]> Git Repo - binutils.git/blob - gdb/ada-lang.c
internal_error: remove need to pass __FILE__/__LINE__
[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, struct objfile *objfile)
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   gdbarch_iterate_over_objfiles_in_search_order
4915     (objfile != NULL ? objfile->arch () : target_gdbarch (),
4916      [&result, lookup_name, match_name] (struct objfile *obj)
4917        {
4918          for (minimal_symbol *msymbol : obj->msymbols ())
4919            {
4920              if (match_name (msymbol->linkage_name (), lookup_name, nullptr)
4921                  && msymbol->type () != mst_solib_trampoline)
4922                {
4923                  result.minsym = msymbol;
4924                  result.objfile = obj;
4925                  return 1;
4926                }
4927            }
4928
4929          return 0;
4930        }, objfile);
4931
4932   return result;
4933 }
4934
4935 /* True if TYPE is definitely an artificial type supplied to a symbol
4936    for which no debugging information was given in the symbol file.  */
4937
4938 static int
4939 is_nondebugging_type (struct type *type)
4940 {
4941   const char *name = ada_type_name (type);
4942
4943   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4944 }
4945
4946 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4947    that are deemed "identical" for practical purposes.
4948
4949    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4950    types and that their number of enumerals is identical (in other
4951    words, type1->num_fields () == type2->num_fields ()).  */
4952
4953 static int
4954 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4955 {
4956   int i;
4957
4958   /* The heuristic we use here is fairly conservative.  We consider
4959      that 2 enumerate types are identical if they have the same
4960      number of enumerals and that all enumerals have the same
4961      underlying value and name.  */
4962
4963   /* All enums in the type should have an identical underlying value.  */
4964   for (i = 0; i < type1->num_fields (); i++)
4965     if (type1->field (i).loc_enumval () != type2->field (i).loc_enumval ())
4966       return 0;
4967
4968   /* All enumerals should also have the same name (modulo any numerical
4969      suffix).  */
4970   for (i = 0; i < type1->num_fields (); i++)
4971     {
4972       const char *name_1 = type1->field (i).name ();
4973       const char *name_2 = type2->field (i).name ();
4974       int len_1 = strlen (name_1);
4975       int len_2 = strlen (name_2);
4976
4977       ada_remove_trailing_digits (type1->field (i).name (), &len_1);
4978       ada_remove_trailing_digits (type2->field (i).name (), &len_2);
4979       if (len_1 != len_2
4980           || strncmp (type1->field (i).name (),
4981                       type2->field (i).name (),
4982                       len_1) != 0)
4983         return 0;
4984     }
4985
4986   return 1;
4987 }
4988
4989 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4990    that are deemed "identical" for practical purposes.  Sometimes,
4991    enumerals are not strictly identical, but their types are so similar
4992    that they can be considered identical.
4993
4994    For instance, consider the following code:
4995
4996       type Color is (Black, Red, Green, Blue, White);
4997       type RGB_Color is new Color range Red .. Blue;
4998
4999    Type RGB_Color is a subrange of an implicit type which is a copy
5000    of type Color. If we call that implicit type RGB_ColorB ("B" is
5001    for "Base Type"), then type RGB_ColorB is a copy of type Color.
5002    As a result, when an expression references any of the enumeral
5003    by name (Eg. "print green"), the expression is technically
5004    ambiguous and the user should be asked to disambiguate. But
5005    doing so would only hinder the user, since it wouldn't matter
5006    what choice he makes, the outcome would always be the same.
5007    So, for practical purposes, we consider them as the same.  */
5008
5009 static int
5010 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
5011 {
5012   int i;
5013
5014   /* Before performing a thorough comparison check of each type,
5015      we perform a series of inexpensive checks.  We expect that these
5016      checks will quickly fail in the vast majority of cases, and thus
5017      help prevent the unnecessary use of a more expensive comparison.
5018      Said comparison also expects us to make some of these checks
5019      (see ada_identical_enum_types_p).  */
5020
5021   /* Quick check: All symbols should have an enum type.  */
5022   for (i = 0; i < syms.size (); i++)
5023     if (syms[i].symbol->type ()->code () != TYPE_CODE_ENUM)
5024       return 0;
5025
5026   /* Quick check: They should all have the same value.  */
5027   for (i = 1; i < syms.size (); i++)
5028     if (syms[i].symbol->value_longest () != syms[0].symbol->value_longest ())
5029       return 0;
5030
5031   /* Quick check: They should all have the same number of enumerals.  */
5032   for (i = 1; i < syms.size (); i++)
5033     if (syms[i].symbol->type ()->num_fields ()
5034         != syms[0].symbol->type ()->num_fields ())
5035       return 0;
5036
5037   /* All the sanity checks passed, so we might have a set of
5038      identical enumeration types.  Perform a more complete
5039      comparison of the type of each symbol.  */
5040   for (i = 1; i < syms.size (); i++)
5041     if (!ada_identical_enum_types_p (syms[i].symbol->type (),
5042                                      syms[0].symbol->type ()))
5043       return 0;
5044
5045   return 1;
5046 }
5047
5048 /* Remove any non-debugging symbols in SYMS that definitely
5049    duplicate other symbols in the list (The only case I know of where
5050    this happens is when object files containing stabs-in-ecoff are
5051    linked with files containing ordinary ecoff debugging symbols (or no
5052    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.  */
5053
5054 static void
5055 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5056 {
5057   int i, j;
5058
5059   /* We should never be called with less than 2 symbols, as there
5060      cannot be any extra symbol in that case.  But it's easy to
5061      handle, since we have nothing to do in that case.  */
5062   if (syms->size () < 2)
5063     return;
5064
5065   i = 0;
5066   while (i < syms->size ())
5067     {
5068       int remove_p = 0;
5069
5070       /* If two symbols have the same name and one of them is a stub type,
5071          the get rid of the stub.  */
5072
5073       if ((*syms)[i].symbol->type ()->is_stub ()
5074           && (*syms)[i].symbol->linkage_name () != NULL)
5075         {
5076           for (j = 0; j < syms->size (); j++)
5077             {
5078               if (j != i
5079                   && !(*syms)[j].symbol->type ()->is_stub ()
5080                   && (*syms)[j].symbol->linkage_name () != NULL
5081                   && strcmp ((*syms)[i].symbol->linkage_name (),
5082                              (*syms)[j].symbol->linkage_name ()) == 0)
5083                 remove_p = 1;
5084             }
5085         }
5086
5087       /* Two symbols with the same name, same class and same address
5088          should be identical.  */
5089
5090       else if ((*syms)[i].symbol->linkage_name () != NULL
5091           && (*syms)[i].symbol->aclass () == LOC_STATIC
5092           && is_nondebugging_type ((*syms)[i].symbol->type ()))
5093         {
5094           for (j = 0; j < syms->size (); j += 1)
5095             {
5096               if (i != j
5097                   && (*syms)[j].symbol->linkage_name () != NULL
5098                   && strcmp ((*syms)[i].symbol->linkage_name (),
5099                              (*syms)[j].symbol->linkage_name ()) == 0
5100                   && ((*syms)[i].symbol->aclass ()
5101                       == (*syms)[j].symbol->aclass ())
5102                   && (*syms)[i].symbol->value_address ()
5103                   == (*syms)[j].symbol->value_address ())
5104                 remove_p = 1;
5105             }
5106         }
5107       
5108       if (remove_p)
5109         syms->erase (syms->begin () + i);
5110       else
5111         i += 1;
5112     }
5113
5114   /* If all the remaining symbols are identical enumerals, then
5115      just keep the first one and discard the rest.
5116
5117      Unlike what we did previously, we do not discard any entry
5118      unless they are ALL identical.  This is because the symbol
5119      comparison is not a strict comparison, but rather a practical
5120      comparison.  If all symbols are considered identical, then
5121      we can just go ahead and use the first one and discard the rest.
5122      But if we cannot reduce the list to a single element, we have
5123      to ask the user to disambiguate anyways.  And if we have to
5124      present a multiple-choice menu, it's less confusing if the list
5125      isn't missing some choices that were identical and yet distinct.  */
5126   if (symbols_are_identical_enums (*syms))
5127     syms->resize (1);
5128 }
5129
5130 /* Given a type that corresponds to a renaming entity, use the type name
5131    to extract the scope (package name or function name, fully qualified,
5132    and following the GNAT encoding convention) where this renaming has been
5133    defined.  */
5134
5135 static std::string
5136 xget_renaming_scope (struct type *renaming_type)
5137 {
5138   /* The renaming types adhere to the following convention:
5139      <scope>__<rename>___<XR extension>.
5140      So, to extract the scope, we search for the "___XR" extension,
5141      and then backtrack until we find the first "__".  */
5142
5143   const char *name = renaming_type->name ();
5144   const char *suffix = strstr (name, "___XR");
5145   const char *last;
5146
5147   /* Now, backtrack a bit until we find the first "__".  Start looking
5148      at suffix - 3, as the <rename> part is at least one character long.  */
5149
5150   for (last = suffix - 3; last > name; last--)
5151     if (last[0] == '_' && last[1] == '_')
5152       break;
5153
5154   /* Make a copy of scope and return it.  */
5155   return std::string (name, last);
5156 }
5157
5158 /* Return nonzero if NAME corresponds to a package name.  */
5159
5160 static int
5161 is_package_name (const char *name)
5162 {
5163   /* Here, We take advantage of the fact that no symbols are generated
5164      for packages, while symbols are generated for each function.
5165      So the condition for NAME represent a package becomes equivalent
5166      to NAME not existing in our list of symbols.  There is only one
5167      small complication with library-level functions (see below).  */
5168
5169   /* If it is a function that has not been defined at library level,
5170      then we should be able to look it up in the symbols.  */
5171   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5172     return 0;
5173
5174   /* Library-level function names start with "_ada_".  See if function
5175      "_ada_" followed by NAME can be found.  */
5176
5177   /* Do a quick check that NAME does not contain "__", since library-level
5178      functions names cannot contain "__" in them.  */
5179   if (strstr (name, "__") != NULL)
5180     return 0;
5181
5182   std::string fun_name = string_printf ("_ada_%s", name);
5183
5184   return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5185 }
5186
5187 /* Return nonzero if SYM corresponds to a renaming entity that is
5188    not visible from FUNCTION_NAME.  */
5189
5190 static int
5191 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5192 {
5193   if (sym->aclass () != LOC_TYPEDEF)
5194     return 0;
5195
5196   std::string scope = xget_renaming_scope (sym->type ());
5197
5198   /* If the rename has been defined in a package, then it is visible.  */
5199   if (is_package_name (scope.c_str ()))
5200     return 0;
5201
5202   /* Check that the rename is in the current function scope by checking
5203      that its name starts with SCOPE.  */
5204
5205   /* If the function name starts with "_ada_", it means that it is
5206      a library-level function.  Strip this prefix before doing the
5207      comparison, as the encoding for the renaming does not contain
5208      this prefix.  */
5209   if (startswith (function_name, "_ada_"))
5210     function_name += 5;
5211
5212   return !startswith (function_name, scope.c_str ());
5213 }
5214
5215 /* Remove entries from SYMS that corresponds to a renaming entity that
5216    is not visible from the function associated with CURRENT_BLOCK or
5217    that is superfluous due to the presence of more specific renaming
5218    information.  Places surviving symbols in the initial entries of
5219    SYMS.
5220
5221    Rationale:
5222    First, in cases where an object renaming is implemented as a
5223    reference variable, GNAT may produce both the actual reference
5224    variable and the renaming encoding.  In this case, we discard the
5225    latter.
5226
5227    Second, GNAT emits a type following a specified encoding for each renaming
5228    entity.  Unfortunately, STABS currently does not support the definition
5229    of types that are local to a given lexical block, so all renamings types
5230    are emitted at library level.  As a consequence, if an application
5231    contains two renaming entities using the same name, and a user tries to
5232    print the value of one of these entities, the result of the ada symbol
5233    lookup will also contain the wrong renaming type.
5234
5235    This function partially covers for this limitation by attempting to
5236    remove from the SYMS list renaming symbols that should be visible
5237    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
5238    method with the current information available.  The implementation
5239    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
5240    
5241       - When the user tries to print a rename in a function while there
5242         is another rename entity defined in a package:  Normally, the
5243         rename in the function has precedence over the rename in the
5244         package, so the latter should be removed from the list.  This is
5245         currently not the case.
5246         
5247       - This function will incorrectly remove valid renames if
5248         the CURRENT_BLOCK corresponds to a function which symbol name
5249         has been changed by an "Export" pragma.  As a consequence,
5250         the user will be unable to print such rename entities.  */
5251
5252 static void
5253 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5254                              const struct block *current_block)
5255 {
5256   struct symbol *current_function;
5257   const char *current_function_name;
5258   int i;
5259   int is_new_style_renaming;
5260
5261   /* If there is both a renaming foo___XR... encoded as a variable and
5262      a simple variable foo in the same block, discard the latter.
5263      First, zero out such symbols, then compress.  */
5264   is_new_style_renaming = 0;
5265   for (i = 0; i < syms->size (); i += 1)
5266     {
5267       struct symbol *sym = (*syms)[i].symbol;
5268       const struct block *block = (*syms)[i].block;
5269       const char *name;
5270       const char *suffix;
5271
5272       if (sym == NULL || sym->aclass () == LOC_TYPEDEF)
5273         continue;
5274       name = sym->linkage_name ();
5275       suffix = strstr (name, "___XR");
5276
5277       if (suffix != NULL)
5278         {
5279           int name_len = suffix - name;
5280           int j;
5281
5282           is_new_style_renaming = 1;
5283           for (j = 0; j < syms->size (); j += 1)
5284             if (i != j && (*syms)[j].symbol != NULL
5285                 && strncmp (name, (*syms)[j].symbol->linkage_name (),
5286                             name_len) == 0
5287                 && block == (*syms)[j].block)
5288               (*syms)[j].symbol = NULL;
5289         }
5290     }
5291   if (is_new_style_renaming)
5292     {
5293       int j, k;
5294
5295       for (j = k = 0; j < syms->size (); j += 1)
5296         if ((*syms)[j].symbol != NULL)
5297             {
5298               (*syms)[k] = (*syms)[j];
5299               k += 1;
5300             }
5301       syms->resize (k);
5302       return;
5303     }
5304
5305   /* Extract the function name associated to CURRENT_BLOCK.
5306      Abort if unable to do so.  */
5307
5308   if (current_block == NULL)
5309     return;
5310
5311   current_function = block_linkage_function (current_block);
5312   if (current_function == NULL)
5313     return;
5314
5315   current_function_name = current_function->linkage_name ();
5316   if (current_function_name == NULL)
5317     return;
5318
5319   /* Check each of the symbols, and remove it from the list if it is
5320      a type corresponding to a renaming that is out of the scope of
5321      the current block.  */
5322
5323   i = 0;
5324   while (i < syms->size ())
5325     {
5326       if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5327           == ADA_OBJECT_RENAMING
5328           && old_renaming_is_invisible ((*syms)[i].symbol,
5329                                         current_function_name))
5330         syms->erase (syms->begin () + i);
5331       else
5332         i += 1;
5333     }
5334 }
5335
5336 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5337    whose name and domain match LOOKUP_NAME and DOMAIN respectively.
5338
5339    Note: This function assumes that RESULT is empty.  */
5340
5341 static void
5342 ada_add_local_symbols (std::vector<struct block_symbol> &result,
5343                        const lookup_name_info &lookup_name,
5344                        const struct block *block, domain_enum domain)
5345 {
5346   while (block != NULL)
5347     {
5348       ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5349
5350       /* If we found a non-function match, assume that's the one.  We
5351          only check this when finding a function boundary, so that we
5352          can accumulate all results from intervening blocks first.  */
5353       if (block->function () != nullptr && is_nonfunction (result))
5354         return;
5355
5356       block = block->superblock ();
5357     }
5358 }
5359
5360 /* An object of this type is used as the callback argument when
5361    calling the map_matching_symbols method.  */
5362
5363 struct match_data
5364 {
5365   explicit match_data (std::vector<struct block_symbol> *rp)
5366     : resultp (rp)
5367   {
5368   }
5369   DISABLE_COPY_AND_ASSIGN (match_data);
5370
5371   bool operator() (struct block_symbol *bsym);
5372
5373   struct objfile *objfile = nullptr;
5374   std::vector<struct block_symbol> *resultp;
5375   struct symbol *arg_sym = nullptr;
5376   bool found_sym = false;
5377 };
5378
5379 /* A callback for add_nonlocal_symbols that adds symbol, found in
5380    BSYM, to a list of symbols.  */
5381
5382 bool
5383 match_data::operator() (struct block_symbol *bsym)
5384 {
5385   const struct block *block = bsym->block;
5386   struct symbol *sym = bsym->symbol;
5387
5388   if (sym == NULL)
5389     {
5390       if (!found_sym && arg_sym != NULL)
5391         add_defn_to_vec (*resultp,
5392                          fixup_symbol_section (arg_sym, objfile),
5393                          block);
5394       found_sym = false;
5395       arg_sym = NULL;
5396     }
5397   else 
5398     {
5399       if (sym->aclass () == LOC_UNRESOLVED)
5400         return true;
5401       else if (sym->is_argument ())
5402         arg_sym = sym;
5403       else
5404         {
5405           found_sym = true;
5406           add_defn_to_vec (*resultp,
5407                            fixup_symbol_section (sym, objfile),
5408                            block);
5409         }
5410     }
5411   return true;
5412 }
5413
5414 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5415    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5416    symbols to RESULT.  Return whether we found such symbols.  */
5417
5418 static int
5419 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5420                          const struct block *block,
5421                          const lookup_name_info &lookup_name,
5422                          domain_enum domain)
5423 {
5424   struct using_direct *renaming;
5425   int defns_mark = result.size ();
5426
5427   symbol_name_matcher_ftype *name_match
5428     = ada_get_symbol_name_matcher (lookup_name);
5429
5430   for (renaming = block_using (block);
5431        renaming != NULL;
5432        renaming = renaming->next)
5433     {
5434       const char *r_name;
5435
5436       /* Avoid infinite recursions: skip this renaming if we are actually
5437          already traversing it.
5438
5439          Currently, symbol lookup in Ada don't use the namespace machinery from
5440          C++/Fortran support: skip namespace imports that use them.  */
5441       if (renaming->searched
5442           || (renaming->import_src != NULL
5443               && renaming->import_src[0] != '\0')
5444           || (renaming->import_dest != NULL
5445               && renaming->import_dest[0] != '\0'))
5446         continue;
5447       renaming->searched = 1;
5448
5449       /* TODO: here, we perform another name-based symbol lookup, which can
5450          pull its own multiple overloads.  In theory, we should be able to do
5451          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5452          not a simple name.  But in order to do this, we would need to enhance
5453          the DWARF reader to associate a symbol to this renaming, instead of a
5454          name.  So, for now, we do something simpler: re-use the C++/Fortran
5455          namespace machinery.  */
5456       r_name = (renaming->alias != NULL
5457                 ? renaming->alias
5458                 : renaming->declaration);
5459       if (name_match (r_name, lookup_name, NULL))
5460         {
5461           lookup_name_info decl_lookup_name (renaming->declaration,
5462                                              lookup_name.match_type ());
5463           ada_add_all_symbols (result, block, decl_lookup_name, domain,
5464                                1, NULL);
5465         }
5466       renaming->searched = 0;
5467     }
5468   return result.size () != defns_mark;
5469 }
5470
5471 /* Implements compare_names, but only applying the comparision using
5472    the given CASING.  */
5473
5474 static int
5475 compare_names_with_case (const char *string1, const char *string2,
5476                          enum case_sensitivity casing)
5477 {
5478   while (*string1 != '\0' && *string2 != '\0')
5479     {
5480       char c1, c2;
5481
5482       if (isspace (*string1) || isspace (*string2))
5483         return strcmp_iw_ordered (string1, string2);
5484
5485       if (casing == case_sensitive_off)
5486         {
5487           c1 = tolower (*string1);
5488           c2 = tolower (*string2);
5489         }
5490       else
5491         {
5492           c1 = *string1;
5493           c2 = *string2;
5494         }
5495       if (c1 != c2)
5496         break;
5497
5498       string1 += 1;
5499       string2 += 1;
5500     }
5501
5502   switch (*string1)
5503     {
5504     case '(':
5505       return strcmp_iw_ordered (string1, string2);
5506     case '_':
5507       if (*string2 == '\0')
5508         {
5509           if (is_name_suffix (string1))
5510             return 0;
5511           else
5512             return 1;
5513         }
5514       /* FALLTHROUGH */
5515     default:
5516       if (*string2 == '(')
5517         return strcmp_iw_ordered (string1, string2);
5518       else
5519         {
5520           if (casing == case_sensitive_off)
5521             return tolower (*string1) - tolower (*string2);
5522           else
5523             return *string1 - *string2;
5524         }
5525     }
5526 }
5527
5528 /* Compare STRING1 to STRING2, with results as for strcmp.
5529    Compatible with strcmp_iw_ordered in that...
5530
5531        strcmp_iw_ordered (STRING1, STRING2) <= 0
5532
5533    ... implies...
5534
5535        compare_names (STRING1, STRING2) <= 0
5536
5537    (they may differ as to what symbols compare equal).  */
5538
5539 static int
5540 compare_names (const char *string1, const char *string2)
5541 {
5542   int result;
5543
5544   /* Similar to what strcmp_iw_ordered does, we need to perform
5545      a case-insensitive comparison first, and only resort to
5546      a second, case-sensitive, comparison if the first one was
5547      not sufficient to differentiate the two strings.  */
5548
5549   result = compare_names_with_case (string1, string2, case_sensitive_off);
5550   if (result == 0)
5551     result = compare_names_with_case (string1, string2, case_sensitive_on);
5552
5553   return result;
5554 }
5555
5556 /* Convenience function to get at the Ada encoded lookup name for
5557    LOOKUP_NAME, as a C string.  */
5558
5559 static const char *
5560 ada_lookup_name (const lookup_name_info &lookup_name)
5561 {
5562   return lookup_name.ada ().lookup_name ().c_str ();
5563 }
5564
5565 /* A helper for add_nonlocal_symbols.  Call expand_matching_symbols
5566    for OBJFILE, then walk the objfile's symtabs and update the
5567    results.  */
5568
5569 static void
5570 map_matching_symbols (struct objfile *objfile,
5571                       const lookup_name_info &lookup_name,
5572                       bool is_wild_match,
5573                       domain_enum domain,
5574                       int global,
5575                       match_data &data)
5576 {
5577   data.objfile = objfile;
5578   objfile->expand_matching_symbols (lookup_name, domain, global,
5579                                     is_wild_match ? nullptr : compare_names);
5580
5581   const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5582   for (compunit_symtab *symtab : objfile->compunits ())
5583     {
5584       const struct block *block
5585         = symtab->blockvector ()->block (block_kind);
5586       if (!iterate_over_symbols_terminated (block, lookup_name,
5587                                             domain, data))
5588         break;
5589     }
5590 }
5591
5592 /* Add to RESULT all non-local symbols whose name and domain match
5593    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5594    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5595    symbols otherwise.  */
5596
5597 static void
5598 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5599                       const lookup_name_info &lookup_name,
5600                       domain_enum domain, int global)
5601 {
5602   struct match_data data (&result);
5603
5604   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5605
5606   for (objfile *objfile : current_program_space->objfiles ())
5607     {
5608       map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5609                             global, data);
5610
5611       for (compunit_symtab *cu : objfile->compunits ())
5612         {
5613           const struct block *global_block
5614             = cu->blockvector ()->global_block ();
5615
5616           if (ada_add_block_renamings (result, global_block, lookup_name,
5617                                        domain))
5618             data.found_sym = true;
5619         }
5620     }
5621
5622   if (result.empty () && global && !is_wild_match)
5623     {
5624       const char *name = ada_lookup_name (lookup_name);
5625       std::string bracket_name = std::string ("<_ada_") + name + '>';
5626       lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5627
5628       for (objfile *objfile : current_program_space->objfiles ())
5629         map_matching_symbols (objfile, name1, false, domain, global, data);
5630     }
5631 }
5632
5633 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5634    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5635    returning the number of matches.  Add these to RESULT.
5636
5637    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5638    symbol match within the nest of blocks whose innermost member is BLOCK,
5639    is the one match returned (no other matches in that or
5640    enclosing blocks is returned).  If there are any matches in or
5641    surrounding BLOCK, then these alone are returned.
5642
5643    Names prefixed with "standard__" are handled specially:
5644    "standard__" is first stripped off (by the lookup_name
5645    constructor), and only static and global symbols are searched.
5646
5647    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5648    to lookup global symbols.  */
5649
5650 static void
5651 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5652                      const struct block *block,
5653                      const lookup_name_info &lookup_name,
5654                      domain_enum domain,
5655                      int full_search,
5656                      int *made_global_lookup_p)
5657 {
5658   struct symbol *sym;
5659
5660   if (made_global_lookup_p)
5661     *made_global_lookup_p = 0;
5662
5663   /* Special case: If the user specifies a symbol name inside package
5664      Standard, do a non-wild matching of the symbol name without
5665      the "standard__" prefix.  This was primarily introduced in order
5666      to allow the user to specifically access the standard exceptions
5667      using, for instance, Standard.Constraint_Error when Constraint_Error
5668      is ambiguous (due to the user defining its own Constraint_Error
5669      entity inside its program).  */
5670   if (lookup_name.ada ().standard_p ())
5671     block = NULL;
5672
5673   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5674
5675   if (block != NULL)
5676     {
5677       if (full_search)
5678         ada_add_local_symbols (result, lookup_name, block, domain);
5679       else
5680         {
5681           /* In the !full_search case we're are being called by
5682              iterate_over_symbols, and we don't want to search
5683              superblocks.  */
5684           ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5685         }
5686       if (!result.empty () || !full_search)
5687         return;
5688     }
5689
5690   /* No non-global symbols found.  Check our cache to see if we have
5691      already performed this search before.  If we have, then return
5692      the same result.  */
5693
5694   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5695                             domain, &sym, &block))
5696     {
5697       if (sym != NULL)
5698         add_defn_to_vec (result, sym, block);
5699       return;
5700     }
5701
5702   if (made_global_lookup_p)
5703     *made_global_lookup_p = 1;
5704
5705   /* Search symbols from all global blocks.  */
5706  
5707   add_nonlocal_symbols (result, lookup_name, domain, 1);
5708
5709   /* Now add symbols from all per-file blocks if we've gotten no hits
5710      (not strictly correct, but perhaps better than an error).  */
5711
5712   if (result.empty ())
5713     add_nonlocal_symbols (result, lookup_name, domain, 0);
5714 }
5715
5716 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5717    is non-zero, enclosing scope and in global scopes.
5718
5719    Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5720    blocks and symbol tables (if any) in which they were found.
5721
5722    When full_search is non-zero, any non-function/non-enumeral
5723    symbol match within the nest of blocks whose innermost member is BLOCK,
5724    is the one match returned (no other matches in that or
5725    enclosing blocks is returned).  If there are any matches in or
5726    surrounding BLOCK, then these alone are returned.
5727
5728    Names prefixed with "standard__" are handled specially: "standard__"
5729    is first stripped off, and only static and global symbols are searched.  */
5730
5731 static std::vector<struct block_symbol>
5732 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5733                                const struct block *block,
5734                                domain_enum domain,
5735                                int full_search)
5736 {
5737   int syms_from_global_search;
5738   std::vector<struct block_symbol> results;
5739
5740   ada_add_all_symbols (results, block, lookup_name,
5741                        domain, full_search, &syms_from_global_search);
5742
5743   remove_extra_symbols (&results);
5744
5745   if (results.empty () && full_search && syms_from_global_search)
5746     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5747
5748   if (results.size () == 1 && full_search && syms_from_global_search)
5749     cache_symbol (ada_lookup_name (lookup_name), domain,
5750                   results[0].symbol, results[0].block);
5751
5752   remove_irrelevant_renamings (&results, block);
5753   return results;
5754 }
5755
5756 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5757    in global scopes, returning (SYM,BLOCK) tuples.
5758
5759    See ada_lookup_symbol_list_worker for further details.  */
5760
5761 std::vector<struct block_symbol>
5762 ada_lookup_symbol_list (const char *name, const struct block *block,
5763                         domain_enum domain)
5764 {
5765   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5766   lookup_name_info lookup_name (name, name_match_type);
5767
5768   return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5769 }
5770
5771 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5772    to 1, but choosing the first symbol found if there are multiple
5773    choices.
5774
5775    The result is stored in *INFO, which must be non-NULL.
5776    If no match is found, INFO->SYM is set to NULL.  */
5777
5778 void
5779 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5780                            domain_enum domain,
5781                            struct block_symbol *info)
5782 {
5783   /* Since we already have an encoded name, wrap it in '<>' to force a
5784      verbatim match.  Otherwise, if the name happens to not look like
5785      an encoded name (because it doesn't include a "__"),
5786      ada_lookup_name_info would re-encode/fold it again, and that
5787      would e.g., incorrectly lowercase object renaming names like
5788      "R28b" -> "r28b".  */
5789   std::string verbatim = add_angle_brackets (name);
5790
5791   gdb_assert (info != NULL);
5792   *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5793 }
5794
5795 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5796    scope and in global scopes, or NULL if none.  NAME is folded and
5797    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5798    choosing the first symbol if there are multiple choices.  */
5799
5800 struct block_symbol
5801 ada_lookup_symbol (const char *name, const struct block *block0,
5802                    domain_enum domain)
5803 {
5804   std::vector<struct block_symbol> candidates
5805     = ada_lookup_symbol_list (name, block0, domain);
5806
5807   if (candidates.empty ())
5808     return {};
5809
5810   block_symbol info = candidates[0];
5811   info.symbol = fixup_symbol_section (info.symbol, NULL);
5812   return info;
5813 }
5814
5815
5816 /* True iff STR is a possible encoded suffix of a normal Ada name
5817    that is to be ignored for matching purposes.  Suffixes of parallel
5818    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5819    are given by any of the regular expressions:
5820
5821    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5822    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5823    TKB              [subprogram suffix for task bodies]
5824    _E[0-9]+[bs]$    [protected object entry suffixes]
5825    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5826
5827    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5828    match is performed.  This sequence is used to differentiate homonyms,
5829    is an optional part of a valid name suffix.  */
5830
5831 static int
5832 is_name_suffix (const char *str)
5833 {
5834   int k;
5835   const char *matching;
5836   const int len = strlen (str);
5837
5838   /* Skip optional leading __[0-9]+.  */
5839
5840   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5841     {
5842       str += 3;
5843       while (isdigit (str[0]))
5844         str += 1;
5845     }
5846   
5847   /* [.$][0-9]+ */
5848
5849   if (str[0] == '.' || str[0] == '$')
5850     {
5851       matching = str + 1;
5852       while (isdigit (matching[0]))
5853         matching += 1;
5854       if (matching[0] == '\0')
5855         return 1;
5856     }
5857
5858   /* ___[0-9]+ */
5859
5860   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5861     {
5862       matching = str + 3;
5863       while (isdigit (matching[0]))
5864         matching += 1;
5865       if (matching[0] == '\0')
5866         return 1;
5867     }
5868
5869   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
5870
5871   if (strcmp (str, "TKB") == 0)
5872     return 1;
5873
5874 #if 0
5875   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5876      with a N at the end.  Unfortunately, the compiler uses the same
5877      convention for other internal types it creates.  So treating
5878      all entity names that end with an "N" as a name suffix causes
5879      some regressions.  For instance, consider the case of an enumerated
5880      type.  To support the 'Image attribute, it creates an array whose
5881      name ends with N.
5882      Having a single character like this as a suffix carrying some
5883      information is a bit risky.  Perhaps we should change the encoding
5884      to be something like "_N" instead.  In the meantime, do not do
5885      the following check.  */
5886   /* Protected Object Subprograms */
5887   if (len == 1 && str [0] == 'N')
5888     return 1;
5889 #endif
5890
5891   /* _E[0-9]+[bs]$ */
5892   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5893     {
5894       matching = str + 3;
5895       while (isdigit (matching[0]))
5896         matching += 1;
5897       if ((matching[0] == 'b' || matching[0] == 's')
5898           && matching [1] == '\0')
5899         return 1;
5900     }
5901
5902   /* ??? We should not modify STR directly, as we are doing below.  This
5903      is fine in this case, but may become problematic later if we find
5904      that this alternative did not work, and want to try matching
5905      another one from the begining of STR.  Since we modified it, we
5906      won't be able to find the begining of the string anymore!  */
5907   if (str[0] == 'X')
5908     {
5909       str += 1;
5910       while (str[0] != '_' && str[0] != '\0')
5911         {
5912           if (str[0] != 'n' && str[0] != 'b')
5913             return 0;
5914           str += 1;
5915         }
5916     }
5917
5918   if (str[0] == '\000')
5919     return 1;
5920
5921   if (str[0] == '_')
5922     {
5923       if (str[1] != '_' || str[2] == '\000')
5924         return 0;
5925       if (str[2] == '_')
5926         {
5927           if (strcmp (str + 3, "JM") == 0)
5928             return 1;
5929           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5930              the LJM suffix in favor of the JM one.  But we will
5931              still accept LJM as a valid suffix for a reasonable
5932              amount of time, just to allow ourselves to debug programs
5933              compiled using an older version of GNAT.  */
5934           if (strcmp (str + 3, "LJM") == 0)
5935             return 1;
5936           if (str[3] != 'X')
5937             return 0;
5938           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5939               || str[4] == 'U' || str[4] == 'P')
5940             return 1;
5941           if (str[4] == 'R' && str[5] != 'T')
5942             return 1;
5943           return 0;
5944         }
5945       if (!isdigit (str[2]))
5946         return 0;
5947       for (k = 3; str[k] != '\0'; k += 1)
5948         if (!isdigit (str[k]) && str[k] != '_')
5949           return 0;
5950       return 1;
5951     }
5952   if (str[0] == '$' && isdigit (str[1]))
5953     {
5954       for (k = 2; str[k] != '\0'; k += 1)
5955         if (!isdigit (str[k]) && str[k] != '_')
5956           return 0;
5957       return 1;
5958     }
5959   return 0;
5960 }
5961
5962 /* Return non-zero if the string starting at NAME and ending before
5963    NAME_END contains no capital letters.  */
5964
5965 static int
5966 is_valid_name_for_wild_match (const char *name0)
5967 {
5968   std::string decoded_name = ada_decode (name0);
5969   int i;
5970
5971   /* If the decoded name starts with an angle bracket, it means that
5972      NAME0 does not follow the GNAT encoding format.  It should then
5973      not be allowed as a possible wild match.  */
5974   if (decoded_name[0] == '<')
5975     return 0;
5976
5977   for (i=0; decoded_name[i] != '\0'; i++)
5978     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5979       return 0;
5980
5981   return 1;
5982 }
5983
5984 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5985    character which could start a simple name.  Assumes that *NAMEP points
5986    somewhere inside the string beginning at NAME0.  */
5987
5988 static int
5989 advance_wild_match (const char **namep, const char *name0, char target0)
5990 {
5991   const char *name = *namep;
5992
5993   while (1)
5994     {
5995       char t0, t1;
5996
5997       t0 = *name;
5998       if (t0 == '_')
5999         {
6000           t1 = name[1];
6001           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6002             {
6003               name += 1;
6004               if (name == name0 + 5 && startswith (name0, "_ada"))
6005                 break;
6006               else
6007                 name += 1;
6008             }
6009           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6010                                  || name[2] == target0))
6011             {
6012               name += 2;
6013               break;
6014             }
6015           else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
6016             {
6017               /* Names like "pkg__B_N__name", where N is a number, are
6018                  block-local.  We can handle these by simply skipping
6019                  the "B_" here.  */
6020               name += 4;
6021             }
6022           else
6023             return 0;
6024         }
6025       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6026         name += 1;
6027       else
6028         return 0;
6029     }
6030
6031   *namep = name;
6032   return 1;
6033 }
6034
6035 /* Return true iff NAME encodes a name of the form prefix.PATN.
6036    Ignores any informational suffixes of NAME (i.e., for which
6037    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
6038    simple name.  */
6039
6040 static bool
6041 wild_match (const char *name, const char *patn)
6042 {
6043   const char *p;
6044   const char *name0 = name;
6045
6046   if (startswith (name, "___ghost_"))
6047     name += 9;
6048
6049   while (1)
6050     {
6051       const char *match = name;
6052
6053       if (*name == *patn)
6054         {
6055           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6056             if (*p != *name)
6057               break;
6058           if (*p == '\0' && is_name_suffix (name))
6059             return match == name0 || is_valid_name_for_wild_match (name0);
6060
6061           if (name[-1] == '_')
6062             name -= 1;
6063         }
6064       if (!advance_wild_match (&name, name0, *patn))
6065         return false;
6066     }
6067 }
6068
6069 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
6070    necessary).  OBJFILE is the section containing BLOCK.  */
6071
6072 static void
6073 ada_add_block_symbols (std::vector<struct block_symbol> &result,
6074                        const struct block *block,
6075                        const lookup_name_info &lookup_name,
6076                        domain_enum domain, struct objfile *objfile)
6077 {
6078   struct block_iterator iter;
6079   /* A matching argument symbol, if any.  */
6080   struct symbol *arg_sym;
6081   /* Set true when we find a matching non-argument symbol.  */
6082   bool found_sym;
6083   struct symbol *sym;
6084
6085   arg_sym = NULL;
6086   found_sym = false;
6087   for (sym = block_iter_match_first (block, lookup_name, &iter);
6088        sym != NULL;
6089        sym = block_iter_match_next (lookup_name, &iter))
6090     {
6091       if (symbol_matches_domain (sym->language (), sym->domain (), domain))
6092         {
6093           if (sym->aclass () != LOC_UNRESOLVED)
6094             {
6095               if (sym->is_argument ())
6096                 arg_sym = sym;
6097               else
6098                 {
6099                   found_sym = true;
6100                   add_defn_to_vec (result,
6101                                    fixup_symbol_section (sym, objfile),
6102                                    block);
6103                 }
6104             }
6105         }
6106     }
6107
6108   /* Handle renamings.  */
6109
6110   if (ada_add_block_renamings (result, block, lookup_name, domain))
6111     found_sym = true;
6112
6113   if (!found_sym && arg_sym != NULL)
6114     {
6115       add_defn_to_vec (result,
6116                        fixup_symbol_section (arg_sym, objfile),
6117                        block);
6118     }
6119
6120   if (!lookup_name.ada ().wild_match_p ())
6121     {
6122       arg_sym = NULL;
6123       found_sym = false;
6124       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6125       const char *name = ada_lookup_name.c_str ();
6126       size_t name_len = ada_lookup_name.size ();
6127
6128       ALL_BLOCK_SYMBOLS (block, iter, sym)
6129       {
6130         if (symbol_matches_domain (sym->language (),
6131                                    sym->domain (), domain))
6132           {
6133             int cmp;
6134
6135             cmp = (int) '_' - (int) sym->linkage_name ()[0];
6136             if (cmp == 0)
6137               {
6138                 cmp = !startswith (sym->linkage_name (), "_ada_");
6139                 if (cmp == 0)
6140                   cmp = strncmp (name, sym->linkage_name () + 5,
6141                                  name_len);
6142               }
6143
6144             if (cmp == 0
6145                 && is_name_suffix (sym->linkage_name () + name_len + 5))
6146               {
6147                 if (sym->aclass () != LOC_UNRESOLVED)
6148                   {
6149                     if (sym->is_argument ())
6150                       arg_sym = sym;
6151                     else
6152                       {
6153                         found_sym = true;
6154                         add_defn_to_vec (result,
6155                                          fixup_symbol_section (sym, objfile),
6156                                          block);
6157                       }
6158                   }
6159               }
6160           }
6161       }
6162
6163       /* NOTE: This really shouldn't be needed for _ada_ symbols.
6164          They aren't parameters, right?  */
6165       if (!found_sym && arg_sym != NULL)
6166         {
6167           add_defn_to_vec (result,
6168                            fixup_symbol_section (arg_sym, objfile),
6169                            block);
6170         }
6171     }
6172 }
6173 \f
6174
6175                                 /* Symbol Completion */
6176
6177 /* See symtab.h.  */
6178
6179 bool
6180 ada_lookup_name_info::matches
6181   (const char *sym_name,
6182    symbol_name_match_type match_type,
6183    completion_match_result *comp_match_res) const
6184 {
6185   bool match = false;
6186   const char *text = m_encoded_name.c_str ();
6187   size_t text_len = m_encoded_name.size ();
6188
6189   /* First, test against the fully qualified name of the symbol.  */
6190
6191   if (strncmp (sym_name, text, text_len) == 0)
6192     match = true;
6193
6194   std::string decoded_name = ada_decode (sym_name);
6195   if (match && !m_encoded_p)
6196     {
6197       /* One needed check before declaring a positive match is to verify
6198          that iff we are doing a verbatim match, the decoded version
6199          of the symbol name starts with '<'.  Otherwise, this symbol name
6200          is not a suitable completion.  */
6201
6202       bool has_angle_bracket = (decoded_name[0] == '<');
6203       match = (has_angle_bracket == m_verbatim_p);
6204     }
6205
6206   if (match && !m_verbatim_p)
6207     {
6208       /* When doing non-verbatim match, another check that needs to
6209          be done is to verify that the potentially matching symbol name
6210          does not include capital letters, because the ada-mode would
6211          not be able to understand these symbol names without the
6212          angle bracket notation.  */
6213       const char *tmp;
6214
6215       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6216       if (*tmp != '\0')
6217         match = false;
6218     }
6219
6220   /* Second: Try wild matching...  */
6221
6222   if (!match && m_wild_match_p)
6223     {
6224       /* Since we are doing wild matching, this means that TEXT
6225          may represent an unqualified symbol name.  We therefore must
6226          also compare TEXT against the unqualified name of the symbol.  */
6227       sym_name = ada_unqualified_name (decoded_name.c_str ());
6228
6229       if (strncmp (sym_name, text, text_len) == 0)
6230         match = true;
6231     }
6232
6233   /* Finally: If we found a match, prepare the result to return.  */
6234
6235   if (!match)
6236     return false;
6237
6238   if (comp_match_res != NULL)
6239     {
6240       std::string &match_str = comp_match_res->match.storage ();
6241
6242       if (!m_encoded_p)
6243         match_str = ada_decode (sym_name);
6244       else
6245         {
6246           if (m_verbatim_p)
6247             match_str = add_angle_brackets (sym_name);
6248           else
6249             match_str = sym_name;
6250
6251         }
6252
6253       comp_match_res->set_match (match_str.c_str ());
6254     }
6255
6256   return true;
6257 }
6258
6259                                 /* Field Access */
6260
6261 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6262    for tagged types.  */
6263
6264 static int
6265 ada_is_dispatch_table_ptr_type (struct type *type)
6266 {
6267   const char *name;
6268
6269   if (type->code () != TYPE_CODE_PTR)
6270     return 0;
6271
6272   name = type->target_type ()->name ();
6273   if (name == NULL)
6274     return 0;
6275
6276   return (strcmp (name, "ada__tags__dispatch_table") == 0);
6277 }
6278
6279 /* Return non-zero if TYPE is an interface tag.  */
6280
6281 static int
6282 ada_is_interface_tag (struct type *type)
6283 {
6284   const char *name = type->name ();
6285
6286   if (name == NULL)
6287     return 0;
6288
6289   return (strcmp (name, "ada__tags__interface_tag") == 0);
6290 }
6291
6292 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6293    to be invisible to users.  */
6294
6295 int
6296 ada_is_ignored_field (struct type *type, int field_num)
6297 {
6298   if (field_num < 0 || field_num > type->num_fields ())
6299     return 1;
6300
6301   /* Check the name of that field.  */
6302   {
6303     const char *name = type->field (field_num).name ();
6304
6305     /* Anonymous field names should not be printed.
6306        brobecker/2007-02-20: I don't think this can actually happen
6307        but we don't want to print the value of anonymous fields anyway.  */
6308     if (name == NULL)
6309       return 1;
6310
6311     /* Normally, fields whose name start with an underscore ("_")
6312        are fields that have been internally generated by the compiler,
6313        and thus should not be printed.  The "_parent" field is special,
6314        however: This is a field internally generated by the compiler
6315        for tagged types, and it contains the components inherited from
6316        the parent type.  This field should not be printed as is, but
6317        should not be ignored either.  */
6318     if (name[0] == '_' && !startswith (name, "_parent"))
6319       return 1;
6320
6321     /* The compiler doesn't document this, but sometimes it emits
6322        a field whose name starts with a capital letter, like 'V148s'.
6323        These aren't marked as artificial in any way, but we know they
6324        should be ignored.  However, wrapper fields should not be
6325        ignored.  */
6326     if (name[0] == 'S' || name[0] == 'R' || name[0] == 'O')
6327       {
6328         /* Wrapper field.  */
6329       }
6330     else if (isupper (name[0]))
6331       return 1;
6332   }
6333
6334   /* If this is the dispatch table of a tagged type or an interface tag,
6335      then ignore.  */
6336   if (ada_is_tagged_type (type, 1)
6337       && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
6338           || ada_is_interface_tag (type->field (field_num).type ())))
6339     return 1;
6340
6341   /* Not a special field, so it should not be ignored.  */
6342   return 0;
6343 }
6344
6345 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
6346    pointer or reference type whose ultimate target has a tag field.  */
6347
6348 int
6349 ada_is_tagged_type (struct type *type, int refok)
6350 {
6351   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6352 }
6353
6354 /* True iff TYPE represents the type of X'Tag */
6355
6356 int
6357 ada_is_tag_type (struct type *type)
6358 {
6359   type = ada_check_typedef (type);
6360
6361   if (type == NULL || type->code () != TYPE_CODE_PTR)
6362     return 0;
6363   else
6364     {
6365       const char *name = ada_type_name (type->target_type ());
6366
6367       return (name != NULL
6368               && strcmp (name, "ada__tags__dispatch_table") == 0);
6369     }
6370 }
6371
6372 /* The type of the tag on VAL.  */
6373
6374 static struct type *
6375 ada_tag_type (struct value *val)
6376 {
6377   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6378 }
6379
6380 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6381    retired at Ada 05).  */
6382
6383 static int
6384 is_ada95_tag (struct value *tag)
6385 {
6386   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6387 }
6388
6389 /* The value of the tag on VAL.  */
6390
6391 static struct value *
6392 ada_value_tag (struct value *val)
6393 {
6394   return ada_value_struct_elt (val, "_tag", 0);
6395 }
6396
6397 /* The value of the tag on the object of type TYPE whose contents are
6398    saved at VALADDR, if it is non-null, or is at memory address
6399    ADDRESS.  */
6400
6401 static struct value *
6402 value_tag_from_contents_and_address (struct type *type,
6403                                      const gdb_byte *valaddr,
6404                                      CORE_ADDR address)
6405 {
6406   int tag_byte_offset;
6407   struct type *tag_type;
6408
6409   gdb::array_view<const gdb_byte> contents;
6410   if (valaddr != nullptr)
6411     contents = gdb::make_array_view (valaddr, type->length ());
6412   struct type *resolved_type = resolve_dynamic_type (type, contents, address);
6413   if (find_struct_field ("_tag", resolved_type, 0, &tag_type, &tag_byte_offset,
6414                          NULL, NULL, NULL))
6415     {
6416       const gdb_byte *valaddr1 = ((valaddr == NULL)
6417                                   ? NULL
6418                                   : valaddr + tag_byte_offset);
6419       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6420
6421       return value_from_contents_and_address (tag_type, valaddr1, address1);
6422     }
6423   return NULL;
6424 }
6425
6426 static struct type *
6427 type_from_tag (struct value *tag)
6428 {
6429   gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6430
6431   if (type_name != NULL)
6432     return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6433   return NULL;
6434 }
6435
6436 /* Given a value OBJ of a tagged type, return a value of this
6437    type at the base address of the object.  The base address, as
6438    defined in Ada.Tags, it is the address of the primary tag of
6439    the object, and therefore where the field values of its full
6440    view can be fetched.  */
6441
6442 struct value *
6443 ada_tag_value_at_base_address (struct value *obj)
6444 {
6445   struct value *val;
6446   LONGEST offset_to_top = 0;
6447   struct type *ptr_type, *obj_type;
6448   struct value *tag;
6449   CORE_ADDR base_address;
6450
6451   obj_type = value_type (obj);
6452
6453   /* It is the responsability of the caller to deref pointers.  */
6454
6455   if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6456     return obj;
6457
6458   tag = ada_value_tag (obj);
6459   if (!tag)
6460     return obj;
6461
6462   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6463
6464   if (is_ada95_tag (tag))
6465     return obj;
6466
6467   struct type *offset_type
6468     = language_lookup_primitive_type (language_def (language_ada),
6469                                       target_gdbarch(), "storage_offset");
6470   ptr_type = lookup_pointer_type (offset_type);
6471   val = value_cast (ptr_type, tag);
6472   if (!val)
6473     return obj;
6474
6475   /* It is perfectly possible that an exception be raised while
6476      trying to determine the base address, just like for the tag;
6477      see ada_tag_name for more details.  We do not print the error
6478      message for the same reason.  */
6479
6480   try
6481     {
6482       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6483     }
6484
6485   catch (const gdb_exception_error &e)
6486     {
6487       return obj;
6488     }
6489
6490   /* If offset is null, nothing to do.  */
6491
6492   if (offset_to_top == 0)
6493     return obj;
6494
6495   /* -1 is a special case in Ada.Tags; however, what should be done
6496      is not quite clear from the documentation.  So do nothing for
6497      now.  */
6498
6499   if (offset_to_top == -1)
6500     return obj;
6501
6502   /* Storage_Offset'Last is used to indicate that a dynamic offset to
6503      top is used.  In this situation the offset is stored just after
6504      the tag, in the object itself.  */
6505   ULONGEST last = (((ULONGEST) 1) << (8 * offset_type->length () - 1)) - 1;
6506   if (offset_to_top == last)
6507     {
6508       struct value *tem = value_addr (tag);
6509       tem = value_ptradd (tem, 1);
6510       tem = value_cast (ptr_type, tem);
6511       offset_to_top = value_as_long (value_ind (tem));
6512     }
6513
6514   if (offset_to_top > 0)
6515     {
6516       /* OFFSET_TO_TOP used to be a positive value to be subtracted
6517          from the base address.  This was however incompatible with
6518          C++ dispatch table: C++ uses a *negative* value to *add*
6519          to the base address.  Ada's convention has therefore been
6520          changed in GNAT 19.0w 20171023: since then, C++ and Ada
6521          use the same convention.  Here, we support both cases by
6522          checking the sign of OFFSET_TO_TOP.  */
6523       offset_to_top = -offset_to_top;
6524     }
6525
6526   base_address = value_address (obj) + offset_to_top;
6527   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6528
6529   /* Make sure that we have a proper tag at the new address.
6530      Otherwise, offset_to_top is bogus (which can happen when
6531      the object is not initialized yet).  */
6532
6533   if (!tag)
6534     return obj;
6535
6536   obj_type = type_from_tag (tag);
6537
6538   if (!obj_type)
6539     return obj;
6540
6541   return value_from_contents_and_address (obj_type, NULL, base_address);
6542 }
6543
6544 /* Return the "ada__tags__type_specific_data" type.  */
6545
6546 static struct type *
6547 ada_get_tsd_type (struct inferior *inf)
6548 {
6549   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6550
6551   if (data->tsd_type == 0)
6552     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6553   return data->tsd_type;
6554 }
6555
6556 /* Return the TSD (type-specific data) associated to the given TAG.
6557    TAG is assumed to be the tag of a tagged-type entity.
6558
6559    May return NULL if we are unable to get the TSD.  */
6560
6561 static struct value *
6562 ada_get_tsd_from_tag (struct value *tag)
6563 {
6564   struct value *val;
6565   struct type *type;
6566
6567   /* First option: The TSD is simply stored as a field of our TAG.
6568      Only older versions of GNAT would use this format, but we have
6569      to test it first, because there are no visible markers for
6570      the current approach except the absence of that field.  */
6571
6572   val = ada_value_struct_elt (tag, "tsd", 1);
6573   if (val)
6574     return val;
6575
6576   /* Try the second representation for the dispatch table (in which
6577      there is no explicit 'tsd' field in the referent of the tag pointer,
6578      and instead the tsd pointer is stored just before the dispatch
6579      table.  */
6580
6581   type = ada_get_tsd_type (current_inferior());
6582   if (type == NULL)
6583     return NULL;
6584   type = lookup_pointer_type (lookup_pointer_type (type));
6585   val = value_cast (type, tag);
6586   if (val == NULL)
6587     return NULL;
6588   return value_ind (value_ptradd (val, -1));
6589 }
6590
6591 /* Given the TSD of a tag (type-specific data), return a string
6592    containing the name of the associated type.
6593
6594    May return NULL if we are unable to determine the tag name.  */
6595
6596 static gdb::unique_xmalloc_ptr<char>
6597 ada_tag_name_from_tsd (struct value *tsd)
6598 {
6599   struct value *val;
6600
6601   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6602   if (val == NULL)
6603     return NULL;
6604   gdb::unique_xmalloc_ptr<char> buffer
6605     = target_read_string (value_as_address (val), INT_MAX);
6606   if (buffer == nullptr)
6607     return nullptr;
6608
6609   try
6610     {
6611       /* Let this throw an exception on error.  If the data is
6612          uninitialized, we'd rather not have the user see a
6613          warning.  */
6614       const char *folded = ada_fold_name (buffer.get (), true);
6615       return make_unique_xstrdup (folded);
6616     }
6617   catch (const gdb_exception &)
6618     {
6619       return nullptr;
6620     }
6621 }
6622
6623 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6624    a C string.
6625
6626    Return NULL if the TAG is not an Ada tag, or if we were unable to
6627    determine the name of that tag.  */
6628
6629 gdb::unique_xmalloc_ptr<char>
6630 ada_tag_name (struct value *tag)
6631 {
6632   gdb::unique_xmalloc_ptr<char> name;
6633
6634   if (!ada_is_tag_type (value_type (tag)))
6635     return NULL;
6636
6637   /* It is perfectly possible that an exception be raised while trying
6638      to determine the TAG's name, even under normal circumstances:
6639      The associated variable may be uninitialized or corrupted, for
6640      instance. We do not let any exception propagate past this point.
6641      instead we return NULL.
6642
6643      We also do not print the error message either (which often is very
6644      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6645      the caller print a more meaningful message if necessary.  */
6646   try
6647     {
6648       struct value *tsd = ada_get_tsd_from_tag (tag);
6649
6650       if (tsd != NULL)
6651         name = ada_tag_name_from_tsd (tsd);
6652     }
6653   catch (const gdb_exception_error &e)
6654     {
6655     }
6656
6657   return name;
6658 }
6659
6660 /* The parent type of TYPE, or NULL if none.  */
6661
6662 struct type *
6663 ada_parent_type (struct type *type)
6664 {
6665   int i;
6666
6667   type = ada_check_typedef (type);
6668
6669   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6670     return NULL;
6671
6672   for (i = 0; i < type->num_fields (); i += 1)
6673     if (ada_is_parent_field (type, i))
6674       {
6675         struct type *parent_type = type->field (i).type ();
6676
6677         /* If the _parent field is a pointer, then dereference it.  */
6678         if (parent_type->code () == TYPE_CODE_PTR)
6679           parent_type = parent_type->target_type ();
6680         /* If there is a parallel XVS type, get the actual base type.  */
6681         parent_type = ada_get_base_type (parent_type);
6682
6683         return ada_check_typedef (parent_type);
6684       }
6685
6686   return NULL;
6687 }
6688
6689 /* True iff field number FIELD_NUM of structure type TYPE contains the
6690    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6691    a structure type with at least FIELD_NUM+1 fields.  */
6692
6693 int
6694 ada_is_parent_field (struct type *type, int field_num)
6695 {
6696   const char *name = ada_check_typedef (type)->field (field_num).name ();
6697
6698   return (name != NULL
6699           && (startswith (name, "PARENT")
6700               || startswith (name, "_parent")));
6701 }
6702
6703 /* True iff field number FIELD_NUM of structure type TYPE is a
6704    transparent wrapper field (which should be silently traversed when doing
6705    field selection and flattened when printing).  Assumes TYPE is a
6706    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6707    structures.  */
6708
6709 int
6710 ada_is_wrapper_field (struct type *type, int field_num)
6711 {
6712   const char *name = type->field (field_num).name ();
6713
6714   if (name != NULL && strcmp (name, "RETVAL") == 0)
6715     {
6716       /* This happens in functions with "out" or "in out" parameters
6717          which are passed by copy.  For such functions, GNAT describes
6718          the function's return type as being a struct where the return
6719          value is in a field called RETVAL, and where the other "out"
6720          or "in out" parameters are fields of that struct.  This is not
6721          a wrapper.  */
6722       return 0;
6723     }
6724
6725   return (name != NULL
6726           && (startswith (name, "PARENT")
6727               || strcmp (name, "REP") == 0
6728               || startswith (name, "_parent")
6729               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6730 }
6731
6732 /* True iff field number FIELD_NUM of structure or union type TYPE
6733    is a variant wrapper.  Assumes TYPE is a structure type with at least
6734    FIELD_NUM+1 fields.  */
6735
6736 int
6737 ada_is_variant_part (struct type *type, int field_num)
6738 {
6739   /* Only Ada types are eligible.  */
6740   if (!ADA_TYPE_P (type))
6741     return 0;
6742
6743   struct type *field_type = type->field (field_num).type ();
6744
6745   return (field_type->code () == TYPE_CODE_UNION
6746           || (is_dynamic_field (type, field_num)
6747               && (field_type->target_type ()->code ()
6748                   == TYPE_CODE_UNION)));
6749 }
6750
6751 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6752    whose discriminants are contained in the record type OUTER_TYPE,
6753    returns the type of the controlling discriminant for the variant.
6754    May return NULL if the type could not be found.  */
6755
6756 struct type *
6757 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6758 {
6759   const char *name = ada_variant_discrim_name (var_type);
6760
6761   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6762 }
6763
6764 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6765    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6766    represents a 'when others' clause; otherwise 0.  */
6767
6768 static int
6769 ada_is_others_clause (struct type *type, int field_num)
6770 {
6771   const char *name = type->field (field_num).name ();
6772
6773   return (name != NULL && name[0] == 'O');
6774 }
6775
6776 /* Assuming that TYPE0 is the type of the variant part of a record,
6777    returns the name of the discriminant controlling the variant.
6778    The value is valid until the next call to ada_variant_discrim_name.  */
6779
6780 const char *
6781 ada_variant_discrim_name (struct type *type0)
6782 {
6783   static std::string result;
6784   struct type *type;
6785   const char *name;
6786   const char *discrim_end;
6787   const char *discrim_start;
6788
6789   if (type0->code () == TYPE_CODE_PTR)
6790     type = type0->target_type ();
6791   else
6792     type = type0;
6793
6794   name = ada_type_name (type);
6795
6796   if (name == NULL || name[0] == '\000')
6797     return "";
6798
6799   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6800        discrim_end -= 1)
6801     {
6802       if (startswith (discrim_end, "___XVN"))
6803         break;
6804     }
6805   if (discrim_end == name)
6806     return "";
6807
6808   for (discrim_start = discrim_end; discrim_start != name + 3;
6809        discrim_start -= 1)
6810     {
6811       if (discrim_start == name + 1)
6812         return "";
6813       if ((discrim_start > name + 3
6814            && startswith (discrim_start - 3, "___"))
6815           || discrim_start[-1] == '.')
6816         break;
6817     }
6818
6819   result = std::string (discrim_start, discrim_end - discrim_start);
6820   return result.c_str ();
6821 }
6822
6823 /* Scan STR for a subtype-encoded number, beginning at position K.
6824    Put the position of the character just past the number scanned in
6825    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
6826    Return 1 if there was a valid number at the given position, and 0
6827    otherwise.  A "subtype-encoded" number consists of the absolute value
6828    in decimal, followed by the letter 'm' to indicate a negative number.
6829    Assumes 0m does not occur.  */
6830
6831 int
6832 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6833 {
6834   ULONGEST RU;
6835
6836   if (!isdigit (str[k]))
6837     return 0;
6838
6839   /* Do it the hard way so as not to make any assumption about
6840      the relationship of unsigned long (%lu scan format code) and
6841      LONGEST.  */
6842   RU = 0;
6843   while (isdigit (str[k]))
6844     {
6845       RU = RU * 10 + (str[k] - '0');
6846       k += 1;
6847     }
6848
6849   if (str[k] == 'm')
6850     {
6851       if (R != NULL)
6852         *R = (-(LONGEST) (RU - 1)) - 1;
6853       k += 1;
6854     }
6855   else if (R != NULL)
6856     *R = (LONGEST) RU;
6857
6858   /* NOTE on the above: Technically, C does not say what the results of
6859      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6860      number representable as a LONGEST (although either would probably work
6861      in most implementations).  When RU>0, the locution in the then branch
6862      above is always equivalent to the negative of RU.  */
6863
6864   if (new_k != NULL)
6865     *new_k = k;
6866   return 1;
6867 }
6868
6869 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6870    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6871    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
6872
6873 static int
6874 ada_in_variant (LONGEST val, struct type *type, int field_num)
6875 {
6876   const char *name = type->field (field_num).name ();
6877   int p;
6878
6879   p = 0;
6880   while (1)
6881     {
6882       switch (name[p])
6883         {
6884         case '\0':
6885           return 0;
6886         case 'S':
6887           {
6888             LONGEST W;
6889
6890             if (!ada_scan_number (name, p + 1, &W, &p))
6891               return 0;
6892             if (val == W)
6893               return 1;
6894             break;
6895           }
6896         case 'R':
6897           {
6898             LONGEST L, U;
6899
6900             if (!ada_scan_number (name, p + 1, &L, &p)
6901                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6902               return 0;
6903             if (val >= L && val <= U)
6904               return 1;
6905             break;
6906           }
6907         case 'O':
6908           return 1;
6909         default:
6910           return 0;
6911         }
6912     }
6913 }
6914
6915 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
6916
6917 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6918    ARG_TYPE, extract and return the value of one of its (non-static)
6919    fields.  FIELDNO says which field.   Differs from value_primitive_field
6920    only in that it can handle packed values of arbitrary type.  */
6921
6922 struct value *
6923 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6924                            struct type *arg_type)
6925 {
6926   struct type *type;
6927
6928   arg_type = ada_check_typedef (arg_type);
6929   type = arg_type->field (fieldno).type ();
6930
6931   /* Handle packed fields.  It might be that the field is not packed
6932      relative to its containing structure, but the structure itself is
6933      packed; in this case we must take the bit-field path.  */
6934   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6935     {
6936       int bit_pos = arg_type->field (fieldno).loc_bitpos ();
6937       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6938
6939       return ada_value_primitive_packed_val (arg1,
6940                                              value_contents (arg1).data (),
6941                                              offset + bit_pos / 8,
6942                                              bit_pos % 8, bit_size, type);
6943     }
6944   else
6945     return value_primitive_field (arg1, offset, fieldno, arg_type);
6946 }
6947
6948 /* Find field with name NAME in object of type TYPE.  If found, 
6949    set the following for each argument that is non-null:
6950     - *FIELD_TYPE_P to the field's type; 
6951     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
6952       an object of that type;
6953     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
6954     - *BIT_SIZE_P to its size in bits if the field is packed, and 
6955       0 otherwise;
6956    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6957    fields up to but not including the desired field, or by the total
6958    number of fields if not found.   A NULL value of NAME never
6959    matches; the function just counts visible fields in this case.
6960    
6961    Notice that we need to handle when a tagged record hierarchy
6962    has some components with the same name, like in this scenario:
6963
6964       type Top_T is tagged record
6965          N : Integer := 1;
6966          U : Integer := 974;
6967          A : Integer := 48;
6968       end record;
6969
6970       type Middle_T is new Top.Top_T with record
6971          N : Character := 'a';
6972          C : Integer := 3;
6973       end record;
6974
6975      type Bottom_T is new Middle.Middle_T with record
6976         N : Float := 4.0;
6977         C : Character := '5';
6978         X : Integer := 6;
6979         A : Character := 'J';
6980      end record;
6981
6982    Let's say we now have a variable declared and initialized as follow:
6983
6984      TC : Top_A := new Bottom_T;
6985
6986    And then we use this variable to call this function
6987
6988      procedure Assign (Obj: in out Top_T; TV : Integer);
6989
6990    as follow:
6991
6992       Assign (Top_T (B), 12);
6993
6994    Now, we're in the debugger, and we're inside that procedure
6995    then and we want to print the value of obj.c:
6996
6997    Usually, the tagged record or one of the parent type owns the
6998    component to print and there's no issue but in this particular
6999    case, what does it mean to ask for Obj.C? Since the actual
7000    type for object is type Bottom_T, it could mean two things: type
7001    component C from the Middle_T view, but also component C from
7002    Bottom_T.  So in that "undefined" case, when the component is
7003    not found in the non-resolved type (which includes all the
7004    components of the parent type), then resolve it and see if we
7005    get better luck once expanded.
7006
7007    In the case of homonyms in the derived tagged type, we don't
7008    guaranty anything, and pick the one that's easiest for us
7009    to program.
7010
7011    Returns 1 if found, 0 otherwise.  */
7012
7013 static int
7014 find_struct_field (const char *name, struct type *type, int offset,
7015                    struct type **field_type_p,
7016                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7017                    int *index_p)
7018 {
7019   int i;
7020   int parent_offset = -1;
7021
7022   type = ada_check_typedef (type);
7023
7024   if (field_type_p != NULL)
7025     *field_type_p = NULL;
7026   if (byte_offset_p != NULL)
7027     *byte_offset_p = 0;
7028   if (bit_offset_p != NULL)
7029     *bit_offset_p = 0;
7030   if (bit_size_p != NULL)
7031     *bit_size_p = 0;
7032
7033   for (i = 0; i < type->num_fields (); i += 1)
7034     {
7035       /* These can't be computed using TYPE_FIELD_BITPOS for a dynamic
7036          type.  However, we only need the values to be correct when
7037          the caller asks for them.  */
7038       int bit_pos = 0, fld_offset = 0;
7039       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7040         {
7041           bit_pos = type->field (i).loc_bitpos ();
7042           fld_offset = offset + bit_pos / 8;
7043         }
7044
7045       const char *t_field_name = type->field (i).name ();
7046
7047       if (t_field_name == NULL)
7048         continue;
7049
7050       else if (ada_is_parent_field (type, i))
7051         {
7052           /* This is a field pointing us to the parent type of a tagged
7053              type.  As hinted in this function's documentation, we give
7054              preference to fields in the current record first, so what
7055              we do here is just record the index of this field before
7056              we skip it.  If it turns out we couldn't find our field
7057              in the current record, then we'll get back to it and search
7058              inside it whether the field might exist in the parent.  */
7059
7060           parent_offset = i;
7061           continue;
7062         }
7063
7064       else if (name != NULL && field_name_match (t_field_name, name))
7065         {
7066           int bit_size = TYPE_FIELD_BITSIZE (type, i);
7067
7068           if (field_type_p != NULL)
7069             *field_type_p = type->field (i).type ();
7070           if (byte_offset_p != NULL)
7071             *byte_offset_p = fld_offset;
7072           if (bit_offset_p != NULL)
7073             *bit_offset_p = bit_pos % 8;
7074           if (bit_size_p != NULL)
7075             *bit_size_p = bit_size;
7076           return 1;
7077         }
7078       else if (ada_is_wrapper_field (type, i))
7079         {
7080           if (find_struct_field (name, type->field (i).type (), fld_offset,
7081                                  field_type_p, byte_offset_p, bit_offset_p,
7082                                  bit_size_p, index_p))
7083             return 1;
7084         }
7085       else if (ada_is_variant_part (type, i))
7086         {
7087           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
7088              fixed type?? */
7089           int j;
7090           struct type *field_type
7091             = ada_check_typedef (type->field (i).type ());
7092
7093           for (j = 0; j < field_type->num_fields (); j += 1)
7094             {
7095               if (find_struct_field (name, field_type->field (j).type (),
7096                                      fld_offset
7097                                      + field_type->field (j).loc_bitpos () / 8,
7098                                      field_type_p, byte_offset_p,
7099                                      bit_offset_p, bit_size_p, index_p))
7100                 return 1;
7101             }
7102         }
7103       else if (index_p != NULL)
7104         *index_p += 1;
7105     }
7106
7107   /* Field not found so far.  If this is a tagged type which
7108      has a parent, try finding that field in the parent now.  */
7109
7110   if (parent_offset != -1)
7111     {
7112       /* As above, only compute the offset when truly needed.  */
7113       int fld_offset = offset;
7114       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7115         {
7116           int bit_pos = type->field (parent_offset).loc_bitpos ();
7117           fld_offset += bit_pos / 8;
7118         }
7119
7120       if (find_struct_field (name, type->field (parent_offset).type (),
7121                              fld_offset, field_type_p, byte_offset_p,
7122                              bit_offset_p, bit_size_p, index_p))
7123         return 1;
7124     }
7125
7126   return 0;
7127 }
7128
7129 /* Number of user-visible fields in record type TYPE.  */
7130
7131 static int
7132 num_visible_fields (struct type *type)
7133 {
7134   int n;
7135
7136   n = 0;
7137   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7138   return n;
7139 }
7140
7141 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
7142    and search in it assuming it has (class) type TYPE.
7143    If found, return value, else return NULL.
7144
7145    Searches recursively through wrapper fields (e.g., '_parent').
7146
7147    In the case of homonyms in the tagged types, please refer to the
7148    long explanation in find_struct_field's function documentation.  */
7149
7150 static struct value *
7151 ada_search_struct_field (const char *name, struct value *arg, int offset,
7152                          struct type *type)
7153 {
7154   int i;
7155   int parent_offset = -1;
7156
7157   type = ada_check_typedef (type);
7158   for (i = 0; i < type->num_fields (); i += 1)
7159     {
7160       const char *t_field_name = type->field (i).name ();
7161
7162       if (t_field_name == NULL)
7163         continue;
7164
7165       else if (ada_is_parent_field (type, i))
7166         {
7167           /* This is a field pointing us to the parent type of a tagged
7168              type.  As hinted in this function's documentation, we give
7169              preference to fields in the current record first, so what
7170              we do here is just record the index of this field before
7171              we skip it.  If it turns out we couldn't find our field
7172              in the current record, then we'll get back to it and search
7173              inside it whether the field might exist in the parent.  */
7174
7175           parent_offset = i;
7176           continue;
7177         }
7178
7179       else if (field_name_match (t_field_name, name))
7180         return ada_value_primitive_field (arg, offset, i, type);
7181
7182       else if (ada_is_wrapper_field (type, i))
7183         {
7184           struct value *v =     /* Do not let indent join lines here.  */
7185             ada_search_struct_field (name, arg,
7186                                      offset + type->field (i).loc_bitpos () / 8,
7187                                      type->field (i).type ());
7188
7189           if (v != NULL)
7190             return v;
7191         }
7192
7193       else if (ada_is_variant_part (type, i))
7194         {
7195           /* PNH: Do we ever get here?  See find_struct_field.  */
7196           int j;
7197           struct type *field_type = ada_check_typedef (type->field (i).type ());
7198           int var_offset = offset + type->field (i).loc_bitpos () / 8;
7199
7200           for (j = 0; j < field_type->num_fields (); j += 1)
7201             {
7202               struct value *v = ada_search_struct_field /* Force line
7203                                                            break.  */
7204                 (name, arg,
7205                  var_offset + field_type->field (j).loc_bitpos () / 8,
7206                  field_type->field (j).type ());
7207
7208               if (v != NULL)
7209                 return v;
7210             }
7211         }
7212     }
7213
7214   /* Field not found so far.  If this is a tagged type which
7215      has a parent, try finding that field in the parent now.  */
7216
7217   if (parent_offset != -1)
7218     {
7219       struct value *v = ada_search_struct_field (
7220         name, arg, offset + type->field (parent_offset).loc_bitpos () / 8,
7221         type->field (parent_offset).type ());
7222
7223       if (v != NULL)
7224         return v;
7225     }
7226
7227   return NULL;
7228 }
7229
7230 static struct value *ada_index_struct_field_1 (int *, struct value *,
7231                                                int, struct type *);
7232
7233
7234 /* Return field #INDEX in ARG, where the index is that returned by
7235  * find_struct_field through its INDEX_P argument.  Adjust the address
7236  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7237  * If found, return value, else return NULL.  */
7238
7239 static struct value *
7240 ada_index_struct_field (int index, struct value *arg, int offset,
7241                         struct type *type)
7242 {
7243   return ada_index_struct_field_1 (&index, arg, offset, type);
7244 }
7245
7246
7247 /* Auxiliary function for ada_index_struct_field.  Like
7248  * ada_index_struct_field, but takes index from *INDEX_P and modifies
7249  * *INDEX_P.  */
7250
7251 static struct value *
7252 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7253                           struct type *type)
7254 {
7255   int i;
7256   type = ada_check_typedef (type);
7257
7258   for (i = 0; i < type->num_fields (); i += 1)
7259     {
7260       if (type->field (i).name () == NULL)
7261         continue;
7262       else if (ada_is_wrapper_field (type, i))
7263         {
7264           struct value *v =     /* Do not let indent join lines here.  */
7265             ada_index_struct_field_1 (index_p, arg,
7266                                       offset + type->field (i).loc_bitpos () / 8,
7267                                       type->field (i).type ());
7268
7269           if (v != NULL)
7270             return v;
7271         }
7272
7273       else if (ada_is_variant_part (type, i))
7274         {
7275           /* PNH: Do we ever get here?  See ada_search_struct_field,
7276              find_struct_field.  */
7277           error (_("Cannot assign this kind of variant record"));
7278         }
7279       else if (*index_p == 0)
7280         return ada_value_primitive_field (arg, offset, i, type);
7281       else
7282         *index_p -= 1;
7283     }
7284   return NULL;
7285 }
7286
7287 /* Return a string representation of type TYPE.  */
7288
7289 static std::string
7290 type_as_string (struct type *type)
7291 {
7292   string_file tmp_stream;
7293
7294   type_print (type, "", &tmp_stream, -1);
7295
7296   return tmp_stream.release ();
7297 }
7298
7299 /* Given a type TYPE, look up the type of the component of type named NAME.
7300    If DISPP is non-null, add its byte displacement from the beginning of a
7301    structure (pointed to by a value) of type TYPE to *DISPP (does not
7302    work for packed fields).
7303
7304    Matches any field whose name has NAME as a prefix, possibly
7305    followed by "___".
7306
7307    TYPE can be either a struct or union.  If REFOK, TYPE may also 
7308    be a (pointer or reference)+ to a struct or union, and the
7309    ultimate target type will be searched.
7310
7311    Looks recursively into variant clauses and parent types.
7312
7313    In the case of homonyms in the tagged types, please refer to the
7314    long explanation in find_struct_field's function documentation.
7315
7316    If NOERR is nonzero, return NULL if NAME is not suitably defined or
7317    TYPE is not a type of the right kind.  */
7318
7319 static struct type *
7320 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7321                             int noerr)
7322 {
7323   int i;
7324   int parent_offset = -1;
7325
7326   if (name == NULL)
7327     goto BadName;
7328
7329   if (refok && type != NULL)
7330     while (1)
7331       {
7332         type = ada_check_typedef (type);
7333         if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
7334           break;
7335         type = type->target_type ();
7336       }
7337
7338   if (type == NULL
7339       || (type->code () != TYPE_CODE_STRUCT
7340           && type->code () != TYPE_CODE_UNION))
7341     {
7342       if (noerr)
7343         return NULL;
7344
7345       error (_("Type %s is not a structure or union type"),
7346              type != NULL ? type_as_string (type).c_str () : _("(null)"));
7347     }
7348
7349   type = to_static_fixed_type (type);
7350
7351   for (i = 0; i < type->num_fields (); i += 1)
7352     {
7353       const char *t_field_name = type->field (i).name ();
7354       struct type *t;
7355
7356       if (t_field_name == NULL)
7357         continue;
7358
7359       else if (ada_is_parent_field (type, i))
7360         {
7361           /* This is a field pointing us to the parent type of a tagged
7362              type.  As hinted in this function's documentation, we give
7363              preference to fields in the current record first, so what
7364              we do here is just record the index of this field before
7365              we skip it.  If it turns out we couldn't find our field
7366              in the current record, then we'll get back to it and search
7367              inside it whether the field might exist in the parent.  */
7368
7369           parent_offset = i;
7370           continue;
7371         }
7372
7373       else if (field_name_match (t_field_name, name))
7374         return type->field (i).type ();
7375
7376       else if (ada_is_wrapper_field (type, i))
7377         {
7378           t = ada_lookup_struct_elt_type (type->field (i).type (), name,
7379                                           0, 1);
7380           if (t != NULL)
7381             return t;
7382         }
7383
7384       else if (ada_is_variant_part (type, i))
7385         {
7386           int j;
7387           struct type *field_type = ada_check_typedef (type->field (i).type ());
7388
7389           for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
7390             {
7391               /* FIXME pnh 2008/01/26: We check for a field that is
7392                  NOT wrapped in a struct, since the compiler sometimes
7393                  generates these for unchecked variant types.  Revisit
7394                  if the compiler changes this practice.  */
7395               const char *v_field_name = field_type->field (j).name ();
7396
7397               if (v_field_name != NULL 
7398                   && field_name_match (v_field_name, name))
7399                 t = field_type->field (j).type ();
7400               else
7401                 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
7402                                                 name, 0, 1);
7403
7404               if (t != NULL)
7405                 return t;
7406             }
7407         }
7408
7409     }
7410
7411     /* Field not found so far.  If this is a tagged type which
7412        has a parent, try finding that field in the parent now.  */
7413
7414     if (parent_offset != -1)
7415       {
7416         struct type *t;
7417
7418         t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
7419                                         name, 0, 1);
7420         if (t != NULL)
7421           return t;
7422       }
7423
7424 BadName:
7425   if (!noerr)
7426     {
7427       const char *name_str = name != NULL ? name : _("<null>");
7428
7429       error (_("Type %s has no component named %s"),
7430              type_as_string (type).c_str (), name_str);
7431     }
7432
7433   return NULL;
7434 }
7435
7436 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7437    within a value of type OUTER_TYPE, return true iff VAR_TYPE
7438    represents an unchecked union (that is, the variant part of a
7439    record that is named in an Unchecked_Union pragma).  */
7440
7441 static int
7442 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7443 {
7444   const char *discrim_name = ada_variant_discrim_name (var_type);
7445
7446   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7447 }
7448
7449
7450 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7451    within OUTER, determine which variant clause (field number in VAR_TYPE,
7452    numbering from 0) is applicable.  Returns -1 if none are.  */
7453
7454 int
7455 ada_which_variant_applies (struct type *var_type, struct value *outer)
7456 {
7457   int others_clause;
7458   int i;
7459   const char *discrim_name = ada_variant_discrim_name (var_type);
7460   struct value *discrim;
7461   LONGEST discrim_val;
7462
7463   /* Using plain value_from_contents_and_address here causes problems
7464      because we will end up trying to resolve a type that is currently
7465      being constructed.  */
7466   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7467   if (discrim == NULL)
7468     return -1;
7469   discrim_val = value_as_long (discrim);
7470
7471   others_clause = -1;
7472   for (i = 0; i < var_type->num_fields (); i += 1)
7473     {
7474       if (ada_is_others_clause (var_type, i))
7475         others_clause = i;
7476       else if (ada_in_variant (discrim_val, var_type, i))
7477         return i;
7478     }
7479
7480   return others_clause;
7481 }
7482 \f
7483
7484
7485                                 /* Dynamic-Sized Records */
7486
7487 /* Strategy: The type ostensibly attached to a value with dynamic size
7488    (i.e., a size that is not statically recorded in the debugging
7489    data) does not accurately reflect the size or layout of the value.
7490    Our strategy is to convert these values to values with accurate,
7491    conventional types that are constructed on the fly.  */
7492
7493 /* There is a subtle and tricky problem here.  In general, we cannot
7494    determine the size of dynamic records without its data.  However,
7495    the 'struct value' data structure, which GDB uses to represent
7496    quantities in the inferior process (the target), requires the size
7497    of the type at the time of its allocation in order to reserve space
7498    for GDB's internal copy of the data.  That's why the
7499    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7500    rather than struct value*s.
7501
7502    However, GDB's internal history variables ($1, $2, etc.) are
7503    struct value*s containing internal copies of the data that are not, in
7504    general, the same as the data at their corresponding addresses in
7505    the target.  Fortunately, the types we give to these values are all
7506    conventional, fixed-size types (as per the strategy described
7507    above), so that we don't usually have to perform the
7508    'to_fixed_xxx_type' conversions to look at their values.
7509    Unfortunately, there is one exception: if one of the internal
7510    history variables is an array whose elements are unconstrained
7511    records, then we will need to create distinct fixed types for each
7512    element selected.  */
7513
7514 /* The upshot of all of this is that many routines take a (type, host
7515    address, target address) triple as arguments to represent a value.
7516    The host address, if non-null, is supposed to contain an internal
7517    copy of the relevant data; otherwise, the program is to consult the
7518    target at the target address.  */
7519
7520 /* Assuming that VAL0 represents a pointer value, the result of
7521    dereferencing it.  Differs from value_ind in its treatment of
7522    dynamic-sized types.  */
7523
7524 struct value *
7525 ada_value_ind (struct value *val0)
7526 {
7527   struct value *val = value_ind (val0);
7528
7529   if (ada_is_tagged_type (value_type (val), 0))
7530     val = ada_tag_value_at_base_address (val);
7531
7532   return ada_to_fixed_value (val);
7533 }
7534
7535 /* The value resulting from dereferencing any "reference to"
7536    qualifiers on VAL0.  */
7537
7538 static struct value *
7539 ada_coerce_ref (struct value *val0)
7540 {
7541   if (value_type (val0)->code () == TYPE_CODE_REF)
7542     {
7543       struct value *val = val0;
7544
7545       val = coerce_ref (val);
7546
7547       if (ada_is_tagged_type (value_type (val), 0))
7548         val = ada_tag_value_at_base_address (val);
7549
7550       return ada_to_fixed_value (val);
7551     }
7552   else
7553     return val0;
7554 }
7555
7556 /* Return the bit alignment required for field #F of template type TYPE.  */
7557
7558 static unsigned int
7559 field_alignment (struct type *type, int f)
7560 {
7561   const char *name = type->field (f).name ();
7562   int len;
7563   int align_offset;
7564
7565   /* The field name should never be null, unless the debugging information
7566      is somehow malformed.  In this case, we assume the field does not
7567      require any alignment.  */
7568   if (name == NULL)
7569     return 1;
7570
7571   len = strlen (name);
7572
7573   if (!isdigit (name[len - 1]))
7574     return 1;
7575
7576   if (isdigit (name[len - 2]))
7577     align_offset = len - 2;
7578   else
7579     align_offset = len - 1;
7580
7581   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7582     return TARGET_CHAR_BIT;
7583
7584   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7585 }
7586
7587 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7588
7589 static struct symbol *
7590 ada_find_any_type_symbol (const char *name)
7591 {
7592   struct symbol *sym;
7593
7594   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7595   if (sym != NULL && sym->aclass () == LOC_TYPEDEF)
7596     return sym;
7597
7598   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7599   return sym;
7600 }
7601
7602 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7603    solely for types defined by debug info, it will not search the GDB
7604    primitive types.  */
7605
7606 static struct type *
7607 ada_find_any_type (const char *name)
7608 {
7609   struct symbol *sym = ada_find_any_type_symbol (name);
7610
7611   if (sym != NULL)
7612     return sym->type ();
7613
7614   return NULL;
7615 }
7616
7617 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7618    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
7619    symbol, in which case it is returned.  Otherwise, this looks for
7620    symbols whose name is that of NAME_SYM suffixed with  "___XR".
7621    Return symbol if found, and NULL otherwise.  */
7622
7623 static bool
7624 ada_is_renaming_symbol (struct symbol *name_sym)
7625 {
7626   const char *name = name_sym->linkage_name ();
7627   return strstr (name, "___XR") != NULL;
7628 }
7629
7630 /* Because of GNAT encoding conventions, several GDB symbols may match a
7631    given type name.  If the type denoted by TYPE0 is to be preferred to
7632    that of TYPE1 for purposes of type printing, return non-zero;
7633    otherwise return 0.  */
7634
7635 int
7636 ada_prefer_type (struct type *type0, struct type *type1)
7637 {
7638   if (type1 == NULL)
7639     return 1;
7640   else if (type0 == NULL)
7641     return 0;
7642   else if (type1->code () == TYPE_CODE_VOID)
7643     return 1;
7644   else if (type0->code () == TYPE_CODE_VOID)
7645     return 0;
7646   else if (type1->name () == NULL && type0->name () != NULL)
7647     return 1;
7648   else if (ada_is_constrained_packed_array_type (type0))
7649     return 1;
7650   else if (ada_is_array_descriptor_type (type0)
7651            && !ada_is_array_descriptor_type (type1))
7652     return 1;
7653   else
7654     {
7655       const char *type0_name = type0->name ();
7656       const char *type1_name = type1->name ();
7657
7658       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7659           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7660         return 1;
7661     }
7662   return 0;
7663 }
7664
7665 /* The name of TYPE, which is its TYPE_NAME.  Null if TYPE is
7666    null.  */
7667
7668 const char *
7669 ada_type_name (struct type *type)
7670 {
7671   if (type == NULL)
7672     return NULL;
7673   return type->name ();
7674 }
7675
7676 /* Search the list of "descriptive" types associated to TYPE for a type
7677    whose name is NAME.  */
7678
7679 static struct type *
7680 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7681 {
7682   struct type *result, *tmp;
7683
7684   if (ada_ignore_descriptive_types_p)
7685     return NULL;
7686
7687   /* If there no descriptive-type info, then there is no parallel type
7688      to be found.  */
7689   if (!HAVE_GNAT_AUX_INFO (type))
7690     return NULL;
7691
7692   result = TYPE_DESCRIPTIVE_TYPE (type);
7693   while (result != NULL)
7694     {
7695       const char *result_name = ada_type_name (result);
7696
7697       if (result_name == NULL)
7698         {
7699           warning (_("unexpected null name on descriptive type"));
7700           return NULL;
7701         }
7702
7703       /* If the names match, stop.  */
7704       if (strcmp (result_name, name) == 0)
7705         break;
7706
7707       /* Otherwise, look at the next item on the list, if any.  */
7708       if (HAVE_GNAT_AUX_INFO (result))
7709         tmp = TYPE_DESCRIPTIVE_TYPE (result);
7710       else
7711         tmp = NULL;
7712
7713       /* If not found either, try after having resolved the typedef.  */
7714       if (tmp != NULL)
7715         result = tmp;
7716       else
7717         {
7718           result = check_typedef (result);
7719           if (HAVE_GNAT_AUX_INFO (result))
7720             result = TYPE_DESCRIPTIVE_TYPE (result);
7721           else
7722             result = NULL;
7723         }
7724     }
7725
7726   /* If we didn't find a match, see whether this is a packed array.  With
7727      older compilers, the descriptive type information is either absent or
7728      irrelevant when it comes to packed arrays so the above lookup fails.
7729      Fall back to using a parallel lookup by name in this case.  */
7730   if (result == NULL && ada_is_constrained_packed_array_type (type))
7731     return ada_find_any_type (name);
7732
7733   return result;
7734 }
7735
7736 /* Find a parallel type to TYPE with the specified NAME, using the
7737    descriptive type taken from the debugging information, if available,
7738    and otherwise using the (slower) name-based method.  */
7739
7740 static struct type *
7741 ada_find_parallel_type_with_name (struct type *type, const char *name)
7742 {
7743   struct type *result = NULL;
7744
7745   if (HAVE_GNAT_AUX_INFO (type))
7746     result = find_parallel_type_by_descriptive_type (type, name);
7747   else
7748     result = ada_find_any_type (name);
7749
7750   return result;
7751 }
7752
7753 /* Same as above, but specify the name of the parallel type by appending
7754    SUFFIX to the name of TYPE.  */
7755
7756 struct type *
7757 ada_find_parallel_type (struct type *type, const char *suffix)
7758 {
7759   char *name;
7760   const char *type_name = ada_type_name (type);
7761   int len;
7762
7763   if (type_name == NULL)
7764     return NULL;
7765
7766   len = strlen (type_name);
7767
7768   name = (char *) alloca (len + strlen (suffix) + 1);
7769
7770   strcpy (name, type_name);
7771   strcpy (name + len, suffix);
7772
7773   return ada_find_parallel_type_with_name (type, name);
7774 }
7775
7776 /* If TYPE is a variable-size record type, return the corresponding template
7777    type describing its fields.  Otherwise, return NULL.  */
7778
7779 static struct type *
7780 dynamic_template_type (struct type *type)
7781 {
7782   type = ada_check_typedef (type);
7783
7784   if (type == NULL || type->code () != TYPE_CODE_STRUCT
7785       || ada_type_name (type) == NULL)
7786     return NULL;
7787   else
7788     {
7789       int len = strlen (ada_type_name (type));
7790
7791       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7792         return type;
7793       else
7794         return ada_find_parallel_type (type, "___XVE");
7795     }
7796 }
7797
7798 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7799    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
7800
7801 static int
7802 is_dynamic_field (struct type *templ_type, int field_num)
7803 {
7804   const char *name = templ_type->field (field_num).name ();
7805
7806   return name != NULL
7807     && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7808     && strstr (name, "___XVL") != NULL;
7809 }
7810
7811 /* The index of the variant field of TYPE, or -1 if TYPE does not
7812    represent a variant record type.  */
7813
7814 static int
7815 variant_field_index (struct type *type)
7816 {
7817   int f;
7818
7819   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7820     return -1;
7821
7822   for (f = 0; f < type->num_fields (); f += 1)
7823     {
7824       if (ada_is_variant_part (type, f))
7825         return f;
7826     }
7827   return -1;
7828 }
7829
7830 /* A record type with no fields.  */
7831
7832 static struct type *
7833 empty_record (struct type *templ)
7834 {
7835   struct type *type = alloc_type_copy (templ);
7836
7837   type->set_code (TYPE_CODE_STRUCT);
7838   INIT_NONE_SPECIFIC (type);
7839   type->set_name ("<empty>");
7840   type->set_length (0);
7841   return type;
7842 }
7843
7844 /* An ordinary record type (with fixed-length fields) that describes
7845    the value of type TYPE at VALADDR or ADDRESS (see comments at
7846    the beginning of this section) VAL according to GNAT conventions.
7847    DVAL0 should describe the (portion of a) record that contains any
7848    necessary discriminants.  It should be NULL if value_type (VAL) is
7849    an outer-level type (i.e., as opposed to a branch of a variant.)  A
7850    variant field (unless unchecked) is replaced by a particular branch
7851    of the variant.
7852
7853    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7854    length are not statically known are discarded.  As a consequence,
7855    VALADDR, ADDRESS and DVAL0 are ignored.
7856
7857    NOTE: Limitations: For now, we assume that dynamic fields and
7858    variants occupy whole numbers of bytes.  However, they need not be
7859    byte-aligned.  */
7860
7861 struct type *
7862 ada_template_to_fixed_record_type_1 (struct type *type,
7863                                      const gdb_byte *valaddr,
7864                                      CORE_ADDR address, struct value *dval0,
7865                                      int keep_dynamic_fields)
7866 {
7867   struct value *dval;
7868   struct type *rtype;
7869   int nfields, bit_len;
7870   int variant_field;
7871   long off;
7872   int fld_bit_len;
7873   int f;
7874
7875   scoped_value_mark mark;
7876
7877   /* Compute the number of fields in this record type that are going
7878      to be processed: unless keep_dynamic_fields, this includes only
7879      fields whose position and length are static will be processed.  */
7880   if (keep_dynamic_fields)
7881     nfields = type->num_fields ();
7882   else
7883     {
7884       nfields = 0;
7885       while (nfields < type->num_fields ()
7886              && !ada_is_variant_part (type, nfields)
7887              && !is_dynamic_field (type, nfields))
7888         nfields++;
7889     }
7890
7891   rtype = alloc_type_copy (type);
7892   rtype->set_code (TYPE_CODE_STRUCT);
7893   INIT_NONE_SPECIFIC (rtype);
7894   rtype->set_num_fields (nfields);
7895   rtype->set_fields
7896    ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7897   rtype->set_name (ada_type_name (type));
7898   rtype->set_is_fixed_instance (true);
7899
7900   off = 0;
7901   bit_len = 0;
7902   variant_field = -1;
7903
7904   for (f = 0; f < nfields; f += 1)
7905     {
7906       off = align_up (off, field_alignment (type, f))
7907         + type->field (f).loc_bitpos ();
7908       rtype->field (f).set_loc_bitpos (off);
7909       TYPE_FIELD_BITSIZE (rtype, f) = 0;
7910
7911       if (ada_is_variant_part (type, f))
7912         {
7913           variant_field = f;
7914           fld_bit_len = 0;
7915         }
7916       else if (is_dynamic_field (type, f))
7917         {
7918           const gdb_byte *field_valaddr = valaddr;
7919           CORE_ADDR field_address = address;
7920           struct type *field_type = type->field (f).type ()->target_type ();
7921
7922           if (dval0 == NULL)
7923             {
7924               /* Using plain value_from_contents_and_address here
7925                  causes problems because we will end up trying to
7926                  resolve a type that is currently being
7927                  constructed.  */
7928               dval = value_from_contents_and_address_unresolved (rtype,
7929                                                                  valaddr,
7930                                                                  address);
7931               rtype = value_type (dval);
7932             }
7933           else
7934             dval = dval0;
7935
7936           /* If the type referenced by this field is an aligner type, we need
7937              to unwrap that aligner type, because its size might not be set.
7938              Keeping the aligner type would cause us to compute the wrong
7939              size for this field, impacting the offset of the all the fields
7940              that follow this one.  */
7941           if (ada_is_aligner_type (field_type))
7942             {
7943               long field_offset = type->field (f).loc_bitpos ();
7944
7945               field_valaddr = cond_offset_host (field_valaddr, field_offset);
7946               field_address = cond_offset_target (field_address, field_offset);
7947               field_type = ada_aligned_type (field_type);
7948             }
7949
7950           field_valaddr = cond_offset_host (field_valaddr,
7951                                             off / TARGET_CHAR_BIT);
7952           field_address = cond_offset_target (field_address,
7953                                               off / TARGET_CHAR_BIT);
7954
7955           /* Get the fixed type of the field.  Note that, in this case,
7956              we do not want to get the real type out of the tag: if
7957              the current field is the parent part of a tagged record,
7958              we will get the tag of the object.  Clearly wrong: the real
7959              type of the parent is not the real type of the child.  We
7960              would end up in an infinite loop.  */
7961           field_type = ada_get_base_type (field_type);
7962           field_type = ada_to_fixed_type (field_type, field_valaddr,
7963                                           field_address, dval, 0);
7964
7965           rtype->field (f).set_type (field_type);
7966           rtype->field (f).set_name (type->field (f).name ());
7967           /* The multiplication can potentially overflow.  But because
7968              the field length has been size-checked just above, and
7969              assuming that the maximum size is a reasonable value,
7970              an overflow should not happen in practice.  So rather than
7971              adding overflow recovery code to this already complex code,
7972              we just assume that it's not going to happen.  */
7973           fld_bit_len = rtype->field (f).type ()->length () * TARGET_CHAR_BIT;
7974         }
7975       else
7976         {
7977           /* Note: If this field's type is a typedef, it is important
7978              to preserve the typedef layer.
7979
7980              Otherwise, we might be transforming a typedef to a fat
7981              pointer (encoding a pointer to an unconstrained array),
7982              into a basic fat pointer (encoding an unconstrained
7983              array).  As both types are implemented using the same
7984              structure, the typedef is the only clue which allows us
7985              to distinguish between the two options.  Stripping it
7986              would prevent us from printing this field appropriately.  */
7987           rtype->field (f).set_type (type->field (f).type ());
7988           rtype->field (f).set_name (type->field (f).name ());
7989           if (TYPE_FIELD_BITSIZE (type, f) > 0)
7990             fld_bit_len =
7991               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7992           else
7993             {
7994               struct type *field_type = type->field (f).type ();
7995
7996               /* We need to be careful of typedefs when computing
7997                  the length of our field.  If this is a typedef,
7998                  get the length of the target type, not the length
7999                  of the typedef.  */
8000               if (field_type->code () == TYPE_CODE_TYPEDEF)
8001                 field_type = ada_typedef_target_type (field_type);
8002
8003               fld_bit_len =
8004                 ada_check_typedef (field_type)->length () * TARGET_CHAR_BIT;
8005             }
8006         }
8007       if (off + fld_bit_len > bit_len)
8008         bit_len = off + fld_bit_len;
8009       off += fld_bit_len;
8010       rtype->set_length (align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT);
8011     }
8012
8013   /* We handle the variant part, if any, at the end because of certain
8014      odd cases in which it is re-ordered so as NOT to be the last field of
8015      the record.  This can happen in the presence of representation
8016      clauses.  */
8017   if (variant_field >= 0)
8018     {
8019       struct type *branch_type;
8020
8021       off = rtype->field (variant_field).loc_bitpos ();
8022
8023       if (dval0 == NULL)
8024         {
8025           /* Using plain value_from_contents_and_address here causes
8026              problems because we will end up trying to resolve a type
8027              that is currently being constructed.  */
8028           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8029                                                              address);
8030           rtype = value_type (dval);
8031         }
8032       else
8033         dval = dval0;
8034
8035       branch_type =
8036         to_fixed_variant_branch_type
8037         (type->field (variant_field).type (),
8038          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8039          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8040       if (branch_type == NULL)
8041         {
8042           for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
8043             rtype->field (f - 1) = rtype->field (f);
8044           rtype->set_num_fields (rtype->num_fields () - 1);
8045         }
8046       else
8047         {
8048           rtype->field (variant_field).set_type (branch_type);
8049           rtype->field (variant_field).set_name ("S");
8050           fld_bit_len =
8051             rtype->field (variant_field).type ()->length () * TARGET_CHAR_BIT;
8052           if (off + fld_bit_len > bit_len)
8053             bit_len = off + fld_bit_len;
8054
8055           rtype->set_length
8056             (align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT);
8057         }
8058     }
8059
8060   /* According to exp_dbug.ads, the size of TYPE for variable-size records
8061      should contain the alignment of that record, which should be a strictly
8062      positive value.  If null or negative, then something is wrong, most
8063      probably in the debug info.  In that case, we don't round up the size
8064      of the resulting type.  If this record is not part of another structure,
8065      the current RTYPE length might be good enough for our purposes.  */
8066   if (type->length () <= 0)
8067     {
8068       if (rtype->name ())
8069         warning (_("Invalid type size for `%s' detected: %s."),
8070                  rtype->name (), pulongest (type->length ()));
8071       else
8072         warning (_("Invalid type size for <unnamed> detected: %s."),
8073                  pulongest (type->length ()));
8074     }
8075   else
8076     rtype->set_length (align_up (rtype->length (), type->length ()));
8077
8078   return rtype;
8079 }
8080
8081 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8082    of 1.  */
8083
8084 static struct type *
8085 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8086                                CORE_ADDR address, struct value *dval0)
8087 {
8088   return ada_template_to_fixed_record_type_1 (type, valaddr,
8089                                               address, dval0, 1);
8090 }
8091
8092 /* An ordinary record type in which ___XVL-convention fields and
8093    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8094    static approximations, containing all possible fields.  Uses
8095    no runtime values.  Useless for use in values, but that's OK,
8096    since the results are used only for type determinations.   Works on both
8097    structs and unions.  Representation note: to save space, we memorize
8098    the result of this function in the type::target_type of the
8099    template type.  */
8100
8101 static struct type *
8102 template_to_static_fixed_type (struct type *type0)
8103 {
8104   struct type *type;
8105   int nfields;
8106   int f;
8107
8108   /* No need no do anything if the input type is already fixed.  */
8109   if (type0->is_fixed_instance ())
8110     return type0;
8111
8112   /* Likewise if we already have computed the static approximation.  */
8113   if (type0->target_type () != NULL)
8114     return type0->target_type ();
8115
8116   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
8117   type = type0;
8118   nfields = type0->num_fields ();
8119
8120   /* Whether or not we cloned TYPE0, cache the result so that we don't do
8121      recompute all over next time.  */
8122   type0->set_target_type (type);
8123
8124   for (f = 0; f < nfields; f += 1)
8125     {
8126       struct type *field_type = type0->field (f).type ();
8127       struct type *new_type;
8128
8129       if (is_dynamic_field (type0, f))
8130         {
8131           field_type = ada_check_typedef (field_type);
8132           new_type = to_static_fixed_type (field_type->target_type ());
8133         }
8134       else
8135         new_type = static_unwrap_type (field_type);
8136
8137       if (new_type != field_type)
8138         {
8139           /* Clone TYPE0 only the first time we get a new field type.  */
8140           if (type == type0)
8141             {
8142               type = alloc_type_copy (type0);
8143               type0->set_target_type (type);
8144               type->set_code (type0->code ());
8145               INIT_NONE_SPECIFIC (type);
8146               type->set_num_fields (nfields);
8147
8148               field *fields =
8149                 ((struct field *)
8150                  TYPE_ALLOC (type, nfields * sizeof (struct field)));
8151               memcpy (fields, type0->fields (),
8152                       sizeof (struct field) * nfields);
8153               type->set_fields (fields);
8154
8155               type->set_name (ada_type_name (type0));
8156               type->set_is_fixed_instance (true);
8157               type->set_length (0);
8158             }
8159           type->field (f).set_type (new_type);
8160           type->field (f).set_name (type0->field (f).name ());
8161         }
8162     }
8163
8164   return type;
8165 }
8166
8167 /* Given an object of type TYPE whose contents are at VALADDR and
8168    whose address in memory is ADDRESS, returns a revision of TYPE,
8169    which should be a non-dynamic-sized record, in which the variant
8170    part, if any, is replaced with the appropriate branch.  Looks
8171    for discriminant values in DVAL0, which can be NULL if the record
8172    contains the necessary discriminant values.  */
8173
8174 static struct type *
8175 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8176                                    CORE_ADDR address, struct value *dval0)
8177 {
8178   struct value *dval;
8179   struct type *rtype;
8180   struct type *branch_type;
8181   int nfields = type->num_fields ();
8182   int variant_field = variant_field_index (type);
8183
8184   if (variant_field == -1)
8185     return type;
8186
8187   scoped_value_mark mark;
8188   if (dval0 == NULL)
8189     {
8190       dval = value_from_contents_and_address (type, valaddr, address);
8191       type = value_type (dval);
8192     }
8193   else
8194     dval = dval0;
8195
8196   rtype = alloc_type_copy (type);
8197   rtype->set_code (TYPE_CODE_STRUCT);
8198   INIT_NONE_SPECIFIC (rtype);
8199   rtype->set_num_fields (nfields);
8200
8201   field *fields =
8202     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8203   memcpy (fields, type->fields (), sizeof (struct field) * nfields);
8204   rtype->set_fields (fields);
8205
8206   rtype->set_name (ada_type_name (type));
8207   rtype->set_is_fixed_instance (true);
8208   rtype->set_length (type->length ());
8209
8210   branch_type = to_fixed_variant_branch_type
8211     (type->field (variant_field).type (),
8212      cond_offset_host (valaddr,
8213                        type->field (variant_field).loc_bitpos ()
8214                        / TARGET_CHAR_BIT),
8215      cond_offset_target (address,
8216                          type->field (variant_field).loc_bitpos ()
8217                          / TARGET_CHAR_BIT), dval);
8218   if (branch_type == NULL)
8219     {
8220       int f;
8221
8222       for (f = variant_field + 1; f < nfields; f += 1)
8223         rtype->field (f - 1) = rtype->field (f);
8224       rtype->set_num_fields (rtype->num_fields () - 1);
8225     }
8226   else
8227     {
8228       rtype->field (variant_field).set_type (branch_type);
8229       rtype->field (variant_field).set_name ("S");
8230       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8231       rtype->set_length (rtype->length () + branch_type->length ());
8232     }
8233
8234   rtype->set_length (rtype->length ()
8235                      - type->field (variant_field).type ()->length ());
8236
8237   return rtype;
8238 }
8239
8240 /* An ordinary record type (with fixed-length fields) that describes
8241    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8242    beginning of this section].   Any necessary discriminants' values
8243    should be in DVAL, a record value; it may be NULL if the object
8244    at ADDR itself contains any necessary discriminant values.
8245    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8246    values from the record are needed.  Except in the case that DVAL,
8247    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8248    unchecked) is replaced by a particular branch of the variant.
8249
8250    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8251    is questionable and may be removed.  It can arise during the
8252    processing of an unconstrained-array-of-record type where all the
8253    variant branches have exactly the same size.  This is because in
8254    such cases, the compiler does not bother to use the XVS convention
8255    when encoding the record.  I am currently dubious of this
8256    shortcut and suspect the compiler should be altered.  FIXME.  */
8257
8258 static struct type *
8259 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8260                       CORE_ADDR address, struct value *dval)
8261 {
8262   struct type *templ_type;
8263
8264   if (type0->is_fixed_instance ())
8265     return type0;
8266
8267   templ_type = dynamic_template_type (type0);
8268
8269   if (templ_type != NULL)
8270     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8271   else if (variant_field_index (type0) >= 0)
8272     {
8273       if (dval == NULL && valaddr == NULL && address == 0)
8274         return type0;
8275       return to_record_with_fixed_variant_part (type0, valaddr, address,
8276                                                 dval);
8277     }
8278   else
8279     {
8280       type0->set_is_fixed_instance (true);
8281       return type0;
8282     }
8283
8284 }
8285
8286 /* An ordinary record type (with fixed-length fields) that describes
8287    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8288    union type.  Any necessary discriminants' values should be in DVAL,
8289    a record value.  That is, this routine selects the appropriate
8290    branch of the union at ADDR according to the discriminant value
8291    indicated in the union's type name.  Returns VAR_TYPE0 itself if
8292    it represents a variant subject to a pragma Unchecked_Union.  */
8293
8294 static struct type *
8295 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8296                               CORE_ADDR address, struct value *dval)
8297 {
8298   int which;
8299   struct type *templ_type;
8300   struct type *var_type;
8301
8302   if (var_type0->code () == TYPE_CODE_PTR)
8303     var_type = var_type0->target_type ();
8304   else
8305     var_type = var_type0;
8306
8307   templ_type = ada_find_parallel_type (var_type, "___XVU");
8308
8309   if (templ_type != NULL)
8310     var_type = templ_type;
8311
8312   if (is_unchecked_variant (var_type, value_type (dval)))
8313       return var_type0;
8314   which = ada_which_variant_applies (var_type, dval);
8315
8316   if (which < 0)
8317     return empty_record (var_type);
8318   else if (is_dynamic_field (var_type, which))
8319     return to_fixed_record_type
8320       (var_type->field (which).type ()->target_type(), valaddr, address, dval);
8321   else if (variant_field_index (var_type->field (which).type ()) >= 0)
8322     return
8323       to_fixed_record_type
8324       (var_type->field (which).type (), valaddr, address, dval);
8325   else
8326     return var_type->field (which).type ();
8327 }
8328
8329 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8330    ENCODING_TYPE, a type following the GNAT conventions for discrete
8331    type encodings, only carries redundant information.  */
8332
8333 static int
8334 ada_is_redundant_range_encoding (struct type *range_type,
8335                                  struct type *encoding_type)
8336 {
8337   const char *bounds_str;
8338   int n;
8339   LONGEST lo, hi;
8340
8341   gdb_assert (range_type->code () == TYPE_CODE_RANGE);
8342
8343   if (get_base_type (range_type)->code ()
8344       != get_base_type (encoding_type)->code ())
8345     {
8346       /* The compiler probably used a simple base type to describe
8347          the range type instead of the range's actual base type,
8348          expecting us to get the real base type from the encoding
8349          anyway.  In this situation, the encoding cannot be ignored
8350          as redundant.  */
8351       return 0;
8352     }
8353
8354   if (is_dynamic_type (range_type))
8355     return 0;
8356
8357   if (encoding_type->name () == NULL)
8358     return 0;
8359
8360   bounds_str = strstr (encoding_type->name (), "___XDLU_");
8361   if (bounds_str == NULL)
8362     return 0;
8363
8364   n = 8; /* Skip "___XDLU_".  */
8365   if (!ada_scan_number (bounds_str, n, &lo, &n))
8366     return 0;
8367   if (range_type->bounds ()->low.const_val () != lo)
8368     return 0;
8369
8370   n += 2; /* Skip the "__" separator between the two bounds.  */
8371   if (!ada_scan_number (bounds_str, n, &hi, &n))
8372     return 0;
8373   if (range_type->bounds ()->high.const_val () != hi)
8374     return 0;
8375
8376   return 1;
8377 }
8378
8379 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8380    a type following the GNAT encoding for describing array type
8381    indices, only carries redundant information.  */
8382
8383 static int
8384 ada_is_redundant_index_type_desc (struct type *array_type,
8385                                   struct type *desc_type)
8386 {
8387   struct type *this_layer = check_typedef (array_type);
8388   int i;
8389
8390   for (i = 0; i < desc_type->num_fields (); i++)
8391     {
8392       if (!ada_is_redundant_range_encoding (this_layer->index_type (),
8393                                             desc_type->field (i).type ()))
8394         return 0;
8395       this_layer = check_typedef (this_layer->target_type ());
8396     }
8397
8398   return 1;
8399 }
8400
8401 /* Assuming that TYPE0 is an array type describing the type of a value
8402    at ADDR, and that DVAL describes a record containing any
8403    discriminants used in TYPE0, returns a type for the value that
8404    contains no dynamic components (that is, no components whose sizes
8405    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
8406    true, gives an error message if the resulting type's size is over
8407    varsize_limit.  */
8408
8409 static struct type *
8410 to_fixed_array_type (struct type *type0, struct value *dval,
8411                      int ignore_too_big)
8412 {
8413   struct type *index_type_desc;
8414   struct type *result;
8415   int constrained_packed_array_p;
8416   static const char *xa_suffix = "___XA";
8417
8418   type0 = ada_check_typedef (type0);
8419   if (type0->is_fixed_instance ())
8420     return type0;
8421
8422   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8423   if (constrained_packed_array_p)
8424     {
8425       type0 = decode_constrained_packed_array_type (type0);
8426       if (type0 == nullptr)
8427         error (_("could not decode constrained packed array type"));
8428     }
8429
8430   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8431
8432   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8433      encoding suffixed with 'P' may still be generated.  If so,
8434      it should be used to find the XA type.  */
8435
8436   if (index_type_desc == NULL)
8437     {
8438       const char *type_name = ada_type_name (type0);
8439
8440       if (type_name != NULL)
8441         {
8442           const int len = strlen (type_name);
8443           char *name = (char *) alloca (len + strlen (xa_suffix));
8444
8445           if (type_name[len - 1] == 'P')
8446             {
8447               strcpy (name, type_name);
8448               strcpy (name + len - 1, xa_suffix);
8449               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8450             }
8451         }
8452     }
8453
8454   ada_fixup_array_indexes_type (index_type_desc);
8455   if (index_type_desc != NULL
8456       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8457     {
8458       /* Ignore this ___XA parallel type, as it does not bring any
8459          useful information.  This allows us to avoid creating fixed
8460          versions of the array's index types, which would be identical
8461          to the original ones.  This, in turn, can also help avoid
8462          the creation of fixed versions of the array itself.  */
8463       index_type_desc = NULL;
8464     }
8465
8466   if (index_type_desc == NULL)
8467     {
8468       struct type *elt_type0 = ada_check_typedef (type0->target_type ());
8469
8470       /* NOTE: elt_type---the fixed version of elt_type0---should never
8471          depend on the contents of the array in properly constructed
8472          debugging data.  */
8473       /* Create a fixed version of the array element type.
8474          We're not providing the address of an element here,
8475          and thus the actual object value cannot be inspected to do
8476          the conversion.  This should not be a problem, since arrays of
8477          unconstrained objects are not allowed.  In particular, all
8478          the elements of an array of a tagged type should all be of
8479          the same type specified in the debugging info.  No need to
8480          consult the object tag.  */
8481       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8482
8483       /* Make sure we always create a new array type when dealing with
8484          packed array types, since we're going to fix-up the array
8485          type length and element bitsize a little further down.  */
8486       if (elt_type0 == elt_type && !constrained_packed_array_p)
8487         result = type0;
8488       else
8489         result = create_array_type (alloc_type_copy (type0),
8490                                     elt_type, type0->index_type ());
8491     }
8492   else
8493     {
8494       int i;
8495       struct type *elt_type0;
8496
8497       elt_type0 = type0;
8498       for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8499         elt_type0 = elt_type0->target_type ();
8500
8501       /* NOTE: result---the fixed version of elt_type0---should never
8502          depend on the contents of the array in properly constructed
8503          debugging data.  */
8504       /* Create a fixed version of the array element type.
8505          We're not providing the address of an element here,
8506          and thus the actual object value cannot be inspected to do
8507          the conversion.  This should not be a problem, since arrays of
8508          unconstrained objects are not allowed.  In particular, all
8509          the elements of an array of a tagged type should all be of
8510          the same type specified in the debugging info.  No need to
8511          consult the object tag.  */
8512       result =
8513         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8514
8515       elt_type0 = type0;
8516       for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8517         {
8518           struct type *range_type =
8519             to_fixed_range_type (index_type_desc->field (i).type (), dval);
8520
8521           result = create_array_type (alloc_type_copy (elt_type0),
8522                                       result, range_type);
8523           elt_type0 = elt_type0->target_type ();
8524         }
8525     }
8526
8527   /* We want to preserve the type name.  This can be useful when
8528      trying to get the type name of a value that has already been
8529      printed (for instance, if the user did "print VAR; whatis $".  */
8530   result->set_name (type0->name ());
8531
8532   if (constrained_packed_array_p)
8533     {
8534       /* So far, the resulting type has been created as if the original
8535          type was a regular (non-packed) array type.  As a result, the
8536          bitsize of the array elements needs to be set again, and the array
8537          length needs to be recomputed based on that bitsize.  */
8538       int len = result->length () / result->target_type ()->length ();
8539       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8540
8541       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8542       result->set_length (len * elt_bitsize / HOST_CHAR_BIT);
8543       if (result->length () * HOST_CHAR_BIT < len * elt_bitsize)
8544         result->set_length (result->length () + 1);
8545     }
8546
8547   result->set_is_fixed_instance (true);
8548   return result;
8549 }
8550
8551
8552 /* A standard type (containing no dynamically sized components)
8553    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8554    DVAL describes a record containing any discriminants used in TYPE0,
8555    and may be NULL if there are none, or if the object of type TYPE at
8556    ADDRESS or in VALADDR contains these discriminants.
8557    
8558    If CHECK_TAG is not null, in the case of tagged types, this function
8559    attempts to locate the object's tag and use it to compute the actual
8560    type.  However, when ADDRESS is null, we cannot use it to determine the
8561    location of the tag, and therefore compute the tagged type's actual type.
8562    So we return the tagged type without consulting the tag.  */
8563    
8564 static struct type *
8565 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8566                    CORE_ADDR address, struct value *dval, int check_tag)
8567 {
8568   type = ada_check_typedef (type);
8569
8570   /* Only un-fixed types need to be handled here.  */
8571   if (!HAVE_GNAT_AUX_INFO (type))
8572     return type;
8573
8574   switch (type->code ())
8575     {
8576     default:
8577       return type;
8578     case TYPE_CODE_STRUCT:
8579       {
8580         struct type *static_type = to_static_fixed_type (type);
8581         struct type *fixed_record_type =
8582           to_fixed_record_type (type, valaddr, address, NULL);
8583
8584         /* If STATIC_TYPE is a tagged type and we know the object's address,
8585            then we can determine its tag, and compute the object's actual
8586            type from there.  Note that we have to use the fixed record
8587            type (the parent part of the record may have dynamic fields
8588            and the way the location of _tag is expressed may depend on
8589            them).  */
8590
8591         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8592           {
8593             struct value *tag =
8594               value_tag_from_contents_and_address
8595               (fixed_record_type,
8596                valaddr,
8597                address);
8598             struct type *real_type = type_from_tag (tag);
8599             struct value *obj =
8600               value_from_contents_and_address (fixed_record_type,
8601                                                valaddr,
8602                                                address);
8603             fixed_record_type = value_type (obj);
8604             if (real_type != NULL)
8605               return to_fixed_record_type
8606                 (real_type, NULL,
8607                  value_address (ada_tag_value_at_base_address (obj)), NULL);
8608           }
8609
8610         /* Check to see if there is a parallel ___XVZ variable.
8611            If there is, then it provides the actual size of our type.  */
8612         else if (ada_type_name (fixed_record_type) != NULL)
8613           {
8614             const char *name = ada_type_name (fixed_record_type);
8615             char *xvz_name
8616               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8617             bool xvz_found = false;
8618             LONGEST size;
8619
8620             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8621             try
8622               {
8623                 xvz_found = get_int_var_value (xvz_name, size);
8624               }
8625             catch (const gdb_exception_error &except)
8626               {
8627                 /* We found the variable, but somehow failed to read
8628                    its value.  Rethrow the same error, but with a little
8629                    bit more information, to help the user understand
8630                    what went wrong (Eg: the variable might have been
8631                    optimized out).  */
8632                 throw_error (except.error,
8633                              _("unable to read value of %s (%s)"),
8634                              xvz_name, except.what ());
8635               }
8636
8637             if (xvz_found && fixed_record_type->length () != size)
8638               {
8639                 fixed_record_type = copy_type (fixed_record_type);
8640                 fixed_record_type->set_length (size);
8641
8642                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
8643                    observed this when the debugging info is STABS, and
8644                    apparently it is something that is hard to fix.
8645
8646                    In practice, we don't need the actual type definition
8647                    at all, because the presence of the XVZ variable allows us
8648                    to assume that there must be a XVS type as well, which we
8649                    should be able to use later, when we need the actual type
8650                    definition.
8651
8652                    In the meantime, pretend that the "fixed" type we are
8653                    returning is NOT a stub, because this can cause trouble
8654                    when using this type to create new types targeting it.
8655                    Indeed, the associated creation routines often check
8656                    whether the target type is a stub and will try to replace
8657                    it, thus using a type with the wrong size.  This, in turn,
8658                    might cause the new type to have the wrong size too.
8659                    Consider the case of an array, for instance, where the size
8660                    of the array is computed from the number of elements in
8661                    our array multiplied by the size of its element.  */
8662                 fixed_record_type->set_is_stub (false);
8663               }
8664           }
8665         return fixed_record_type;
8666       }
8667     case TYPE_CODE_ARRAY:
8668       return to_fixed_array_type (type, dval, 1);
8669     case TYPE_CODE_UNION:
8670       if (dval == NULL)
8671         return type;
8672       else
8673         return to_fixed_variant_branch_type (type, valaddr, address, dval);
8674     }
8675 }
8676
8677 /* The same as ada_to_fixed_type_1, except that it preserves the type
8678    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8679
8680    The typedef layer needs be preserved in order to differentiate between
8681    arrays and array pointers when both types are implemented using the same
8682    fat pointer.  In the array pointer case, the pointer is encoded as
8683    a typedef of the pointer type.  For instance, considering:
8684
8685           type String_Access is access String;
8686           S1 : String_Access := null;
8687
8688    To the debugger, S1 is defined as a typedef of type String.  But
8689    to the user, it is a pointer.  So if the user tries to print S1,
8690    we should not dereference the array, but print the array address
8691    instead.
8692
8693    If we didn't preserve the typedef layer, we would lose the fact that
8694    the type is to be presented as a pointer (needs de-reference before
8695    being printed).  And we would also use the source-level type name.  */
8696
8697 struct type *
8698 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8699                    CORE_ADDR address, struct value *dval, int check_tag)
8700
8701 {
8702   struct type *fixed_type =
8703     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8704
8705   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8706       then preserve the typedef layer.
8707
8708       Implementation note: We can only check the main-type portion of
8709       the TYPE and FIXED_TYPE, because eliminating the typedef layer
8710       from TYPE now returns a type that has the same instance flags
8711       as TYPE.  For instance, if TYPE is a "typedef const", and its
8712       target type is a "struct", then the typedef elimination will return
8713       a "const" version of the target type.  See check_typedef for more
8714       details about how the typedef layer elimination is done.
8715
8716       brobecker/2010-11-19: It seems to me that the only case where it is
8717       useful to preserve the typedef layer is when dealing with fat pointers.
8718       Perhaps, we could add a check for that and preserve the typedef layer
8719       only in that situation.  But this seems unnecessary so far, probably
8720       because we call check_typedef/ada_check_typedef pretty much everywhere.
8721       */
8722   if (type->code () == TYPE_CODE_TYPEDEF
8723       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8724           == TYPE_MAIN_TYPE (fixed_type)))
8725     return type;
8726
8727   return fixed_type;
8728 }
8729
8730 /* A standard (static-sized) type corresponding as well as possible to
8731    TYPE0, but based on no runtime data.  */
8732
8733 static struct type *
8734 to_static_fixed_type (struct type *type0)
8735 {
8736   struct type *type;
8737
8738   if (type0 == NULL)
8739     return NULL;
8740
8741   if (type0->is_fixed_instance ())
8742     return type0;
8743
8744   type0 = ada_check_typedef (type0);
8745
8746   switch (type0->code ())
8747     {
8748     default:
8749       return type0;
8750     case TYPE_CODE_STRUCT:
8751       type = dynamic_template_type (type0);
8752       if (type != NULL)
8753         return template_to_static_fixed_type (type);
8754       else
8755         return template_to_static_fixed_type (type0);
8756     case TYPE_CODE_UNION:
8757       type = ada_find_parallel_type (type0, "___XVU");
8758       if (type != NULL)
8759         return template_to_static_fixed_type (type);
8760       else
8761         return template_to_static_fixed_type (type0);
8762     }
8763 }
8764
8765 /* A static approximation of TYPE with all type wrappers removed.  */
8766
8767 static struct type *
8768 static_unwrap_type (struct type *type)
8769 {
8770   if (ada_is_aligner_type (type))
8771     {
8772       struct type *type1 = ada_check_typedef (type)->field (0).type ();
8773       if (ada_type_name (type1) == NULL)
8774         type1->set_name (ada_type_name (type));
8775
8776       return static_unwrap_type (type1);
8777     }
8778   else
8779     {
8780       struct type *raw_real_type = ada_get_base_type (type);
8781
8782       if (raw_real_type == type)
8783         return type;
8784       else
8785         return to_static_fixed_type (raw_real_type);
8786     }
8787 }
8788
8789 /* In some cases, incomplete and private types require
8790    cross-references that are not resolved as records (for example,
8791       type Foo;
8792       type FooP is access Foo;
8793       V: FooP;
8794       type Foo is array ...;
8795    ).  In these cases, since there is no mechanism for producing
8796    cross-references to such types, we instead substitute for FooP a
8797    stub enumeration type that is nowhere resolved, and whose tag is
8798    the name of the actual type.  Call these types "non-record stubs".  */
8799
8800 /* A type equivalent to TYPE that is not a non-record stub, if one
8801    exists, otherwise TYPE.  */
8802
8803 struct type *
8804 ada_check_typedef (struct type *type)
8805 {
8806   if (type == NULL)
8807     return NULL;
8808
8809   /* If our type is an access to an unconstrained array, which is encoded
8810      as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8811      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8812      what allows us to distinguish between fat pointers that represent
8813      array types, and fat pointers that represent array access types
8814      (in both cases, the compiler implements them as fat pointers).  */
8815   if (ada_is_access_to_unconstrained_array (type))
8816     return type;
8817
8818   type = check_typedef (type);
8819   if (type == NULL || type->code () != TYPE_CODE_ENUM
8820       || !type->is_stub ()
8821       || type->name () == NULL)
8822     return type;
8823   else
8824     {
8825       const char *name = type->name ();
8826       struct type *type1 = ada_find_any_type (name);
8827
8828       if (type1 == NULL)
8829         return type;
8830
8831       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8832          stubs pointing to arrays, as we don't create symbols for array
8833          types, only for the typedef-to-array types).  If that's the case,
8834          strip the typedef layer.  */
8835       if (type1->code () == TYPE_CODE_TYPEDEF)
8836         type1 = ada_check_typedef (type1);
8837
8838       return type1;
8839     }
8840 }
8841
8842 /* A value representing the data at VALADDR/ADDRESS as described by
8843    type TYPE0, but with a standard (static-sized) type that correctly
8844    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
8845    type, then return VAL0 [this feature is simply to avoid redundant
8846    creation of struct values].  */
8847
8848 static struct value *
8849 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8850                            struct value *val0)
8851 {
8852   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8853
8854   if (type == type0 && val0 != NULL)
8855     return val0;
8856
8857   if (VALUE_LVAL (val0) != lval_memory)
8858     {
8859       /* Our value does not live in memory; it could be a convenience
8860          variable, for instance.  Create a not_lval value using val0's
8861          contents.  */
8862       return value_from_contents (type, value_contents (val0).data ());
8863     }
8864
8865   return value_from_contents_and_address (type, 0, address);
8866 }
8867
8868 /* A value representing VAL, but with a standard (static-sized) type
8869    that correctly describes it.  Does not necessarily create a new
8870    value.  */
8871
8872 struct value *
8873 ada_to_fixed_value (struct value *val)
8874 {
8875   val = unwrap_value (val);
8876   val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8877   return val;
8878 }
8879 \f
8880
8881 /* Attributes */
8882
8883 /* Table mapping attribute numbers to names.
8884    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
8885
8886 static const char * const attribute_names[] = {
8887   "<?>",
8888
8889   "first",
8890   "last",
8891   "length",
8892   "image",
8893   "max",
8894   "min",
8895   "modulus",
8896   "pos",
8897   "size",
8898   "tag",
8899   "val",
8900   0
8901 };
8902
8903 static const char *
8904 ada_attribute_name (enum exp_opcode n)
8905 {
8906   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8907     return attribute_names[n - OP_ATR_FIRST + 1];
8908   else
8909     return attribute_names[0];
8910 }
8911
8912 /* Evaluate the 'POS attribute applied to ARG.  */
8913
8914 static LONGEST
8915 pos_atr (struct value *arg)
8916 {
8917   struct value *val = coerce_ref (arg);
8918   struct type *type = value_type (val);
8919
8920   if (!discrete_type_p (type))
8921     error (_("'POS only defined on discrete types"));
8922
8923   gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8924   if (!result.has_value ())
8925     error (_("enumeration value is invalid: can't find 'POS"));
8926
8927   return *result;
8928 }
8929
8930 struct value *
8931 ada_pos_atr (struct type *expect_type,
8932              struct expression *exp,
8933              enum noside noside, enum exp_opcode op,
8934              struct value *arg)
8935 {
8936   struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8937   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8938     return value_zero (type, not_lval);
8939   return value_from_longest (type, pos_atr (arg));
8940 }
8941
8942 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
8943
8944 static struct value *
8945 val_atr (struct type *type, LONGEST val)
8946 {
8947   gdb_assert (discrete_type_p (type));
8948   if (type->code () == TYPE_CODE_RANGE)
8949     type = type->target_type ();
8950   if (type->code () == TYPE_CODE_ENUM)
8951     {
8952       if (val < 0 || val >= type->num_fields ())
8953         error (_("argument to 'VAL out of range"));
8954       val = type->field (val).loc_enumval ();
8955     }
8956   return value_from_longest (type, val);
8957 }
8958
8959 struct value *
8960 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8961 {
8962   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8963     return value_zero (type, not_lval);
8964
8965   if (!discrete_type_p (type))
8966     error (_("'VAL only defined on discrete types"));
8967   if (!integer_type_p (value_type (arg)))
8968     error (_("'VAL requires integral argument"));
8969
8970   return val_atr (type, value_as_long (arg));
8971 }
8972 \f
8973
8974                                 /* Evaluation */
8975
8976 /* True if TYPE appears to be an Ada character type.
8977    [At the moment, this is true only for Character and Wide_Character;
8978    It is a heuristic test that could stand improvement].  */
8979
8980 bool
8981 ada_is_character_type (struct type *type)
8982 {
8983   const char *name;
8984
8985   /* If the type code says it's a character, then assume it really is,
8986      and don't check any further.  */
8987   if (type->code () == TYPE_CODE_CHAR)
8988     return true;
8989   
8990   /* Otherwise, assume it's a character type iff it is a discrete type
8991      with a known character type name.  */
8992   name = ada_type_name (type);
8993   return (name != NULL
8994           && (type->code () == TYPE_CODE_INT
8995               || type->code () == TYPE_CODE_RANGE)
8996           && (strcmp (name, "character") == 0
8997               || strcmp (name, "wide_character") == 0
8998               || strcmp (name, "wide_wide_character") == 0
8999               || strcmp (name, "unsigned char") == 0));
9000 }
9001
9002 /* True if TYPE appears to be an Ada string type.  */
9003
9004 bool
9005 ada_is_string_type (struct type *type)
9006 {
9007   type = ada_check_typedef (type);
9008   if (type != NULL
9009       && type->code () != TYPE_CODE_PTR
9010       && (ada_is_simple_array_type (type)
9011           || ada_is_array_descriptor_type (type))
9012       && ada_array_arity (type) == 1)
9013     {
9014       struct type *elttype = ada_array_element_type (type, 1);
9015
9016       return ada_is_character_type (elttype);
9017     }
9018   else
9019     return false;
9020 }
9021
9022 /* The compiler sometimes provides a parallel XVS type for a given
9023    PAD type.  Normally, it is safe to follow the PAD type directly,
9024    but older versions of the compiler have a bug that causes the offset
9025    of its "F" field to be wrong.  Following that field in that case
9026    would lead to incorrect results, but this can be worked around
9027    by ignoring the PAD type and using the associated XVS type instead.
9028
9029    Set to True if the debugger should trust the contents of PAD types.
9030    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
9031 static bool trust_pad_over_xvs = true;
9032
9033 /* True if TYPE is a struct type introduced by the compiler to force the
9034    alignment of a value.  Such types have a single field with a
9035    distinctive name.  */
9036
9037 int
9038 ada_is_aligner_type (struct type *type)
9039 {
9040   type = ada_check_typedef (type);
9041
9042   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9043     return 0;
9044
9045   return (type->code () == TYPE_CODE_STRUCT
9046           && type->num_fields () == 1
9047           && strcmp (type->field (0).name (), "F") == 0);
9048 }
9049
9050 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9051    the parallel type.  */
9052
9053 struct type *
9054 ada_get_base_type (struct type *raw_type)
9055 {
9056   struct type *real_type_namer;
9057   struct type *raw_real_type;
9058
9059   if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
9060     return raw_type;
9061
9062   if (ada_is_aligner_type (raw_type))
9063     /* The encoding specifies that we should always use the aligner type.
9064        So, even if this aligner type has an associated XVS type, we should
9065        simply ignore it.
9066
9067        According to the compiler gurus, an XVS type parallel to an aligner
9068        type may exist because of a stabs limitation.  In stabs, aligner
9069        types are empty because the field has a variable-sized type, and
9070        thus cannot actually be used as an aligner type.  As a result,
9071        we need the associated parallel XVS type to decode the type.
9072        Since the policy in the compiler is to not change the internal
9073        representation based on the debugging info format, we sometimes
9074        end up having a redundant XVS type parallel to the aligner type.  */
9075     return raw_type;
9076
9077   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9078   if (real_type_namer == NULL
9079       || real_type_namer->code () != TYPE_CODE_STRUCT
9080       || real_type_namer->num_fields () != 1)
9081     return raw_type;
9082
9083   if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
9084     {
9085       /* This is an older encoding form where the base type needs to be
9086          looked up by name.  We prefer the newer encoding because it is
9087          more efficient.  */
9088       raw_real_type = ada_find_any_type (real_type_namer->field (0).name ());
9089       if (raw_real_type == NULL)
9090         return raw_type;
9091       else
9092         return raw_real_type;
9093     }
9094
9095   /* The field in our XVS type is a reference to the base type.  */
9096   return real_type_namer->field (0).type ()->target_type ();
9097 }
9098
9099 /* The type of value designated by TYPE, with all aligners removed.  */
9100
9101 struct type *
9102 ada_aligned_type (struct type *type)
9103 {
9104   if (ada_is_aligner_type (type))
9105     return ada_aligned_type (type->field (0).type ());
9106   else
9107     return ada_get_base_type (type);
9108 }
9109
9110
9111 /* The address of the aligned value in an object at address VALADDR
9112    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
9113
9114 const gdb_byte *
9115 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9116 {
9117   if (ada_is_aligner_type (type))
9118     return ada_aligned_value_addr
9119       (type->field (0).type (),
9120        valaddr + type->field (0).loc_bitpos () / TARGET_CHAR_BIT);
9121   else
9122     return valaddr;
9123 }
9124
9125
9126
9127 /* The printed representation of an enumeration literal with encoded
9128    name NAME.  The value is good to the next call of ada_enum_name.  */
9129 const char *
9130 ada_enum_name (const char *name)
9131 {
9132   static std::string storage;
9133   const char *tmp;
9134
9135   /* First, unqualify the enumeration name:
9136      1. Search for the last '.' character.  If we find one, then skip
9137      all the preceding characters, the unqualified name starts
9138      right after that dot.
9139      2. Otherwise, we may be debugging on a target where the compiler
9140      translates dots into "__".  Search forward for double underscores,
9141      but stop searching when we hit an overloading suffix, which is
9142      of the form "__" followed by digits.  */
9143
9144   tmp = strrchr (name, '.');
9145   if (tmp != NULL)
9146     name = tmp + 1;
9147   else
9148     {
9149       while ((tmp = strstr (name, "__")) != NULL)
9150         {
9151           if (isdigit (tmp[2]))
9152             break;
9153           else
9154             name = tmp + 2;
9155         }
9156     }
9157
9158   if (name[0] == 'Q')
9159     {
9160       int v;
9161
9162       if (name[1] == 'U' || name[1] == 'W')
9163         {
9164           int offset = 2;
9165           if (name[1] == 'W' && name[2] == 'W')
9166             {
9167               /* Also handle the QWW case.  */
9168               ++offset;
9169             }
9170           if (sscanf (name + offset, "%x", &v) != 1)
9171             return name;
9172         }
9173       else if (((name[1] >= '0' && name[1] <= '9')
9174                 || (name[1] >= 'a' && name[1] <= 'z'))
9175                && name[2] == '\0')
9176         {
9177           storage = string_printf ("'%c'", name[1]);
9178           return storage.c_str ();
9179         }
9180       else
9181         return name;
9182
9183       if (isascii (v) && isprint (v))
9184         storage = string_printf ("'%c'", v);
9185       else if (name[1] == 'U')
9186         storage = string_printf ("'[\"%02x\"]'", v);
9187       else if (name[2] != 'W')
9188         storage = string_printf ("'[\"%04x\"]'", v);
9189       else
9190         storage = string_printf ("'[\"%06x\"]'", v);
9191
9192       return storage.c_str ();
9193     }
9194   else
9195     {
9196       tmp = strstr (name, "__");
9197       if (tmp == NULL)
9198         tmp = strstr (name, "$");
9199       if (tmp != NULL)
9200         {
9201           storage = std::string (name, tmp - name);
9202           return storage.c_str ();
9203         }
9204
9205       return name;
9206     }
9207 }
9208
9209 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9210    value it wraps.  */
9211
9212 static struct value *
9213 unwrap_value (struct value *val)
9214 {
9215   struct type *type = ada_check_typedef (value_type (val));
9216
9217   if (ada_is_aligner_type (type))
9218     {
9219       struct value *v = ada_value_struct_elt (val, "F", 0);
9220       struct type *val_type = ada_check_typedef (value_type (v));
9221
9222       if (ada_type_name (val_type) == NULL)
9223         val_type->set_name (ada_type_name (type));
9224
9225       return unwrap_value (v);
9226     }
9227   else
9228     {
9229       struct type *raw_real_type =
9230         ada_check_typedef (ada_get_base_type (type));
9231
9232       /* If there is no parallel XVS or XVE type, then the value is
9233          already unwrapped.  Return it without further modification.  */
9234       if ((type == raw_real_type)
9235           && ada_find_parallel_type (type, "___XVE") == NULL)
9236         return val;
9237
9238       return
9239         coerce_unspec_val_to_type
9240         (val, ada_to_fixed_type (raw_real_type, 0,
9241                                  value_address (val),
9242                                  NULL, 1));
9243     }
9244 }
9245
9246 /* Given two array types T1 and T2, return nonzero iff both arrays
9247    contain the same number of elements.  */
9248
9249 static int
9250 ada_same_array_size_p (struct type *t1, struct type *t2)
9251 {
9252   LONGEST lo1, hi1, lo2, hi2;
9253
9254   /* Get the array bounds in order to verify that the size of
9255      the two arrays match.  */
9256   if (!get_array_bounds (t1, &lo1, &hi1)
9257       || !get_array_bounds (t2, &lo2, &hi2))
9258     error (_("unable to determine array bounds"));
9259
9260   /* To make things easier for size comparison, normalize a bit
9261      the case of empty arrays by making sure that the difference
9262      between upper bound and lower bound is always -1.  */
9263   if (lo1 > hi1)
9264     hi1 = lo1 - 1;
9265   if (lo2 > hi2)
9266     hi2 = lo2 - 1;
9267
9268   return (hi1 - lo1 == hi2 - lo2);
9269 }
9270
9271 /* Assuming that VAL is an array of integrals, and TYPE represents
9272    an array with the same number of elements, but with wider integral
9273    elements, return an array "casted" to TYPE.  In practice, this
9274    means that the returned array is built by casting each element
9275    of the original array into TYPE's (wider) element type.  */
9276
9277 static struct value *
9278 ada_promote_array_of_integrals (struct type *type, struct value *val)
9279 {
9280   struct type *elt_type = type->target_type ();
9281   LONGEST lo, hi;
9282   LONGEST i;
9283
9284   /* Verify that both val and type are arrays of scalars, and
9285      that the size of val's elements is smaller than the size
9286      of type's element.  */
9287   gdb_assert (type->code () == TYPE_CODE_ARRAY);
9288   gdb_assert (is_integral_type (type->target_type ()));
9289   gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
9290   gdb_assert (is_integral_type (value_type (val)->target_type ()));
9291   gdb_assert (type->target_type ()->length ()
9292               > value_type (val)->target_type ()->length ());
9293
9294   if (!get_array_bounds (type, &lo, &hi))
9295     error (_("unable to determine array bounds"));
9296
9297   value *res = allocate_value (type);
9298   gdb::array_view<gdb_byte> res_contents = value_contents_writeable (res);
9299
9300   /* Promote each array element.  */
9301   for (i = 0; i < hi - lo + 1; i++)
9302     {
9303       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9304       int elt_len = elt_type->length ();
9305
9306       copy (value_contents_all (elt), res_contents.slice (elt_len * i, elt_len));
9307     }
9308
9309   return res;
9310 }
9311
9312 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9313    return the converted value.  */
9314
9315 static struct value *
9316 coerce_for_assign (struct type *type, struct value *val)
9317 {
9318   struct type *type2 = value_type (val);
9319
9320   if (type == type2)
9321     return val;
9322
9323   type2 = ada_check_typedef (type2);
9324   type = ada_check_typedef (type);
9325
9326   if (type2->code () == TYPE_CODE_PTR
9327       && type->code () == TYPE_CODE_ARRAY)
9328     {
9329       val = ada_value_ind (val);
9330       type2 = value_type (val);
9331     }
9332
9333   if (type2->code () == TYPE_CODE_ARRAY
9334       && type->code () == TYPE_CODE_ARRAY)
9335     {
9336       if (!ada_same_array_size_p (type, type2))
9337         error (_("cannot assign arrays of different length"));
9338
9339       if (is_integral_type (type->target_type ())
9340           && is_integral_type (type2->target_type ())
9341           && type2->target_type ()->length () < type->target_type ()->length ())
9342         {
9343           /* Allow implicit promotion of the array elements to
9344              a wider type.  */
9345           return ada_promote_array_of_integrals (type, val);
9346         }
9347
9348       if (type2->target_type ()->length () != type->target_type ()->length ())
9349         error (_("Incompatible types in assignment"));
9350       deprecated_set_value_type (val, type);
9351     }
9352   return val;
9353 }
9354
9355 static struct value *
9356 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9357 {
9358   struct value *val;
9359   struct type *type1, *type2;
9360   LONGEST v, v1, v2;
9361
9362   arg1 = coerce_ref (arg1);
9363   arg2 = coerce_ref (arg2);
9364   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9365   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9366
9367   if (type1->code () != TYPE_CODE_INT
9368       || type2->code () != TYPE_CODE_INT)
9369     return value_binop (arg1, arg2, op);
9370
9371   switch (op)
9372     {
9373     case BINOP_MOD:
9374     case BINOP_DIV:
9375     case BINOP_REM:
9376       break;
9377     default:
9378       return value_binop (arg1, arg2, op);
9379     }
9380
9381   v2 = value_as_long (arg2);
9382   if (v2 == 0)
9383     {
9384       const char *name;
9385       if (op == BINOP_MOD)
9386         name = "mod";
9387       else if (op == BINOP_DIV)
9388         name = "/";
9389       else
9390         {
9391           gdb_assert (op == BINOP_REM);
9392           name = "rem";
9393         }
9394
9395       error (_("second operand of %s must not be zero."), name);
9396     }
9397
9398   if (type1->is_unsigned () || op == BINOP_MOD)
9399     return value_binop (arg1, arg2, op);
9400
9401   v1 = value_as_long (arg1);
9402   switch (op)
9403     {
9404     case BINOP_DIV:
9405       v = v1 / v2;
9406       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9407         v += v > 0 ? -1 : 1;
9408       break;
9409     case BINOP_REM:
9410       v = v1 % v2;
9411       if (v * v1 < 0)
9412         v -= v2;
9413       break;
9414     default:
9415       /* Should not reach this point.  */
9416       v = 0;
9417     }
9418
9419   val = allocate_value (type1);
9420   store_unsigned_integer (value_contents_raw (val).data (),
9421                           value_type (val)->length (),
9422                           type_byte_order (type1), v);
9423   return val;
9424 }
9425
9426 static int
9427 ada_value_equal (struct value *arg1, struct value *arg2)
9428 {
9429   if (ada_is_direct_array_type (value_type (arg1))
9430       || ada_is_direct_array_type (value_type (arg2)))
9431     {
9432       struct type *arg1_type, *arg2_type;
9433
9434       /* Automatically dereference any array reference before
9435          we attempt to perform the comparison.  */
9436       arg1 = ada_coerce_ref (arg1);
9437       arg2 = ada_coerce_ref (arg2);
9438
9439       arg1 = ada_coerce_to_simple_array (arg1);
9440       arg2 = ada_coerce_to_simple_array (arg2);
9441
9442       arg1_type = ada_check_typedef (value_type (arg1));
9443       arg2_type = ada_check_typedef (value_type (arg2));
9444
9445       if (arg1_type->code () != TYPE_CODE_ARRAY
9446           || arg2_type->code () != TYPE_CODE_ARRAY)
9447         error (_("Attempt to compare array with non-array"));
9448       /* FIXME: The following works only for types whose
9449          representations use all bits (no padding or undefined bits)
9450          and do not have user-defined equality.  */
9451       return (arg1_type->length () == arg2_type->length ()
9452               && memcmp (value_contents (arg1).data (),
9453                          value_contents (arg2).data (),
9454                          arg1_type->length ()) == 0);
9455     }
9456   return value_equal (arg1, arg2);
9457 }
9458
9459 namespace expr
9460 {
9461
9462 bool
9463 check_objfile (const std::unique_ptr<ada_component> &comp,
9464                struct objfile *objfile)
9465 {
9466   return comp->uses_objfile (objfile);
9467 }
9468
9469 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9470    component of LHS (a simple array or a record).  Does not modify the
9471    inferior's memory, nor does it modify LHS (unless LHS ==
9472    CONTAINER).  */
9473
9474 static void
9475 assign_component (struct value *container, struct value *lhs, LONGEST index,
9476                   struct expression *exp, operation_up &arg)
9477 {
9478   scoped_value_mark mark;
9479
9480   struct value *elt;
9481   struct type *lhs_type = check_typedef (value_type (lhs));
9482
9483   if (lhs_type->code () == TYPE_CODE_ARRAY)
9484     {
9485       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9486       struct value *index_val = value_from_longest (index_type, index);
9487
9488       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9489     }
9490   else
9491     {
9492       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9493       elt = ada_to_fixed_value (elt);
9494     }
9495
9496   ada_aggregate_operation *ag_op
9497     = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9498   if (ag_op != nullptr)
9499     ag_op->assign_aggregate (container, elt, exp);
9500   else
9501     value_assign_to_component (container, elt,
9502                                arg->evaluate (nullptr, exp,
9503                                               EVAL_NORMAL));
9504 }
9505
9506 bool
9507 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9508 {
9509   for (const auto &item : m_components)
9510     if (item->uses_objfile (objfile))
9511       return true;
9512   return false;
9513 }
9514
9515 void
9516 ada_aggregate_component::dump (ui_file *stream, int depth)
9517 {
9518   gdb_printf (stream, _("%*sAggregate\n"), depth, "");
9519   for (const auto &item : m_components)
9520     item->dump (stream, depth + 1);
9521 }
9522
9523 void
9524 ada_aggregate_component::assign (struct value *container,
9525                                  struct value *lhs, struct expression *exp,
9526                                  std::vector<LONGEST> &indices,
9527                                  LONGEST low, LONGEST high)
9528 {
9529   for (auto &item : m_components)
9530     item->assign (container, lhs, exp, indices, low, high);
9531 }
9532
9533 /* See ada-exp.h.  */
9534
9535 value *
9536 ada_aggregate_operation::assign_aggregate (struct value *container,
9537                                            struct value *lhs,
9538                                            struct expression *exp)
9539 {
9540   struct type *lhs_type;
9541   LONGEST low_index, high_index;
9542
9543   container = ada_coerce_ref (container);
9544   if (ada_is_direct_array_type (value_type (container)))
9545     container = ada_coerce_to_simple_array (container);
9546   lhs = ada_coerce_ref (lhs);
9547   if (!deprecated_value_modifiable (lhs))
9548     error (_("Left operand of assignment is not a modifiable lvalue."));
9549
9550   lhs_type = check_typedef (value_type (lhs));
9551   if (ada_is_direct_array_type (lhs_type))
9552     {
9553       lhs = ada_coerce_to_simple_array (lhs);
9554       lhs_type = check_typedef (value_type (lhs));
9555       low_index = lhs_type->bounds ()->low.const_val ();
9556       high_index = lhs_type->bounds ()->high.const_val ();
9557     }
9558   else if (lhs_type->code () == TYPE_CODE_STRUCT)
9559     {
9560       low_index = 0;
9561       high_index = num_visible_fields (lhs_type) - 1;
9562     }
9563   else
9564     error (_("Left-hand side must be array or record."));
9565
9566   std::vector<LONGEST> indices (4);
9567   indices[0] = indices[1] = low_index - 1;
9568   indices[2] = indices[3] = high_index + 1;
9569
9570   std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9571                                    low_index, high_index);
9572
9573   return container;
9574 }
9575
9576 bool
9577 ada_positional_component::uses_objfile (struct objfile *objfile)
9578 {
9579   return m_op->uses_objfile (objfile);
9580 }
9581
9582 void
9583 ada_positional_component::dump (ui_file *stream, int depth)
9584 {
9585   gdb_printf (stream, _("%*sPositional, index = %d\n"),
9586               depth, "", m_index);
9587   m_op->dump (stream, depth + 1);
9588 }
9589
9590 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9591    construct, given that the positions are relative to lower bound
9592    LOW, where HIGH is the upper bound.  Record the position in
9593    INDICES.  CONTAINER is as for assign_aggregate.  */
9594 void
9595 ada_positional_component::assign (struct value *container,
9596                                   struct value *lhs, struct expression *exp,
9597                                   std::vector<LONGEST> &indices,
9598                                   LONGEST low, LONGEST high)
9599 {
9600   LONGEST ind = m_index + low;
9601
9602   if (ind - 1 == high)
9603     warning (_("Extra components in aggregate ignored."));
9604   if (ind <= high)
9605     {
9606       add_component_interval (ind, ind, indices);
9607       assign_component (container, lhs, ind, exp, m_op);
9608     }
9609 }
9610
9611 bool
9612 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9613 {
9614   return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9615 }
9616
9617 void
9618 ada_discrete_range_association::dump (ui_file *stream, int depth)
9619 {
9620   gdb_printf (stream, _("%*sDiscrete range:\n"), depth, "");
9621   m_low->dump (stream, depth + 1);
9622   m_high->dump (stream, depth + 1);
9623 }
9624
9625 void
9626 ada_discrete_range_association::assign (struct value *container,
9627                                         struct value *lhs,
9628                                         struct expression *exp,
9629                                         std::vector<LONGEST> &indices,
9630                                         LONGEST low, LONGEST high,
9631                                         operation_up &op)
9632 {
9633   LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9634   LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9635
9636   if (lower <= upper && (lower < low || upper > high))
9637     error (_("Index in component association out of bounds."));
9638
9639   add_component_interval (lower, upper, indices);
9640   while (lower <= upper)
9641     {
9642       assign_component (container, lhs, lower, exp, op);
9643       lower += 1;
9644     }
9645 }
9646
9647 bool
9648 ada_name_association::uses_objfile (struct objfile *objfile)
9649 {
9650   return m_val->uses_objfile (objfile);
9651 }
9652
9653 void
9654 ada_name_association::dump (ui_file *stream, int depth)
9655 {
9656   gdb_printf (stream, _("%*sName:\n"), depth, "");
9657   m_val->dump (stream, depth + 1);
9658 }
9659
9660 void
9661 ada_name_association::assign (struct value *container,
9662                               struct value *lhs,
9663                               struct expression *exp,
9664                               std::vector<LONGEST> &indices,
9665                               LONGEST low, LONGEST high,
9666                               operation_up &op)
9667 {
9668   int index;
9669
9670   if (ada_is_direct_array_type (value_type (lhs)))
9671     index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9672                                                             EVAL_NORMAL)));
9673   else
9674     {
9675       ada_string_operation *strop
9676         = dynamic_cast<ada_string_operation *> (m_val.get ());
9677
9678       const char *name;
9679       if (strop != nullptr)
9680         name = strop->get_name ();
9681       else
9682         {
9683           ada_var_value_operation *vvo
9684             = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9685           if (vvo != nullptr)
9686             error (_("Invalid record component association."));
9687           name = vvo->get_symbol ()->natural_name ();
9688         }
9689
9690       index = 0;
9691       if (! find_struct_field (name, value_type (lhs), 0,
9692                                NULL, NULL, NULL, NULL, &index))
9693         error (_("Unknown component name: %s."), name);
9694     }
9695
9696   add_component_interval (index, index, indices);
9697   assign_component (container, lhs, index, exp, op);
9698 }
9699
9700 bool
9701 ada_choices_component::uses_objfile (struct objfile *objfile)
9702 {
9703   if (m_op->uses_objfile (objfile))
9704     return true;
9705   for (const auto &item : m_assocs)
9706     if (item->uses_objfile (objfile))
9707       return true;
9708   return false;
9709 }
9710
9711 void
9712 ada_choices_component::dump (ui_file *stream, int depth)
9713 {
9714   gdb_printf (stream, _("%*sChoices:\n"), depth, "");
9715   m_op->dump (stream, depth + 1);
9716   for (const auto &item : m_assocs)
9717     item->dump (stream, depth + 1);
9718 }
9719
9720 /* Assign into the components of LHS indexed by the OP_CHOICES
9721    construct at *POS, updating *POS past the construct, given that
9722    the allowable indices are LOW..HIGH.  Record the indices assigned
9723    to in INDICES.  CONTAINER is as for assign_aggregate.  */
9724 void
9725 ada_choices_component::assign (struct value *container,
9726                                struct value *lhs, struct expression *exp,
9727                                std::vector<LONGEST> &indices,
9728                                LONGEST low, LONGEST high)
9729 {
9730   for (auto &item : m_assocs)
9731     item->assign (container, lhs, exp, indices, low, high, m_op);
9732 }
9733
9734 bool
9735 ada_others_component::uses_objfile (struct objfile *objfile)
9736 {
9737   return m_op->uses_objfile (objfile);
9738 }
9739
9740 void
9741 ada_others_component::dump (ui_file *stream, int depth)
9742 {
9743   gdb_printf (stream, _("%*sOthers:\n"), depth, "");
9744   m_op->dump (stream, depth + 1);
9745 }
9746
9747 /* Assign the value of the expression in the OP_OTHERS construct in
9748    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9749    have not been previously assigned.  The index intervals already assigned
9750    are in INDICES.  CONTAINER is as for assign_aggregate.  */
9751 void
9752 ada_others_component::assign (struct value *container,
9753                               struct value *lhs, struct expression *exp,
9754                               std::vector<LONGEST> &indices,
9755                               LONGEST low, LONGEST high)
9756 {
9757   int num_indices = indices.size ();
9758   for (int i = 0; i < num_indices - 2; i += 2)
9759     {
9760       for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9761         assign_component (container, lhs, ind, exp, m_op);
9762     }
9763 }
9764
9765 struct value *
9766 ada_assign_operation::evaluate (struct type *expect_type,
9767                                 struct expression *exp,
9768                                 enum noside noside)
9769 {
9770   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9771
9772   ada_aggregate_operation *ag_op
9773     = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9774   if (ag_op != nullptr)
9775     {
9776       if (noside != EVAL_NORMAL)
9777         return arg1;
9778
9779       arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9780       return ada_value_assign (arg1, arg1);
9781     }
9782   /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9783      except if the lhs of our assignment is a convenience variable.
9784      In the case of assigning to a convenience variable, the lhs
9785      should be exactly the result of the evaluation of the rhs.  */
9786   struct type *type = value_type (arg1);
9787   if (VALUE_LVAL (arg1) == lval_internalvar)
9788     type = NULL;
9789   value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9790   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9791     return arg1;
9792   if (VALUE_LVAL (arg1) == lval_internalvar)
9793     {
9794       /* Nothing.  */
9795     }
9796   else
9797     arg2 = coerce_for_assign (value_type (arg1), arg2);
9798   return ada_value_assign (arg1, arg2);
9799 }
9800
9801 } /* namespace expr */
9802
9803 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9804    [ INDICES[0] .. INDICES[1] ],...  The resulting intervals do not
9805    overlap.  */
9806 static void
9807 add_component_interval (LONGEST low, LONGEST high, 
9808                         std::vector<LONGEST> &indices)
9809 {
9810   int i, j;
9811
9812   int size = indices.size ();
9813   for (i = 0; i < size; i += 2) {
9814     if (high >= indices[i] && low <= indices[i + 1])
9815       {
9816         int kh;
9817
9818         for (kh = i + 2; kh < size; kh += 2)
9819           if (high < indices[kh])
9820             break;
9821         if (low < indices[i])
9822           indices[i] = low;
9823         indices[i + 1] = indices[kh - 1];
9824         if (high > indices[i + 1])
9825           indices[i + 1] = high;
9826         memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9827         indices.resize (kh - i - 2);
9828         return;
9829       }
9830     else if (high < indices[i])
9831       break;
9832   }
9833         
9834   indices.resize (indices.size () + 2);
9835   for (j = indices.size () - 1; j >= i + 2; j -= 1)
9836     indices[j] = indices[j - 2];
9837   indices[i] = low;
9838   indices[i + 1] = high;
9839 }
9840
9841 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9842    is different.  */
9843
9844 static struct value *
9845 ada_value_cast (struct type *type, struct value *arg2)
9846 {
9847   if (type == ada_check_typedef (value_type (arg2)))
9848     return arg2;
9849
9850   return value_cast (type, arg2);
9851 }
9852
9853 /*  Evaluating Ada expressions, and printing their result.
9854     ------------------------------------------------------
9855
9856     1. Introduction:
9857     ----------------
9858
9859     We usually evaluate an Ada expression in order to print its value.
9860     We also evaluate an expression in order to print its type, which
9861     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9862     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
9863     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9864     the evaluation compared to the EVAL_NORMAL, but is otherwise very
9865     similar.
9866
9867     Evaluating expressions is a little more complicated for Ada entities
9868     than it is for entities in languages such as C.  The main reason for
9869     this is that Ada provides types whose definition might be dynamic.
9870     One example of such types is variant records.  Or another example
9871     would be an array whose bounds can only be known at run time.
9872
9873     The following description is a general guide as to what should be
9874     done (and what should NOT be done) in order to evaluate an expression
9875     involving such types, and when.  This does not cover how the semantic
9876     information is encoded by GNAT as this is covered separatly.  For the
9877     document used as the reference for the GNAT encoding, see exp_dbug.ads
9878     in the GNAT sources.
9879
9880     Ideally, we should embed each part of this description next to its
9881     associated code.  Unfortunately, the amount of code is so vast right
9882     now that it's hard to see whether the code handling a particular
9883     situation might be duplicated or not.  One day, when the code is
9884     cleaned up, this guide might become redundant with the comments
9885     inserted in the code, and we might want to remove it.
9886
9887     2. ``Fixing'' an Entity, the Simple Case:
9888     -----------------------------------------
9889
9890     When evaluating Ada expressions, the tricky issue is that they may
9891     reference entities whose type contents and size are not statically
9892     known.  Consider for instance a variant record:
9893
9894        type Rec (Empty : Boolean := True) is record
9895           case Empty is
9896              when True => null;
9897              when False => Value : Integer;
9898           end case;
9899        end record;
9900        Yes : Rec := (Empty => False, Value => 1);
9901        No  : Rec := (empty => True);
9902
9903     The size and contents of that record depends on the value of the
9904     descriminant (Rec.Empty).  At this point, neither the debugging
9905     information nor the associated type structure in GDB are able to
9906     express such dynamic types.  So what the debugger does is to create
9907     "fixed" versions of the type that applies to the specific object.
9908     We also informally refer to this operation as "fixing" an object,
9909     which means creating its associated fixed type.
9910
9911     Example: when printing the value of variable "Yes" above, its fixed
9912     type would look like this:
9913
9914        type Rec is record
9915           Empty : Boolean;
9916           Value : Integer;
9917        end record;
9918
9919     On the other hand, if we printed the value of "No", its fixed type
9920     would become:
9921
9922        type Rec is record
9923           Empty : Boolean;
9924        end record;
9925
9926     Things become a little more complicated when trying to fix an entity
9927     with a dynamic type that directly contains another dynamic type,
9928     such as an array of variant records, for instance.  There are
9929     two possible cases: Arrays, and records.
9930
9931     3. ``Fixing'' Arrays:
9932     ---------------------
9933
9934     The type structure in GDB describes an array in terms of its bounds,
9935     and the type of its elements.  By design, all elements in the array
9936     have the same type and we cannot represent an array of variant elements
9937     using the current type structure in GDB.  When fixing an array,
9938     we cannot fix the array element, as we would potentially need one
9939     fixed type per element of the array.  As a result, the best we can do
9940     when fixing an array is to produce an array whose bounds and size
9941     are correct (allowing us to read it from memory), but without having
9942     touched its element type.  Fixing each element will be done later,
9943     when (if) necessary.
9944
9945     Arrays are a little simpler to handle than records, because the same
9946     amount of memory is allocated for each element of the array, even if
9947     the amount of space actually used by each element differs from element
9948     to element.  Consider for instance the following array of type Rec:
9949
9950        type Rec_Array is array (1 .. 2) of Rec;
9951
9952     The actual amount of memory occupied by each element might be different
9953     from element to element, depending on the value of their discriminant.
9954     But the amount of space reserved for each element in the array remains
9955     fixed regardless.  So we simply need to compute that size using
9956     the debugging information available, from which we can then determine
9957     the array size (we multiply the number of elements of the array by
9958     the size of each element).
9959
9960     The simplest case is when we have an array of a constrained element
9961     type. For instance, consider the following type declarations:
9962
9963         type Bounded_String (Max_Size : Integer) is
9964            Length : Integer;
9965            Buffer : String (1 .. Max_Size);
9966         end record;
9967         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9968
9969     In this case, the compiler describes the array as an array of
9970     variable-size elements (identified by its XVS suffix) for which
9971     the size can be read in the parallel XVZ variable.
9972
9973     In the case of an array of an unconstrained element type, the compiler
9974     wraps the array element inside a private PAD type.  This type should not
9975     be shown to the user, and must be "unwrap"'ed before printing.  Note
9976     that we also use the adjective "aligner" in our code to designate
9977     these wrapper types.
9978
9979     In some cases, the size allocated for each element is statically
9980     known.  In that case, the PAD type already has the correct size,
9981     and the array element should remain unfixed.
9982
9983     But there are cases when this size is not statically known.
9984     For instance, assuming that "Five" is an integer variable:
9985
9986         type Dynamic is array (1 .. Five) of Integer;
9987         type Wrapper (Has_Length : Boolean := False) is record
9988            Data : Dynamic;
9989            case Has_Length is
9990               when True => Length : Integer;
9991               when False => null;
9992            end case;
9993         end record;
9994         type Wrapper_Array is array (1 .. 2) of Wrapper;
9995
9996         Hello : Wrapper_Array := (others => (Has_Length => True,
9997                                              Data => (others => 17),
9998                                              Length => 1));
9999
10000
10001     The debugging info would describe variable Hello as being an
10002     array of a PAD type.  The size of that PAD type is not statically
10003     known, but can be determined using a parallel XVZ variable.
10004     In that case, a copy of the PAD type with the correct size should
10005     be used for the fixed array.
10006
10007     3. ``Fixing'' record type objects:
10008     ----------------------------------
10009
10010     Things are slightly different from arrays in the case of dynamic
10011     record types.  In this case, in order to compute the associated
10012     fixed type, we need to determine the size and offset of each of
10013     its components.  This, in turn, requires us to compute the fixed
10014     type of each of these components.
10015
10016     Consider for instance the example:
10017
10018         type Bounded_String (Max_Size : Natural) is record
10019            Str : String (1 .. Max_Size);
10020            Length : Natural;
10021         end record;
10022         My_String : Bounded_String (Max_Size => 10);
10023
10024     In that case, the position of field "Length" depends on the size
10025     of field Str, which itself depends on the value of the Max_Size
10026     discriminant.  In order to fix the type of variable My_String,
10027     we need to fix the type of field Str.  Therefore, fixing a variant
10028     record requires us to fix each of its components.
10029
10030     However, if a component does not have a dynamic size, the component
10031     should not be fixed.  In particular, fields that use a PAD type
10032     should not fixed.  Here is an example where this might happen
10033     (assuming type Rec above):
10034
10035        type Container (Big : Boolean) is record
10036           First : Rec;
10037           After : Integer;
10038           case Big is
10039              when True => Another : Integer;
10040              when False => null;
10041           end case;
10042        end record;
10043        My_Container : Container := (Big => False,
10044                                     First => (Empty => True),
10045                                     After => 42);
10046
10047     In that example, the compiler creates a PAD type for component First,
10048     whose size is constant, and then positions the component After just
10049     right after it.  The offset of component After is therefore constant
10050     in this case.
10051
10052     The debugger computes the position of each field based on an algorithm
10053     that uses, among other things, the actual position and size of the field
10054     preceding it.  Let's now imagine that the user is trying to print
10055     the value of My_Container.  If the type fixing was recursive, we would
10056     end up computing the offset of field After based on the size of the
10057     fixed version of field First.  And since in our example First has
10058     only one actual field, the size of the fixed type is actually smaller
10059     than the amount of space allocated to that field, and thus we would
10060     compute the wrong offset of field After.
10061
10062     To make things more complicated, we need to watch out for dynamic
10063     components of variant records (identified by the ___XVL suffix in
10064     the component name).  Even if the target type is a PAD type, the size
10065     of that type might not be statically known.  So the PAD type needs
10066     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
10067     we might end up with the wrong size for our component.  This can be
10068     observed with the following type declarations:
10069
10070         type Octal is new Integer range 0 .. 7;
10071         type Octal_Array is array (Positive range <>) of Octal;
10072         pragma Pack (Octal_Array);
10073
10074         type Octal_Buffer (Size : Positive) is record
10075            Buffer : Octal_Array (1 .. Size);
10076            Length : Integer;
10077         end record;
10078
10079     In that case, Buffer is a PAD type whose size is unset and needs
10080     to be computed by fixing the unwrapped type.
10081
10082     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10083     ----------------------------------------------------------
10084
10085     Lastly, when should the sub-elements of an entity that remained unfixed
10086     thus far, be actually fixed?
10087
10088     The answer is: Only when referencing that element.  For instance
10089     when selecting one component of a record, this specific component
10090     should be fixed at that point in time.  Or when printing the value
10091     of a record, each component should be fixed before its value gets
10092     printed.  Similarly for arrays, the element of the array should be
10093     fixed when printing each element of the array, or when extracting
10094     one element out of that array.  On the other hand, fixing should
10095     not be performed on the elements when taking a slice of an array!
10096
10097     Note that one of the side effects of miscomputing the offset and
10098     size of each field is that we end up also miscomputing the size
10099     of the containing type.  This can have adverse results when computing
10100     the value of an entity.  GDB fetches the value of an entity based
10101     on the size of its type, and thus a wrong size causes GDB to fetch
10102     the wrong amount of memory.  In the case where the computed size is
10103     too small, GDB fetches too little data to print the value of our
10104     entity.  Results in this case are unpredictable, as we usually read
10105     past the buffer containing the data =:-o.  */
10106
10107 /* A helper function for TERNOP_IN_RANGE.  */
10108
10109 static value *
10110 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
10111                       enum noside noside,
10112                       value *arg1, value *arg2, value *arg3)
10113 {
10114   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10115   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10116   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10117   return
10118     value_from_longest (type,
10119                         (value_less (arg1, arg3)
10120                          || value_equal (arg1, arg3))
10121                         && (value_less (arg2, arg1)
10122                             || value_equal (arg2, arg1)));
10123 }
10124
10125 /* A helper function for UNOP_NEG.  */
10126
10127 value *
10128 ada_unop_neg (struct type *expect_type,
10129               struct expression *exp,
10130               enum noside noside, enum exp_opcode op,
10131               struct value *arg1)
10132 {
10133   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10134   return value_neg (arg1);
10135 }
10136
10137 /* A helper function for UNOP_IN_RANGE.  */
10138
10139 value *
10140 ada_unop_in_range (struct type *expect_type,
10141                    struct expression *exp,
10142                    enum noside noside, enum exp_opcode op,
10143                    struct value *arg1, struct type *type)
10144 {
10145   struct value *arg2, *arg3;
10146   switch (type->code ())
10147     {
10148     default:
10149       lim_warning (_("Membership test incompletely implemented; "
10150                      "always returns true"));
10151       type = language_bool_type (exp->language_defn, exp->gdbarch);
10152       return value_from_longest (type, (LONGEST) 1);
10153
10154     case TYPE_CODE_RANGE:
10155       arg2 = value_from_longest (type,
10156                                  type->bounds ()->low.const_val ());
10157       arg3 = value_from_longest (type,
10158                                  type->bounds ()->high.const_val ());
10159       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10160       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10161       type = language_bool_type (exp->language_defn, exp->gdbarch);
10162       return
10163         value_from_longest (type,
10164                             (value_less (arg1, arg3)
10165                              || value_equal (arg1, arg3))
10166                             && (value_less (arg2, arg1)
10167                                 || value_equal (arg2, arg1)));
10168     }
10169 }
10170
10171 /* A helper function for OP_ATR_TAG.  */
10172
10173 value *
10174 ada_atr_tag (struct type *expect_type,
10175              struct expression *exp,
10176              enum noside noside, enum exp_opcode op,
10177              struct value *arg1)
10178 {
10179   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10180     return value_zero (ada_tag_type (arg1), not_lval);
10181
10182   return ada_value_tag (arg1);
10183 }
10184
10185 /* A helper function for OP_ATR_SIZE.  */
10186
10187 value *
10188 ada_atr_size (struct type *expect_type,
10189               struct expression *exp,
10190               enum noside noside, enum exp_opcode op,
10191               struct value *arg1)
10192 {
10193   struct type *type = value_type (arg1);
10194
10195   /* If the argument is a reference, then dereference its type, since
10196      the user is really asking for the size of the actual object,
10197      not the size of the pointer.  */
10198   if (type->code () == TYPE_CODE_REF)
10199     type = type->target_type ();
10200
10201   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10202     return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
10203   else
10204     return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
10205                                TARGET_CHAR_BIT * type->length ());
10206 }
10207
10208 /* A helper function for UNOP_ABS.  */
10209
10210 value *
10211 ada_abs (struct type *expect_type,
10212          struct expression *exp,
10213          enum noside noside, enum exp_opcode op,
10214          struct value *arg1)
10215 {
10216   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10217   if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
10218     return value_neg (arg1);
10219   else
10220     return arg1;
10221 }
10222
10223 /* A helper function for BINOP_MUL.  */
10224
10225 value *
10226 ada_mult_binop (struct type *expect_type,
10227                 struct expression *exp,
10228                 enum noside noside, enum exp_opcode op,
10229                 struct value *arg1, struct value *arg2)
10230 {
10231   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10232     {
10233       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10234       return value_zero (value_type (arg1), not_lval);
10235     }
10236   else
10237     {
10238       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10239       return ada_value_binop (arg1, arg2, op);
10240     }
10241 }
10242
10243 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL.  */
10244
10245 value *
10246 ada_equal_binop (struct type *expect_type,
10247                  struct expression *exp,
10248                  enum noside noside, enum exp_opcode op,
10249                  struct value *arg1, struct value *arg2)
10250 {
10251   int tem;
10252   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10253     tem = 0;
10254   else
10255     {
10256       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10257       tem = ada_value_equal (arg1, arg2);
10258     }
10259   if (op == BINOP_NOTEQUAL)
10260     tem = !tem;
10261   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10262   return value_from_longest (type, (LONGEST) tem);
10263 }
10264
10265 /* A helper function for TERNOP_SLICE.  */
10266
10267 value *
10268 ada_ternop_slice (struct expression *exp,
10269                   enum noside noside,
10270                   struct value *array, struct value *low_bound_val,
10271                   struct value *high_bound_val)
10272 {
10273   LONGEST low_bound;
10274   LONGEST high_bound;
10275
10276   low_bound_val = coerce_ref (low_bound_val);
10277   high_bound_val = coerce_ref (high_bound_val);
10278   low_bound = value_as_long (low_bound_val);
10279   high_bound = value_as_long (high_bound_val);
10280
10281   /* If this is a reference to an aligner type, then remove all
10282      the aligners.  */
10283   if (value_type (array)->code () == TYPE_CODE_REF
10284       && ada_is_aligner_type (value_type (array)->target_type ()))
10285     value_type (array)->set_target_type
10286       (ada_aligned_type (value_type (array)->target_type ()));
10287
10288   if (ada_is_any_packed_array_type (value_type (array)))
10289     error (_("cannot slice a packed array"));
10290
10291   /* If this is a reference to an array or an array lvalue,
10292      convert to a pointer.  */
10293   if (value_type (array)->code () == TYPE_CODE_REF
10294       || (value_type (array)->code () == TYPE_CODE_ARRAY
10295           && VALUE_LVAL (array) == lval_memory))
10296     array = value_addr (array);
10297
10298   if (noside == EVAL_AVOID_SIDE_EFFECTS
10299       && ada_is_array_descriptor_type (ada_check_typedef
10300                                        (value_type (array))))
10301     return empty_array (ada_type_of_array (array, 0), low_bound,
10302                         high_bound);
10303
10304   array = ada_coerce_to_simple_array_ptr (array);
10305
10306   /* If we have more than one level of pointer indirection,
10307      dereference the value until we get only one level.  */
10308   while (value_type (array)->code () == TYPE_CODE_PTR
10309          && (value_type (array)->target_type ()->code ()
10310              == TYPE_CODE_PTR))
10311     array = value_ind (array);
10312
10313   /* Make sure we really do have an array type before going further,
10314      to avoid a SEGV when trying to get the index type or the target
10315      type later down the road if the debug info generated by
10316      the compiler is incorrect or incomplete.  */
10317   if (!ada_is_simple_array_type (value_type (array)))
10318     error (_("cannot take slice of non-array"));
10319
10320   if (ada_check_typedef (value_type (array))->code ()
10321       == TYPE_CODE_PTR)
10322     {
10323       struct type *type0 = ada_check_typedef (value_type (array));
10324
10325       if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10326         return empty_array (type0->target_type (), low_bound, high_bound);
10327       else
10328         {
10329           struct type *arr_type0 =
10330             to_fixed_array_type (type0->target_type (), NULL, 1);
10331
10332           return ada_value_slice_from_ptr (array, arr_type0,
10333                                            longest_to_int (low_bound),
10334                                            longest_to_int (high_bound));
10335         }
10336     }
10337   else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10338     return array;
10339   else if (high_bound < low_bound)
10340     return empty_array (value_type (array), low_bound, high_bound);
10341   else
10342     return ada_value_slice (array, longest_to_int (low_bound),
10343                             longest_to_int (high_bound));
10344 }
10345
10346 /* A helper function for BINOP_IN_BOUNDS.  */
10347
10348 value *
10349 ada_binop_in_bounds (struct expression *exp, enum noside noside,
10350                      struct value *arg1, struct value *arg2, int n)
10351 {
10352   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10353     {
10354       struct type *type = language_bool_type (exp->language_defn,
10355                                               exp->gdbarch);
10356       return value_zero (type, not_lval);
10357     }
10358
10359   struct type *type = ada_index_type (value_type (arg2), n, "range");
10360   if (!type)
10361     type = value_type (arg1);
10362
10363   value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
10364   arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
10365
10366   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10367   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10368   type = language_bool_type (exp->language_defn, exp->gdbarch);
10369   return value_from_longest (type,
10370                              (value_less (arg1, arg3)
10371                               || value_equal (arg1, arg3))
10372                              && (value_less (arg2, arg1)
10373                                  || value_equal (arg2, arg1)));
10374 }
10375
10376 /* A helper function for some attribute operations.  */
10377
10378 static value *
10379 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
10380               struct value *arg1, struct type *type_arg, int tem)
10381 {
10382   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10383     {
10384       if (type_arg == NULL)
10385         type_arg = value_type (arg1);
10386
10387       if (ada_is_constrained_packed_array_type (type_arg))
10388         type_arg = decode_constrained_packed_array_type (type_arg);
10389
10390       if (!discrete_type_p (type_arg))
10391         {
10392           switch (op)
10393             {
10394             default:          /* Should never happen.  */
10395               error (_("unexpected attribute encountered"));
10396             case OP_ATR_FIRST:
10397             case OP_ATR_LAST:
10398               type_arg = ada_index_type (type_arg, tem,
10399                                          ada_attribute_name (op));
10400               break;
10401             case OP_ATR_LENGTH:
10402               type_arg = builtin_type (exp->gdbarch)->builtin_int;
10403               break;
10404             }
10405         }
10406
10407       return value_zero (type_arg, not_lval);
10408     }
10409   else if (type_arg == NULL)
10410     {
10411       arg1 = ada_coerce_ref (arg1);
10412
10413       if (ada_is_constrained_packed_array_type (value_type (arg1)))
10414         arg1 = ada_coerce_to_simple_array (arg1);
10415
10416       struct type *type;
10417       if (op == OP_ATR_LENGTH)
10418         type = builtin_type (exp->gdbarch)->builtin_int;
10419       else
10420         {
10421           type = ada_index_type (value_type (arg1), tem,
10422                                  ada_attribute_name (op));
10423           if (type == NULL)
10424             type = builtin_type (exp->gdbarch)->builtin_int;
10425         }
10426
10427       switch (op)
10428         {
10429         default:          /* Should never happen.  */
10430           error (_("unexpected attribute encountered"));
10431         case OP_ATR_FIRST:
10432           return value_from_longest
10433             (type, ada_array_bound (arg1, tem, 0));
10434         case OP_ATR_LAST:
10435           return value_from_longest
10436             (type, ada_array_bound (arg1, tem, 1));
10437         case OP_ATR_LENGTH:
10438           return value_from_longest
10439             (type, ada_array_length (arg1, tem));
10440         }
10441     }
10442   else if (discrete_type_p (type_arg))
10443     {
10444       struct type *range_type;
10445       const char *name = ada_type_name (type_arg);
10446
10447       range_type = NULL;
10448       if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10449         range_type = to_fixed_range_type (type_arg, NULL);
10450       if (range_type == NULL)
10451         range_type = type_arg;
10452       switch (op)
10453         {
10454         default:
10455           error (_("unexpected attribute encountered"));
10456         case OP_ATR_FIRST:
10457           return value_from_longest 
10458             (range_type, ada_discrete_type_low_bound (range_type));
10459         case OP_ATR_LAST:
10460           return value_from_longest
10461             (range_type, ada_discrete_type_high_bound (range_type));
10462         case OP_ATR_LENGTH:
10463           error (_("the 'length attribute applies only to array types"));
10464         }
10465     }
10466   else if (type_arg->code () == TYPE_CODE_FLT)
10467     error (_("unimplemented type attribute"));
10468   else
10469     {
10470       LONGEST low, high;
10471
10472       if (ada_is_constrained_packed_array_type (type_arg))
10473         type_arg = decode_constrained_packed_array_type (type_arg);
10474
10475       struct type *type;
10476       if (op == OP_ATR_LENGTH)
10477         type = builtin_type (exp->gdbarch)->builtin_int;
10478       else
10479         {
10480           type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10481           if (type == NULL)
10482             type = builtin_type (exp->gdbarch)->builtin_int;
10483         }
10484
10485       switch (op)
10486         {
10487         default:
10488           error (_("unexpected attribute encountered"));
10489         case OP_ATR_FIRST:
10490           low = ada_array_bound_from_type (type_arg, tem, 0);
10491           return value_from_longest (type, low);
10492         case OP_ATR_LAST:
10493           high = ada_array_bound_from_type (type_arg, tem, 1);
10494           return value_from_longest (type, high);
10495         case OP_ATR_LENGTH:
10496           low = ada_array_bound_from_type (type_arg, tem, 0);
10497           high = ada_array_bound_from_type (type_arg, tem, 1);
10498           return value_from_longest (type, high - low + 1);
10499         }
10500     }
10501 }
10502
10503 /* A helper function for OP_ATR_MIN and OP_ATR_MAX.  */
10504
10505 struct value *
10506 ada_binop_minmax (struct type *expect_type,
10507                   struct expression *exp,
10508                   enum noside noside, enum exp_opcode op,
10509                   struct value *arg1, struct value *arg2)
10510 {
10511   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10512     return value_zero (value_type (arg1), not_lval);
10513   else
10514     {
10515       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10516       return value_binop (arg1, arg2, op);
10517     }
10518 }
10519
10520 /* A helper function for BINOP_EXP.  */
10521
10522 struct value *
10523 ada_binop_exp (struct type *expect_type,
10524                struct expression *exp,
10525                enum noside noside, enum exp_opcode op,
10526                struct value *arg1, struct value *arg2)
10527 {
10528   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10529     return value_zero (value_type (arg1), not_lval);
10530   else
10531     {
10532       /* For integer exponentiation operations,
10533          only promote the first argument.  */
10534       if (is_integral_type (value_type (arg2)))
10535         unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10536       else
10537         binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10538
10539       return value_binop (arg1, arg2, op);
10540     }
10541 }
10542
10543 namespace expr
10544 {
10545
10546 /* See ada-exp.h.  */
10547
10548 operation_up
10549 ada_resolvable::replace (operation_up &&owner,
10550                          struct expression *exp,
10551                          bool deprocedure_p,
10552                          bool parse_completion,
10553                          innermost_block_tracker *tracker,
10554                          struct type *context_type)
10555 {
10556   if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10557     return (make_operation<ada_funcall_operation>
10558             (std::move (owner),
10559              std::vector<operation_up> ()));
10560   return std::move (owner);
10561 }
10562
10563 /* Convert the character literal whose value would be VAL to the
10564    appropriate value of type TYPE, if there is a translation.
10565    Otherwise return VAL.  Hence, in an enumeration type ('A', 'B'),
10566    the literal 'A' (VAL == 65), returns 0.  */
10567
10568 static LONGEST
10569 convert_char_literal (struct type *type, LONGEST val)
10570 {
10571   char name[12];
10572   int f;
10573
10574   if (type == NULL)
10575     return val;
10576   type = check_typedef (type);
10577   if (type->code () != TYPE_CODE_ENUM)
10578     return val;
10579
10580   if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10581     xsnprintf (name, sizeof (name), "Q%c", (int) val);
10582   else if (val >= 0 && val < 256)
10583     xsnprintf (name, sizeof (name), "QU%02x", (unsigned) val);
10584   else if (val >= 0 && val < 0x10000)
10585     xsnprintf (name, sizeof (name), "QW%04x", (unsigned) val);
10586   else
10587     xsnprintf (name, sizeof (name), "QWW%08lx", (unsigned long) val);
10588   size_t len = strlen (name);
10589   for (f = 0; f < type->num_fields (); f += 1)
10590     {
10591       /* Check the suffix because an enum constant in a package will
10592          have a name like "pkg__QUxx".  This is safe enough because we
10593          already have the correct type, and because mangling means
10594          there can't be clashes.  */
10595       const char *ename = type->field (f).name ();
10596       size_t elen = strlen (ename);
10597
10598       if (elen >= len && strcmp (name, ename + elen - len) == 0)
10599         return type->field (f).loc_enumval ();
10600     }
10601   return val;
10602 }
10603
10604 value *
10605 ada_char_operation::evaluate (struct type *expect_type,
10606                               struct expression *exp,
10607                               enum noside noside)
10608 {
10609   value *result = long_const_operation::evaluate (expect_type, exp, noside);
10610   if (expect_type != nullptr)
10611     result = ada_value_cast (expect_type, result);
10612   return result;
10613 }
10614
10615 /* See ada-exp.h.  */
10616
10617 operation_up
10618 ada_char_operation::replace (operation_up &&owner,
10619                              struct expression *exp,
10620                              bool deprocedure_p,
10621                              bool parse_completion,
10622                              innermost_block_tracker *tracker,
10623                              struct type *context_type)
10624 {
10625   operation_up result = std::move (owner);
10626
10627   if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10628     {
10629       gdb_assert (result.get () == this);
10630       std::get<0> (m_storage) = context_type;
10631       std::get<1> (m_storage)
10632         = convert_char_literal (context_type, std::get<1> (m_storage));
10633     }
10634
10635   return result;
10636 }
10637
10638 value *
10639 ada_wrapped_operation::evaluate (struct type *expect_type,
10640                                  struct expression *exp,
10641                                  enum noside noside)
10642 {
10643   value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10644   if (noside == EVAL_NORMAL)
10645     result = unwrap_value (result);
10646
10647   /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10648      then we need to perform the conversion manually, because
10649      evaluate_subexp_standard doesn't do it.  This conversion is
10650      necessary in Ada because the different kinds of float/fixed
10651      types in Ada have different representations.
10652
10653      Similarly, we need to perform the conversion from OP_LONG
10654      ourselves.  */
10655   if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10656     result = ada_value_cast (expect_type, result);
10657
10658   return result;
10659 }
10660
10661 value *
10662 ada_string_operation::evaluate (struct type *expect_type,
10663                                 struct expression *exp,
10664                                 enum noside noside)
10665 {
10666   struct type *char_type;
10667   if (expect_type != nullptr && ada_is_string_type (expect_type))
10668     char_type = ada_array_element_type (expect_type, 1);
10669   else
10670     char_type = language_string_char_type (exp->language_defn, exp->gdbarch);
10671
10672   const std::string &str = std::get<0> (m_storage);
10673   const char *encoding;
10674   switch (char_type->length ())
10675     {
10676     case 1:
10677       {
10678         /* Simply copy over the data -- this isn't perhaps strictly
10679            correct according to the encodings, but it is gdb's
10680            historical behavior.  */
10681         struct type *stringtype
10682           = lookup_array_range_type (char_type, 1, str.length ());
10683         struct value *val = allocate_value (stringtype);
10684         memcpy (value_contents_raw (val).data (), str.c_str (),
10685                 str.length ());
10686         return val;
10687       }
10688
10689     case 2:
10690       if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10691         encoding = "UTF-16BE";
10692       else
10693         encoding = "UTF-16LE";
10694       break;
10695
10696     case 4:
10697       if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10698         encoding = "UTF-32BE";
10699       else
10700         encoding = "UTF-32LE";
10701       break;
10702
10703     default:
10704       error (_("unexpected character type size %s"),
10705              pulongest (char_type->length ()));
10706     }
10707
10708   auto_obstack converted;
10709   convert_between_encodings (host_charset (), encoding,
10710                              (const gdb_byte *) str.c_str (),
10711                              str.length (), 1,
10712                              &converted, translit_none);
10713
10714   struct type *stringtype
10715     = lookup_array_range_type (char_type, 1,
10716                                obstack_object_size (&converted)
10717                                / char_type->length ());
10718   struct value *val = allocate_value (stringtype);
10719   memcpy (value_contents_raw (val).data (),
10720           obstack_base (&converted),
10721           obstack_object_size (&converted));
10722   return val;
10723 }
10724
10725 value *
10726 ada_concat_operation::evaluate (struct type *expect_type,
10727                                 struct expression *exp,
10728                                 enum noside noside)
10729 {
10730   /* If one side is a literal, evaluate the other side first so that
10731      the expected type can be set properly.  */
10732   const operation_up &lhs_expr = std::get<0> (m_storage);
10733   const operation_up &rhs_expr = std::get<1> (m_storage);
10734
10735   value *lhs, *rhs;
10736   if (dynamic_cast<ada_string_operation *> (lhs_expr.get ()) != nullptr)
10737     {
10738       rhs = rhs_expr->evaluate (nullptr, exp, noside);
10739       lhs = lhs_expr->evaluate (value_type (rhs), exp, noside);
10740     }
10741   else if (dynamic_cast<ada_char_operation *> (lhs_expr.get ()) != nullptr)
10742     {
10743       rhs = rhs_expr->evaluate (nullptr, exp, noside);
10744       struct type *rhs_type = check_typedef (value_type (rhs));
10745       struct type *elt_type = nullptr;
10746       if (rhs_type->code () == TYPE_CODE_ARRAY)
10747         elt_type = rhs_type->target_type ();
10748       lhs = lhs_expr->evaluate (elt_type, exp, noside);
10749     }
10750   else if (dynamic_cast<ada_string_operation *> (rhs_expr.get ()) != nullptr)
10751     {
10752       lhs = lhs_expr->evaluate (nullptr, exp, noside);
10753       rhs = rhs_expr->evaluate (value_type (lhs), exp, noside);
10754     }
10755   else if (dynamic_cast<ada_char_operation *> (rhs_expr.get ()) != nullptr)
10756     {
10757       lhs = lhs_expr->evaluate (nullptr, exp, noside);
10758       struct type *lhs_type = check_typedef (value_type (lhs));
10759       struct type *elt_type = nullptr;
10760       if (lhs_type->code () == TYPE_CODE_ARRAY)
10761         elt_type = lhs_type->target_type ();
10762       rhs = rhs_expr->evaluate (elt_type, exp, noside);
10763     }
10764   else
10765     return concat_operation::evaluate (expect_type, exp, noside);
10766
10767   return value_concat (lhs, rhs);
10768 }
10769
10770 value *
10771 ada_qual_operation::evaluate (struct type *expect_type,
10772                               struct expression *exp,
10773                               enum noside noside)
10774 {
10775   struct type *type = std::get<1> (m_storage);
10776   return std::get<0> (m_storage)->evaluate (type, exp, noside);
10777 }
10778
10779 value *
10780 ada_ternop_range_operation::evaluate (struct type *expect_type,
10781                                       struct expression *exp,
10782                                       enum noside noside)
10783 {
10784   value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10785   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10786   value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10787   return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10788 }
10789
10790 value *
10791 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10792                                       struct expression *exp,
10793                                       enum noside noside)
10794 {
10795   value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10796   value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10797
10798   auto do_op = [=] (LONGEST x, LONGEST y)
10799     {
10800       if (std::get<0> (m_storage) == BINOP_ADD)
10801         return x + y;
10802       return x - y;
10803     };
10804
10805   if (value_type (arg1)->code () == TYPE_CODE_PTR)
10806     return (value_from_longest
10807             (value_type (arg1),
10808              do_op (value_as_long (arg1), value_as_long (arg2))));
10809   if (value_type (arg2)->code () == TYPE_CODE_PTR)
10810     return (value_from_longest
10811             (value_type (arg2),
10812              do_op (value_as_long (arg1), value_as_long (arg2))));
10813   /* Preserve the original type for use by the range case below.
10814      We cannot cast the result to a reference type, so if ARG1 is
10815      a reference type, find its underlying type.  */
10816   struct type *type = value_type (arg1);
10817   while (type->code () == TYPE_CODE_REF)
10818     type = type->target_type ();
10819   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10820   arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10821   /* We need to special-case the result with a range.
10822      This is done for the benefit of "ptype".  gdb's Ada support
10823      historically used the LHS to set the result type here, so
10824      preserve this behavior.  */
10825   if (type->code () == TYPE_CODE_RANGE)
10826     arg1 = value_cast (type, arg1);
10827   return arg1;
10828 }
10829
10830 value *
10831 ada_unop_atr_operation::evaluate (struct type *expect_type,
10832                                   struct expression *exp,
10833                                   enum noside noside)
10834 {
10835   struct type *type_arg = nullptr;
10836   value *val = nullptr;
10837
10838   if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10839     {
10840       value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10841                                                       EVAL_AVOID_SIDE_EFFECTS);
10842       type_arg = value_type (tem);
10843     }
10844   else
10845     val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10846
10847   return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10848                        val, type_arg, std::get<2> (m_storage));
10849 }
10850
10851 value *
10852 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10853                                                  struct expression *exp,
10854                                                  enum noside noside)
10855 {
10856   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10857     return value_zero (expect_type, not_lval);
10858
10859   const bound_minimal_symbol &b = std::get<0> (m_storage);
10860   value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10861
10862   val = ada_value_cast (expect_type, val);
10863
10864   /* Follow the Ada language semantics that do not allow taking
10865      an address of the result of a cast (view conversion in Ada).  */
10866   if (VALUE_LVAL (val) == lval_memory)
10867     {
10868       if (value_lazy (val))
10869         value_fetch_lazy (val);
10870       VALUE_LVAL (val) = not_lval;
10871     }
10872   return val;
10873 }
10874
10875 value *
10876 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10877                                             struct expression *exp,
10878                                             enum noside noside)
10879 {
10880   value *val = evaluate_var_value (noside,
10881                                    std::get<0> (m_storage).block,
10882                                    std::get<0> (m_storage).symbol);
10883
10884   val = ada_value_cast (expect_type, val);
10885
10886   /* Follow the Ada language semantics that do not allow taking
10887      an address of the result of a cast (view conversion in Ada).  */
10888   if (VALUE_LVAL (val) == lval_memory)
10889     {
10890       if (value_lazy (val))
10891         value_fetch_lazy (val);
10892       VALUE_LVAL (val) = not_lval;
10893     }
10894   return val;
10895 }
10896
10897 value *
10898 ada_var_value_operation::evaluate (struct type *expect_type,
10899                                    struct expression *exp,
10900                                    enum noside noside)
10901 {
10902   symbol *sym = std::get<0> (m_storage).symbol;
10903
10904   if (sym->domain () == UNDEF_DOMAIN)
10905     /* Only encountered when an unresolved symbol occurs in a
10906        context other than a function call, in which case, it is
10907        invalid.  */
10908     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10909            sym->print_name ());
10910
10911   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10912     {
10913       struct type *type = static_unwrap_type (sym->type ());
10914       /* Check to see if this is a tagged type.  We also need to handle
10915          the case where the type is a reference to a tagged type, but
10916          we have to be careful to exclude pointers to tagged types.
10917          The latter should be shown as usual (as a pointer), whereas
10918          a reference should mostly be transparent to the user.  */
10919       if (ada_is_tagged_type (type, 0)
10920           || (type->code () == TYPE_CODE_REF
10921               && ada_is_tagged_type (type->target_type (), 0)))
10922         {
10923           /* Tagged types are a little special in the fact that the real
10924              type is dynamic and can only be determined by inspecting the
10925              object's tag.  This means that we need to get the object's
10926              value first (EVAL_NORMAL) and then extract the actual object
10927              type from its tag.
10928
10929              Note that we cannot skip the final step where we extract
10930              the object type from its tag, because the EVAL_NORMAL phase
10931              results in dynamic components being resolved into fixed ones.
10932              This can cause problems when trying to print the type
10933              description of tagged types whose parent has a dynamic size:
10934              We use the type name of the "_parent" component in order
10935              to print the name of the ancestor type in the type description.
10936              If that component had a dynamic size, the resolution into
10937              a fixed type would result in the loss of that type name,
10938              thus preventing us from printing the name of the ancestor
10939              type in the type description.  */
10940           value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10941
10942           if (type->code () != TYPE_CODE_REF)
10943             {
10944               struct type *actual_type;
10945
10946               actual_type = type_from_tag (ada_value_tag (arg1));
10947               if (actual_type == NULL)
10948                 /* If, for some reason, we were unable to determine
10949                    the actual type from the tag, then use the static
10950                    approximation that we just computed as a fallback.
10951                    This can happen if the debugging information is
10952                    incomplete, for instance.  */
10953                 actual_type = type;
10954               return value_zero (actual_type, not_lval);
10955             }
10956           else
10957             {
10958               /* In the case of a ref, ada_coerce_ref takes care
10959                  of determining the actual type.  But the evaluation
10960                  should return a ref as it should be valid to ask
10961                  for its address; so rebuild a ref after coerce.  */
10962               arg1 = ada_coerce_ref (arg1);
10963               return value_ref (arg1, TYPE_CODE_REF);
10964             }
10965         }
10966
10967       /* Records and unions for which GNAT encodings have been
10968          generated need to be statically fixed as well.
10969          Otherwise, non-static fixing produces a type where
10970          all dynamic properties are removed, which prevents "ptype"
10971          from being able to completely describe the type.
10972          For instance, a case statement in a variant record would be
10973          replaced by the relevant components based on the actual
10974          value of the discriminants.  */
10975       if ((type->code () == TYPE_CODE_STRUCT
10976            && dynamic_template_type (type) != NULL)
10977           || (type->code () == TYPE_CODE_UNION
10978               && ada_find_parallel_type (type, "___XVU") != NULL))
10979         return value_zero (to_static_fixed_type (type), not_lval);
10980     }
10981
10982   value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10983   return ada_to_fixed_value (arg1);
10984 }
10985
10986 bool
10987 ada_var_value_operation::resolve (struct expression *exp,
10988                                   bool deprocedure_p,
10989                                   bool parse_completion,
10990                                   innermost_block_tracker *tracker,
10991                                   struct type *context_type)
10992 {
10993   symbol *sym = std::get<0> (m_storage).symbol;
10994   if (sym->domain () == UNDEF_DOMAIN)
10995     {
10996       block_symbol resolved
10997         = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10998                                 context_type, parse_completion,
10999                                 deprocedure_p, tracker);
11000       std::get<0> (m_storage) = resolved;
11001     }
11002
11003   if (deprocedure_p
11004       && (std::get<0> (m_storage).symbol->type ()->code ()
11005           == TYPE_CODE_FUNC))
11006     return true;
11007
11008   return false;
11009 }
11010
11011 value *
11012 ada_atr_val_operation::evaluate (struct type *expect_type,
11013                                  struct expression *exp,
11014                                  enum noside noside)
11015 {
11016   value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
11017   return ada_val_atr (noside, std::get<0> (m_storage), arg);
11018 }
11019
11020 value *
11021 ada_unop_ind_operation::evaluate (struct type *expect_type,
11022                                   struct expression *exp,
11023                                   enum noside noside)
11024 {
11025   value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
11026
11027   struct type *type = ada_check_typedef (value_type (arg1));
11028   if (noside == EVAL_AVOID_SIDE_EFFECTS)
11029     {
11030       if (ada_is_array_descriptor_type (type))
11031         /* GDB allows dereferencing GNAT array descriptors.  */
11032         {
11033           struct type *arrType = ada_type_of_array (arg1, 0);
11034
11035           if (arrType == NULL)
11036             error (_("Attempt to dereference null array pointer."));
11037           return value_at_lazy (arrType, 0);
11038         }
11039       else if (type->code () == TYPE_CODE_PTR
11040                || type->code () == TYPE_CODE_REF
11041                /* In C you can dereference an array to get the 1st elt.  */
11042                || type->code () == TYPE_CODE_ARRAY)
11043         {
11044           /* As mentioned in the OP_VAR_VALUE case, tagged types can
11045              only be determined by inspecting the object's tag.
11046              This means that we need to evaluate completely the
11047              expression in order to get its type.  */
11048
11049           if ((type->code () == TYPE_CODE_REF
11050                || type->code () == TYPE_CODE_PTR)
11051               && ada_is_tagged_type (type->target_type (), 0))
11052             {
11053               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11054                                                         EVAL_NORMAL);
11055               type = value_type (ada_value_ind (arg1));
11056             }
11057           else
11058             {
11059               type = to_static_fixed_type
11060                 (ada_aligned_type
11061                  (ada_check_typedef (type->target_type ())));
11062             }
11063           return value_zero (type, lval_memory);
11064         }
11065       else if (type->code () == TYPE_CODE_INT)
11066         {
11067           /* GDB allows dereferencing an int.  */
11068           if (expect_type == NULL)
11069             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11070                                lval_memory);
11071           else
11072             {
11073               expect_type =
11074                 to_static_fixed_type (ada_aligned_type (expect_type));
11075               return value_zero (expect_type, lval_memory);
11076             }
11077         }
11078       else
11079         error (_("Attempt to take contents of a non-pointer value."));
11080     }
11081   arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
11082   type = ada_check_typedef (value_type (arg1));
11083
11084   if (type->code () == TYPE_CODE_INT)
11085     /* GDB allows dereferencing an int.  If we were given
11086        the expect_type, then use that as the target type.
11087        Otherwise, assume that the target type is an int.  */
11088     {
11089       if (expect_type != NULL)
11090         return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11091                                           arg1));
11092       else
11093         return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11094                               (CORE_ADDR) value_as_address (arg1));
11095     }
11096
11097   if (ada_is_array_descriptor_type (type))
11098     /* GDB allows dereferencing GNAT array descriptors.  */
11099     return ada_coerce_to_simple_array (arg1);
11100   else
11101     return ada_value_ind (arg1);
11102 }
11103
11104 value *
11105 ada_structop_operation::evaluate (struct type *expect_type,
11106                                   struct expression *exp,
11107                                   enum noside noside)
11108 {
11109   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
11110   const char *str = std::get<1> (m_storage).c_str ();
11111   if (noside == EVAL_AVOID_SIDE_EFFECTS)
11112     {
11113       struct type *type;
11114       struct type *type1 = value_type (arg1);
11115
11116       if (ada_is_tagged_type (type1, 1))
11117         {
11118           type = ada_lookup_struct_elt_type (type1, str, 1, 1);
11119
11120           /* If the field is not found, check if it exists in the
11121              extension of this object's type. This means that we
11122              need to evaluate completely the expression.  */
11123
11124           if (type == NULL)
11125             {
11126               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11127                                                         EVAL_NORMAL);
11128               arg1 = ada_value_struct_elt (arg1, str, 0);
11129               arg1 = unwrap_value (arg1);
11130               type = value_type (ada_to_fixed_value (arg1));
11131             }
11132         }
11133       else
11134         type = ada_lookup_struct_elt_type (type1, str, 1, 0);
11135
11136       return value_zero (ada_aligned_type (type), lval_memory);
11137     }
11138   else
11139     {
11140       arg1 = ada_value_struct_elt (arg1, str, 0);
11141       arg1 = unwrap_value (arg1);
11142       return ada_to_fixed_value (arg1);
11143     }
11144 }
11145
11146 value *
11147 ada_funcall_operation::evaluate (struct type *expect_type,
11148                                  struct expression *exp,
11149                                  enum noside noside)
11150 {
11151   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11152   int nargs = args_up.size ();
11153   std::vector<value *> argvec (nargs);
11154   operation_up &callee_op = std::get<0> (m_storage);
11155
11156   ada_var_value_operation *avv
11157     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11158   if (avv != nullptr
11159       && avv->get_symbol ()->domain () == UNDEF_DOMAIN)
11160     error (_("Unexpected unresolved symbol, %s, during evaluation"),
11161            avv->get_symbol ()->print_name ());
11162
11163   value *callee = callee_op->evaluate (nullptr, exp, noside);
11164   for (int i = 0; i < args_up.size (); ++i)
11165     argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
11166
11167   if (ada_is_constrained_packed_array_type
11168       (desc_base_type (value_type (callee))))
11169     callee = ada_coerce_to_simple_array (callee);
11170   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11171            && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
11172     /* This is a packed array that has already been fixed, and
11173        therefore already coerced to a simple array.  Nothing further
11174        to do.  */
11175     ;
11176   else if (value_type (callee)->code () == TYPE_CODE_REF)
11177     {
11178       /* Make sure we dereference references so that all the code below
11179          feels like it's really handling the referenced value.  Wrapping
11180          types (for alignment) may be there, so make sure we strip them as
11181          well.  */
11182       callee = ada_to_fixed_value (coerce_ref (callee));
11183     }
11184   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11185            && VALUE_LVAL (callee) == lval_memory)
11186     callee = value_addr (callee);
11187
11188   struct type *type = ada_check_typedef (value_type (callee));
11189
11190   /* Ada allows us to implicitly dereference arrays when subscripting
11191      them.  So, if this is an array typedef (encoding use for array
11192      access types encoded as fat pointers), strip it now.  */
11193   if (type->code () == TYPE_CODE_TYPEDEF)
11194     type = ada_typedef_target_type (type);
11195
11196   if (type->code () == TYPE_CODE_PTR)
11197     {
11198       switch (ada_check_typedef (type->target_type ())->code ())
11199         {
11200         case TYPE_CODE_FUNC:
11201           type = ada_check_typedef (type->target_type ());
11202           break;
11203         case TYPE_CODE_ARRAY:
11204           break;
11205         case TYPE_CODE_STRUCT:
11206           if (noside != EVAL_AVOID_SIDE_EFFECTS)
11207             callee = ada_value_ind (callee);
11208           type = ada_check_typedef (type->target_type ());
11209           break;
11210         default:
11211           error (_("cannot subscript or call something of type `%s'"),
11212                  ada_type_name (value_type (callee)));
11213           break;
11214         }
11215     }
11216
11217   switch (type->code ())
11218     {
11219     case TYPE_CODE_FUNC:
11220       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11221         {
11222           if (type->target_type () == NULL)
11223             error_call_unknown_return_type (NULL);
11224           return allocate_value (type->target_type ());
11225         }
11226       return call_function_by_hand (callee, NULL, argvec);
11227     case TYPE_CODE_INTERNAL_FUNCTION:
11228       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11229         /* We don't know anything about what the internal
11230            function might return, but we have to return
11231            something.  */
11232         return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11233                            not_lval);
11234       else
11235         return call_internal_function (exp->gdbarch, exp->language_defn,
11236                                        callee, nargs,
11237                                        argvec.data ());
11238
11239     case TYPE_CODE_STRUCT:
11240       {
11241         int arity;
11242
11243         arity = ada_array_arity (type);
11244         type = ada_array_element_type (type, nargs);
11245         if (type == NULL)
11246           error (_("cannot subscript or call a record"));
11247         if (arity != nargs)
11248           error (_("wrong number of subscripts; expecting %d"), arity);
11249         if (noside == EVAL_AVOID_SIDE_EFFECTS)
11250           return value_zero (ada_aligned_type (type), lval_memory);
11251         return
11252           unwrap_value (ada_value_subscript
11253                         (callee, nargs, argvec.data ()));
11254       }
11255     case TYPE_CODE_ARRAY:
11256       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11257         {
11258           type = ada_array_element_type (type, nargs);
11259           if (type == NULL)
11260             error (_("element type of array unknown"));
11261           else
11262             return value_zero (ada_aligned_type (type), lval_memory);
11263         }
11264       return
11265         unwrap_value (ada_value_subscript
11266                       (ada_coerce_to_simple_array (callee),
11267                        nargs, argvec.data ()));
11268     case TYPE_CODE_PTR:     /* Pointer to array */
11269       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11270         {
11271           type = to_fixed_array_type (type->target_type (), NULL, 1);
11272           type = ada_array_element_type (type, nargs);
11273           if (type == NULL)
11274             error (_("element type of array unknown"));
11275           else
11276             return value_zero (ada_aligned_type (type), lval_memory);
11277         }
11278       return
11279         unwrap_value (ada_value_ptr_subscript (callee, nargs,
11280                                                argvec.data ()));
11281
11282     default:
11283       error (_("Attempt to index or call something other than an "
11284                "array or function"));
11285     }
11286 }
11287
11288 bool
11289 ada_funcall_operation::resolve (struct expression *exp,
11290                                 bool deprocedure_p,
11291                                 bool parse_completion,
11292                                 innermost_block_tracker *tracker,
11293                                 struct type *context_type)
11294 {
11295   operation_up &callee_op = std::get<0> (m_storage);
11296
11297   ada_var_value_operation *avv
11298     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11299   if (avv == nullptr)
11300     return false;
11301
11302   symbol *sym = avv->get_symbol ();
11303   if (sym->domain () != UNDEF_DOMAIN)
11304     return false;
11305
11306   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11307   int nargs = args_up.size ();
11308   std::vector<value *> argvec (nargs);
11309
11310   for (int i = 0; i < args_up.size (); ++i)
11311     argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
11312
11313   const block *block = avv->get_block ();
11314   block_symbol resolved
11315     = ada_resolve_funcall (sym, block,
11316                            context_type, parse_completion,
11317                            nargs, argvec.data (),
11318                            tracker);
11319
11320   std::get<0> (m_storage)
11321     = make_operation<ada_var_value_operation> (resolved);
11322   return false;
11323 }
11324
11325 bool
11326 ada_ternop_slice_operation::resolve (struct expression *exp,
11327                                      bool deprocedure_p,
11328                                      bool parse_completion,
11329                                      innermost_block_tracker *tracker,
11330                                      struct type *context_type)
11331 {
11332   /* Historically this check was done during resolution, so we
11333      continue that here.  */
11334   value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
11335                                                 EVAL_AVOID_SIDE_EFFECTS);
11336   if (ada_is_any_packed_array_type (value_type (v)))
11337     error (_("cannot slice a packed array"));
11338   return false;
11339 }
11340
11341 }
11342
11343 \f
11344
11345 /* Return non-zero iff TYPE represents a System.Address type.  */
11346
11347 int
11348 ada_is_system_address_type (struct type *type)
11349 {
11350   return (type->name () && strcmp (type->name (), "system__address") == 0);
11351 }
11352
11353 \f
11354
11355                                 /* Range types */
11356
11357 /* Scan STR beginning at position K for a discriminant name, and
11358    return the value of that discriminant field of DVAL in *PX.  If
11359    PNEW_K is not null, put the position of the character beyond the
11360    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
11361    not alter *PX and *PNEW_K if unsuccessful.  */
11362
11363 static int
11364 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11365                     int *pnew_k)
11366 {
11367   static std::string storage;
11368   const char *pstart, *pend, *bound;
11369   struct value *bound_val;
11370
11371   if (dval == NULL || str == NULL || str[k] == '\0')
11372     return 0;
11373
11374   pstart = str + k;
11375   pend = strstr (pstart, "__");
11376   if (pend == NULL)
11377     {
11378       bound = pstart;
11379       k += strlen (bound);
11380     }
11381   else
11382     {
11383       int len = pend - pstart;
11384
11385       /* Strip __ and beyond.  */
11386       storage = std::string (pstart, len);
11387       bound = storage.c_str ();
11388       k = pend - str;
11389     }
11390
11391   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11392   if (bound_val == NULL)
11393     return 0;
11394
11395   *px = value_as_long (bound_val);
11396   if (pnew_k != NULL)
11397     *pnew_k = k;
11398   return 1;
11399 }
11400
11401 /* Value of variable named NAME.  Only exact matches are considered.
11402    If no such variable found, then if ERR_MSG is null, returns 0, and
11403    otherwise causes an error with message ERR_MSG.  */
11404
11405 static struct value *
11406 get_var_value (const char *name, const char *err_msg)
11407 {
11408   std::string quoted_name = add_angle_brackets (name);
11409
11410   lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
11411
11412   std::vector<struct block_symbol> syms
11413     = ada_lookup_symbol_list_worker (lookup_name,
11414                                      get_selected_block (0),
11415                                      VAR_DOMAIN, 1);
11416
11417   if (syms.size () != 1)
11418     {
11419       if (err_msg == NULL)
11420         return 0;
11421       else
11422         error (("%s"), err_msg);
11423     }
11424
11425   return value_of_variable (syms[0].symbol, syms[0].block);
11426 }
11427
11428 /* Value of integer variable named NAME in the current environment.
11429    If no such variable is found, returns false.  Otherwise, sets VALUE
11430    to the variable's value and returns true.  */
11431
11432 bool
11433 get_int_var_value (const char *name, LONGEST &value)
11434 {
11435   struct value *var_val = get_var_value (name, 0);
11436
11437   if (var_val == 0)
11438     return false;
11439
11440   value = value_as_long (var_val);
11441   return true;
11442 }
11443
11444
11445 /* Return a range type whose base type is that of the range type named
11446    NAME in the current environment, and whose bounds are calculated
11447    from NAME according to the GNAT range encoding conventions.
11448    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
11449    corresponding range type from debug information; fall back to using it
11450    if symbol lookup fails.  If a new type must be created, allocate it
11451    like ORIG_TYPE was.  The bounds information, in general, is encoded
11452    in NAME, the base type given in the named range type.  */
11453
11454 static struct type *
11455 to_fixed_range_type (struct type *raw_type, struct value *dval)
11456 {
11457   const char *name;
11458   struct type *base_type;
11459   const char *subtype_info;
11460
11461   gdb_assert (raw_type != NULL);
11462   gdb_assert (raw_type->name () != NULL);
11463
11464   if (raw_type->code () == TYPE_CODE_RANGE)
11465     base_type = raw_type->target_type ();
11466   else
11467     base_type = raw_type;
11468
11469   name = raw_type->name ();
11470   subtype_info = strstr (name, "___XD");
11471   if (subtype_info == NULL)
11472     {
11473       LONGEST L = ada_discrete_type_low_bound (raw_type);
11474       LONGEST U = ada_discrete_type_high_bound (raw_type);
11475
11476       if (L < INT_MIN || U > INT_MAX)
11477         return raw_type;
11478       else
11479         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11480                                          L, U);
11481     }
11482   else
11483     {
11484       int prefix_len = subtype_info - name;
11485       LONGEST L, U;
11486       struct type *type;
11487       const char *bounds_str;
11488       int n;
11489
11490       subtype_info += 5;
11491       bounds_str = strchr (subtype_info, '_');
11492       n = 1;
11493
11494       if (*subtype_info == 'L')
11495         {
11496           if (!ada_scan_number (bounds_str, n, &L, &n)
11497               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11498             return raw_type;
11499           if (bounds_str[n] == '_')
11500             n += 2;
11501           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
11502             n += 1;
11503           subtype_info += 1;
11504         }
11505       else
11506         {
11507           std::string name_buf = std::string (name, prefix_len) + "___L";
11508           if (!get_int_var_value (name_buf.c_str (), L))
11509             {
11510               lim_warning (_("Unknown lower bound, using 1."));
11511               L = 1;
11512             }
11513         }
11514
11515       if (*subtype_info == 'U')
11516         {
11517           if (!ada_scan_number (bounds_str, n, &U, &n)
11518               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11519             return raw_type;
11520         }
11521       else
11522         {
11523           std::string name_buf = std::string (name, prefix_len) + "___U";
11524           if (!get_int_var_value (name_buf.c_str (), U))
11525             {
11526               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11527               U = L;
11528             }
11529         }
11530
11531       type = create_static_range_type (alloc_type_copy (raw_type),
11532                                        base_type, L, U);
11533       /* create_static_range_type alters the resulting type's length
11534          to match the size of the base_type, which is not what we want.
11535          Set it back to the original range type's length.  */
11536       type->set_length (raw_type->length ());
11537       type->set_name (name);
11538       return type;
11539     }
11540 }
11541
11542 /* True iff NAME is the name of a range type.  */
11543
11544 int
11545 ada_is_range_type_name (const char *name)
11546 {
11547   return (name != NULL && strstr (name, "___XD"));
11548 }
11549 \f
11550
11551                                 /* Modular types */
11552
11553 /* True iff TYPE is an Ada modular type.  */
11554
11555 int
11556 ada_is_modular_type (struct type *type)
11557 {
11558   struct type *subranged_type = get_base_type (type);
11559
11560   return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11561           && subranged_type->code () == TYPE_CODE_INT
11562           && subranged_type->is_unsigned ());
11563 }
11564
11565 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
11566
11567 ULONGEST
11568 ada_modulus (struct type *type)
11569 {
11570   const dynamic_prop &high = type->bounds ()->high;
11571
11572   if (high.kind () == PROP_CONST)
11573     return (ULONGEST) high.const_val () + 1;
11574
11575   /* If TYPE is unresolved, the high bound might be a location list.  Return
11576      0, for lack of a better value to return.  */
11577   return 0;
11578 }
11579 \f
11580
11581 /* Ada exception catchpoint support:
11582    ---------------------------------
11583
11584    We support 3 kinds of exception catchpoints:
11585      . catchpoints on Ada exceptions
11586      . catchpoints on unhandled Ada exceptions
11587      . catchpoints on failed assertions
11588
11589    Exceptions raised during failed assertions, or unhandled exceptions
11590    could perfectly be caught with the general catchpoint on Ada exceptions.
11591    However, we can easily differentiate these two special cases, and having
11592    the option to distinguish these two cases from the rest can be useful
11593    to zero-in on certain situations.
11594
11595    Exception catchpoints are a specialized form of breakpoint,
11596    since they rely on inserting breakpoints inside known routines
11597    of the GNAT runtime.  The implementation therefore uses a standard
11598    breakpoint structure of the BP_BREAKPOINT type, but with its own set
11599    of breakpoint_ops.
11600
11601    Support in the runtime for exception catchpoints have been changed
11602    a few times already, and these changes affect the implementation
11603    of these catchpoints.  In order to be able to support several
11604    variants of the runtime, we use a sniffer that will determine
11605    the runtime variant used by the program being debugged.  */
11606
11607 /* Ada's standard exceptions.
11608
11609    The Ada 83 standard also defined Numeric_Error.  But there so many
11610    situations where it was unclear from the Ada 83 Reference Manual
11611    (RM) whether Constraint_Error or Numeric_Error should be raised,
11612    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11613    Interpretation saying that anytime the RM says that Numeric_Error
11614    should be raised, the implementation may raise Constraint_Error.
11615    Ada 95 went one step further and pretty much removed Numeric_Error
11616    from the list of standard exceptions (it made it a renaming of
11617    Constraint_Error, to help preserve compatibility when compiling
11618    an Ada83 compiler). As such, we do not include Numeric_Error from
11619    this list of standard exceptions.  */
11620
11621 static const char * const standard_exc[] = {
11622   "constraint_error",
11623   "program_error",
11624   "storage_error",
11625   "tasking_error"
11626 };
11627
11628 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11629
11630 /* A structure that describes how to support exception catchpoints
11631    for a given executable.  */
11632
11633 struct exception_support_info
11634 {
11635    /* The name of the symbol to break on in order to insert
11636       a catchpoint on exceptions.  */
11637    const char *catch_exception_sym;
11638
11639    /* The name of the symbol to break on in order to insert
11640       a catchpoint on unhandled exceptions.  */
11641    const char *catch_exception_unhandled_sym;
11642
11643    /* The name of the symbol to break on in order to insert
11644       a catchpoint on failed assertions.  */
11645    const char *catch_assert_sym;
11646
11647    /* The name of the symbol to break on in order to insert
11648       a catchpoint on exception handling.  */
11649    const char *catch_handlers_sym;
11650
11651    /* Assuming that the inferior just triggered an unhandled exception
11652       catchpoint, this function is responsible for returning the address
11653       in inferior memory where the name of that exception is stored.
11654       Return zero if the address could not be computed.  */
11655    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11656 };
11657
11658 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11659 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11660
11661 /* The following exception support info structure describes how to
11662    implement exception catchpoints with the latest version of the
11663    Ada runtime (as of 2019-08-??).  */
11664
11665 static const struct exception_support_info default_exception_support_info =
11666 {
11667   "__gnat_debug_raise_exception", /* catch_exception_sym */
11668   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11669   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11670   "__gnat_begin_handler_v1", /* catch_handlers_sym */
11671   ada_unhandled_exception_name_addr
11672 };
11673
11674 /* The following exception support info structure describes how to
11675    implement exception catchpoints with an earlier version of the
11676    Ada runtime (as of 2007-03-06) using v0 of the EH ABI.  */
11677
11678 static const struct exception_support_info exception_support_info_v0 =
11679 {
11680   "__gnat_debug_raise_exception", /* catch_exception_sym */
11681   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11682   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11683   "__gnat_begin_handler", /* catch_handlers_sym */
11684   ada_unhandled_exception_name_addr
11685 };
11686
11687 /* The following exception support info structure describes how to
11688    implement exception catchpoints with a slightly older version
11689    of the Ada runtime.  */
11690
11691 static const struct exception_support_info exception_support_info_fallback =
11692 {
11693   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11694   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11695   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
11696   "__gnat_begin_handler", /* catch_handlers_sym */
11697   ada_unhandled_exception_name_addr_from_raise
11698 };
11699
11700 /* Return nonzero if we can detect the exception support routines
11701    described in EINFO.
11702
11703    This function errors out if an abnormal situation is detected
11704    (for instance, if we find the exception support routines, but
11705    that support is found to be incomplete).  */
11706
11707 static int
11708 ada_has_this_exception_support (const struct exception_support_info *einfo)
11709 {
11710   struct symbol *sym;
11711
11712   /* The symbol we're looking up is provided by a unit in the GNAT runtime
11713      that should be compiled with debugging information.  As a result, we
11714      expect to find that symbol in the symtabs.  */
11715
11716   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11717   if (sym == NULL)
11718     {
11719       /* Perhaps we did not find our symbol because the Ada runtime was
11720          compiled without debugging info, or simply stripped of it.
11721          It happens on some GNU/Linux distributions for instance, where
11722          users have to install a separate debug package in order to get
11723          the runtime's debugging info.  In that situation, let the user
11724          know why we cannot insert an Ada exception catchpoint.
11725
11726          Note: Just for the purpose of inserting our Ada exception
11727          catchpoint, we could rely purely on the associated minimal symbol.
11728          But we would be operating in degraded mode anyway, since we are
11729          still lacking the debugging info needed later on to extract
11730          the name of the exception being raised (this name is printed in
11731          the catchpoint message, and is also used when trying to catch
11732          a specific exception).  We do not handle this case for now.  */
11733       struct bound_minimal_symbol msym
11734         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11735
11736       if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11737         error (_("Your Ada runtime appears to be missing some debugging "
11738                  "information.\nCannot insert Ada exception catchpoint "
11739                  "in this configuration."));
11740
11741       return 0;
11742     }
11743
11744   /* Make sure that the symbol we found corresponds to a function.  */
11745
11746   if (sym->aclass () != LOC_BLOCK)
11747     {
11748       error (_("Symbol \"%s\" is not a function (class = %d)"),
11749              sym->linkage_name (), sym->aclass ());
11750       return 0;
11751     }
11752
11753   sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11754   if (sym == NULL)
11755     {
11756       struct bound_minimal_symbol msym
11757         = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11758
11759       if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11760         error (_("Your Ada runtime appears to be missing some debugging "
11761                  "information.\nCannot insert Ada exception catchpoint "
11762                  "in this configuration."));
11763
11764       return 0;
11765     }
11766
11767   /* Make sure that the symbol we found corresponds to a function.  */
11768
11769   if (sym->aclass () != LOC_BLOCK)
11770     {
11771       error (_("Symbol \"%s\" is not a function (class = %d)"),
11772              sym->linkage_name (), sym->aclass ());
11773       return 0;
11774     }
11775
11776   return 1;
11777 }
11778
11779 /* Inspect the Ada runtime and determine which exception info structure
11780    should be used to provide support for exception catchpoints.
11781
11782    This function will always set the per-inferior exception_info,
11783    or raise an error.  */
11784
11785 static void
11786 ada_exception_support_info_sniffer (void)
11787 {
11788   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11789
11790   /* If the exception info is already known, then no need to recompute it.  */
11791   if (data->exception_info != NULL)
11792     return;
11793
11794   /* Check the latest (default) exception support info.  */
11795   if (ada_has_this_exception_support (&default_exception_support_info))
11796     {
11797       data->exception_info = &default_exception_support_info;
11798       return;
11799     }
11800
11801   /* Try the v0 exception suport info.  */
11802   if (ada_has_this_exception_support (&exception_support_info_v0))
11803     {
11804       data->exception_info = &exception_support_info_v0;
11805       return;
11806     }
11807
11808   /* Try our fallback exception suport info.  */
11809   if (ada_has_this_exception_support (&exception_support_info_fallback))
11810     {
11811       data->exception_info = &exception_support_info_fallback;
11812       return;
11813     }
11814
11815   /* Sometimes, it is normal for us to not be able to find the routine
11816      we are looking for.  This happens when the program is linked with
11817      the shared version of the GNAT runtime, and the program has not been
11818      started yet.  Inform the user of these two possible causes if
11819      applicable.  */
11820
11821   if (ada_update_initial_language (language_unknown) != language_ada)
11822     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
11823
11824   /* If the symbol does not exist, then check that the program is
11825      already started, to make sure that shared libraries have been
11826      loaded.  If it is not started, this may mean that the symbol is
11827      in a shared library.  */
11828
11829   if (inferior_ptid.pid () == 0)
11830     error (_("Unable to insert catchpoint. Try to start the program first."));
11831
11832   /* At this point, we know that we are debugging an Ada program and
11833      that the inferior has been started, but we still are not able to
11834      find the run-time symbols.  That can mean that we are in
11835      configurable run time mode, or that a-except as been optimized
11836      out by the linker...  In any case, at this point it is not worth
11837      supporting this feature.  */
11838
11839   error (_("Cannot insert Ada exception catchpoints in this configuration."));
11840 }
11841
11842 /* True iff FRAME is very likely to be that of a function that is
11843    part of the runtime system.  This is all very heuristic, but is
11844    intended to be used as advice as to what frames are uninteresting
11845    to most users.  */
11846
11847 static int
11848 is_known_support_routine (frame_info_ptr frame)
11849 {
11850   enum language func_lang;
11851   int i;
11852   const char *fullname;
11853
11854   /* If this code does not have any debugging information (no symtab),
11855      This cannot be any user code.  */
11856
11857   symtab_and_line sal = find_frame_sal (frame);
11858   if (sal.symtab == NULL)
11859     return 1;
11860
11861   /* If there is a symtab, but the associated source file cannot be
11862      located, then assume this is not user code:  Selecting a frame
11863      for which we cannot display the code would not be very helpful
11864      for the user.  This should also take care of case such as VxWorks
11865      where the kernel has some debugging info provided for a few units.  */
11866
11867   fullname = symtab_to_fullname (sal.symtab);
11868   if (access (fullname, R_OK) != 0)
11869     return 1;
11870
11871   /* Check the unit filename against the Ada runtime file naming.
11872      We also check the name of the objfile against the name of some
11873      known system libraries that sometimes come with debugging info
11874      too.  */
11875
11876   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11877     {
11878       re_comp (known_runtime_file_name_patterns[i]);
11879       if (re_exec (lbasename (sal.symtab->filename)))
11880         return 1;
11881       if (sal.symtab->compunit ()->objfile () != NULL
11882           && re_exec (objfile_name (sal.symtab->compunit ()->objfile ())))
11883         return 1;
11884     }
11885
11886   /* Check whether the function is a GNAT-generated entity.  */
11887
11888   gdb::unique_xmalloc_ptr<char> func_name
11889     = find_frame_funname (frame, &func_lang, NULL);
11890   if (func_name == NULL)
11891     return 1;
11892
11893   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11894     {
11895       re_comp (known_auxiliary_function_name_patterns[i]);
11896       if (re_exec (func_name.get ()))
11897         return 1;
11898     }
11899
11900   return 0;
11901 }
11902
11903 /* Find the first frame that contains debugging information and that is not
11904    part of the Ada run-time, starting from FI and moving upward.  */
11905
11906 void
11907 ada_find_printable_frame (frame_info_ptr fi)
11908 {
11909   for (; fi != NULL; fi = get_prev_frame (fi))
11910     {
11911       if (!is_known_support_routine (fi))
11912         {
11913           select_frame (fi);
11914           break;
11915         }
11916     }
11917
11918 }
11919
11920 /* Assuming that the inferior just triggered an unhandled exception
11921    catchpoint, return the address in inferior memory where the name
11922    of the exception is stored.
11923    
11924    Return zero if the address could not be computed.  */
11925
11926 static CORE_ADDR
11927 ada_unhandled_exception_name_addr (void)
11928 {
11929   return parse_and_eval_address ("e.full_name");
11930 }
11931
11932 /* Same as ada_unhandled_exception_name_addr, except that this function
11933    should be used when the inferior uses an older version of the runtime,
11934    where the exception name needs to be extracted from a specific frame
11935    several frames up in the callstack.  */
11936
11937 static CORE_ADDR
11938 ada_unhandled_exception_name_addr_from_raise (void)
11939 {
11940   int frame_level;
11941   frame_info_ptr fi;
11942   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11943
11944   /* To determine the name of this exception, we need to select
11945      the frame corresponding to RAISE_SYM_NAME.  This frame is
11946      at least 3 levels up, so we simply skip the first 3 frames
11947      without checking the name of their associated function.  */
11948   fi = get_current_frame ();
11949   for (frame_level = 0; frame_level < 3; frame_level += 1)
11950     if (fi != NULL)
11951       fi = get_prev_frame (fi); 
11952
11953   while (fi != NULL)
11954     {
11955       enum language func_lang;
11956
11957       gdb::unique_xmalloc_ptr<char> func_name
11958         = find_frame_funname (fi, &func_lang, NULL);
11959       if (func_name != NULL)
11960         {
11961           if (strcmp (func_name.get (),
11962                       data->exception_info->catch_exception_sym) == 0)
11963             break; /* We found the frame we were looking for...  */
11964         }
11965       fi = get_prev_frame (fi);
11966     }
11967
11968   if (fi == NULL)
11969     return 0;
11970
11971   select_frame (fi);
11972   return parse_and_eval_address ("id.full_name");
11973 }
11974
11975 /* Assuming the inferior just triggered an Ada exception catchpoint
11976    (of any type), return the address in inferior memory where the name
11977    of the exception is stored, if applicable.
11978
11979    Assumes the selected frame is the current frame.
11980
11981    Return zero if the address could not be computed, or if not relevant.  */
11982
11983 static CORE_ADDR
11984 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex)
11985 {
11986   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11987
11988   switch (ex)
11989     {
11990       case ada_catch_exception:
11991         return (parse_and_eval_address ("e.full_name"));
11992         break;
11993
11994       case ada_catch_exception_unhandled:
11995         return data->exception_info->unhandled_exception_name_addr ();
11996         break;
11997
11998       case ada_catch_handlers:
11999         return 0;  /* The runtimes does not provide access to the exception
12000                       name.  */
12001         break;
12002
12003       case ada_catch_assert:
12004         return 0;  /* Exception name is not relevant in this case.  */
12005         break;
12006
12007       default:
12008         internal_error (_("unexpected catchpoint type"));
12009         break;
12010     }
12011
12012   return 0; /* Should never be reached.  */
12013 }
12014
12015 /* Assuming the inferior is stopped at an exception catchpoint,
12016    return the message which was associated to the exception, if
12017    available.  Return NULL if the message could not be retrieved.
12018
12019    Note: The exception message can be associated to an exception
12020    either through the use of the Raise_Exception function, or
12021    more simply (Ada 2005 and later), via:
12022
12023        raise Exception_Name with "exception message";
12024
12025    */
12026
12027 static gdb::unique_xmalloc_ptr<char>
12028 ada_exception_message_1 (void)
12029 {
12030   struct value *e_msg_val;
12031   int e_msg_len;
12032
12033   /* For runtimes that support this feature, the exception message
12034      is passed as an unbounded string argument called "message".  */
12035   e_msg_val = parse_and_eval ("message");
12036   if (e_msg_val == NULL)
12037     return NULL; /* Exception message not supported.  */
12038
12039   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12040   gdb_assert (e_msg_val != NULL);
12041   e_msg_len = value_type (e_msg_val)->length ();
12042
12043   /* If the message string is empty, then treat it as if there was
12044      no exception message.  */
12045   if (e_msg_len <= 0)
12046     return NULL;
12047
12048   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12049   read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
12050                e_msg_len);
12051   e_msg.get ()[e_msg_len] = '\0';
12052
12053   return e_msg;
12054 }
12055
12056 /* Same as ada_exception_message_1, except that all exceptions are
12057    contained here (returning NULL instead).  */
12058
12059 static gdb::unique_xmalloc_ptr<char>
12060 ada_exception_message (void)
12061 {
12062   gdb::unique_xmalloc_ptr<char> e_msg;
12063
12064   try
12065     {
12066       e_msg = ada_exception_message_1 ();
12067     }
12068   catch (const gdb_exception_error &e)
12069     {
12070       e_msg.reset (nullptr);
12071     }
12072
12073   return e_msg;
12074 }
12075
12076 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12077    any error that ada_exception_name_addr_1 might cause to be thrown.
12078    When an error is intercepted, a warning with the error message is printed,
12079    and zero is returned.  */
12080
12081 static CORE_ADDR
12082 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex)
12083 {
12084   CORE_ADDR result = 0;
12085
12086   try
12087     {
12088       result = ada_exception_name_addr_1 (ex);
12089     }
12090
12091   catch (const gdb_exception_error &e)
12092     {
12093       warning (_("failed to get exception name: %s"), e.what ());
12094       return 0;
12095     }
12096
12097   return result;
12098 }
12099
12100 static std::string ada_exception_catchpoint_cond_string
12101   (const char *excep_string,
12102    enum ada_exception_catchpoint_kind ex);
12103
12104 /* Ada catchpoints.
12105
12106    In the case of catchpoints on Ada exceptions, the catchpoint will
12107    stop the target on every exception the program throws.  When a user
12108    specifies the name of a specific exception, we translate this
12109    request into a condition expression (in text form), and then parse
12110    it into an expression stored in each of the catchpoint's locations.
12111    We then use this condition to check whether the exception that was
12112    raised is the one the user is interested in.  If not, then the
12113    target is resumed again.  We store the name of the requested
12114    exception, in order to be able to re-set the condition expression
12115    when symbols change.  */
12116
12117 /* An instance of this type is used to represent an Ada catchpoint.  */
12118
12119 struct ada_catchpoint : public code_breakpoint
12120 {
12121   ada_catchpoint (struct gdbarch *gdbarch_,
12122                   enum ada_exception_catchpoint_kind kind,
12123                   struct symtab_and_line sal,
12124                   const char *addr_string_,
12125                   bool tempflag,
12126                   bool enabled,
12127                   bool from_tty)
12128     : code_breakpoint (gdbarch_, bp_catchpoint),
12129       m_kind (kind)
12130   {
12131     add_location (sal);
12132
12133     /* Unlike most code_breakpoint types, Ada catchpoints are
12134        pspace-specific.  */
12135     gdb_assert (sal.pspace != nullptr);
12136     this->pspace = sal.pspace;
12137
12138     if (from_tty)
12139       {
12140         struct gdbarch *loc_gdbarch = get_sal_arch (sal);
12141         if (!loc_gdbarch)
12142           loc_gdbarch = gdbarch;
12143
12144         describe_other_breakpoints (loc_gdbarch,
12145                                     sal.pspace, sal.pc, sal.section, -1);
12146         /* FIXME: brobecker/2006-12-28: Actually, re-implement a special
12147            version for exception catchpoints, because two catchpoints
12148            used for different exception names will use the same address.
12149            In this case, a "breakpoint ... also set at..." warning is
12150            unproductive.  Besides, the warning phrasing is also a bit
12151            inappropriate, we should use the word catchpoint, and tell
12152            the user what type of catchpoint it is.  The above is good
12153            enough for now, though.  */
12154       }
12155
12156     enable_state = enabled ? bp_enabled : bp_disabled;
12157     disposition = tempflag ? disp_del : disp_donttouch;
12158     locspec = string_to_location_spec (&addr_string_,
12159                                        language_def (language_ada));
12160     language = language_ada;
12161   }
12162
12163   struct bp_location *allocate_location () override;
12164   void re_set () override;
12165   void check_status (struct bpstat *bs) override;
12166   enum print_stop_action print_it (const bpstat *bs) const override;
12167   bool print_one (bp_location **) const override;
12168   void print_mention () const override;
12169   void print_recreate (struct ui_file *fp) const override;
12170
12171   /* The name of the specific exception the user specified.  */
12172   std::string excep_string;
12173
12174   /* What kind of catchpoint this is.  */
12175   enum ada_exception_catchpoint_kind m_kind;
12176 };
12177
12178 /* An instance of this type is used to represent an Ada catchpoint
12179    breakpoint location.  */
12180
12181 class ada_catchpoint_location : public bp_location
12182 {
12183 public:
12184   explicit ada_catchpoint_location (ada_catchpoint *owner)
12185     : bp_location (owner, bp_loc_software_breakpoint)
12186   {}
12187
12188   /* The condition that checks whether the exception that was raised
12189      is the specific exception the user specified on catchpoint
12190      creation.  */
12191   expression_up excep_cond_expr;
12192 };
12193
12194 /* Parse the exception condition string in the context of each of the
12195    catchpoint's locations, and store them for later evaluation.  */
12196
12197 static void
12198 create_excep_cond_exprs (struct ada_catchpoint *c,
12199                          enum ada_exception_catchpoint_kind ex)
12200 {
12201   /* Nothing to do if there's no specific exception to catch.  */
12202   if (c->excep_string.empty ())
12203     return;
12204
12205   /* Same if there are no locations... */
12206   if (c->loc == NULL)
12207     return;
12208
12209   /* Compute the condition expression in text form, from the specific
12210      expection we want to catch.  */
12211   std::string cond_string
12212     = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
12213
12214   /* Iterate over all the catchpoint's locations, and parse an
12215      expression for each.  */
12216   for (bp_location *bl : c->locations ())
12217     {
12218       struct ada_catchpoint_location *ada_loc
12219         = (struct ada_catchpoint_location *) bl;
12220       expression_up exp;
12221
12222       if (!bl->shlib_disabled)
12223         {
12224           const char *s;
12225
12226           s = cond_string.c_str ();
12227           try
12228             {
12229               exp = parse_exp_1 (&s, bl->address,
12230                                  block_for_pc (bl->address),
12231                                  0);
12232             }
12233           catch (const gdb_exception_error &e)
12234             {
12235               warning (_("failed to reevaluate internal exception condition "
12236                          "for catchpoint %d: %s"),
12237                        c->number, e.what ());
12238             }
12239         }
12240
12241       ada_loc->excep_cond_expr = std::move (exp);
12242     }
12243 }
12244
12245 /* Implement the ALLOCATE_LOCATION method in the structure for all
12246    exception catchpoint kinds.  */
12247
12248 struct bp_location *
12249 ada_catchpoint::allocate_location ()
12250 {
12251   return new ada_catchpoint_location (this);
12252 }
12253
12254 /* Implement the RE_SET method in the structure for all exception
12255    catchpoint kinds.  */
12256
12257 void
12258 ada_catchpoint::re_set ()
12259 {
12260   /* Call the base class's method.  This updates the catchpoint's
12261      locations.  */
12262   this->code_breakpoint::re_set ();
12263
12264   /* Reparse the exception conditional expressions.  One for each
12265      location.  */
12266   create_excep_cond_exprs (this, m_kind);
12267 }
12268
12269 /* Returns true if we should stop for this breakpoint hit.  If the
12270    user specified a specific exception, we only want to cause a stop
12271    if the program thrown that exception.  */
12272
12273 static bool
12274 should_stop_exception (const struct bp_location *bl)
12275 {
12276   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12277   const struct ada_catchpoint_location *ada_loc
12278     = (const struct ada_catchpoint_location *) bl;
12279   bool stop;
12280
12281   struct internalvar *var = lookup_internalvar ("_ada_exception");
12282   if (c->m_kind == ada_catch_assert)
12283     clear_internalvar (var);
12284   else
12285     {
12286       try
12287         {
12288           const char *expr;
12289
12290           if (c->m_kind == ada_catch_handlers)
12291             expr = ("GNAT_GCC_exception_Access(gcc_exception)"
12292                     ".all.occurrence.id");
12293           else
12294             expr = "e";
12295
12296           struct value *exc = parse_and_eval (expr);
12297           set_internalvar (var, exc);
12298         }
12299       catch (const gdb_exception_error &ex)
12300         {
12301           clear_internalvar (var);
12302         }
12303     }
12304
12305   /* With no specific exception, should always stop.  */
12306   if (c->excep_string.empty ())
12307     return true;
12308
12309   if (ada_loc->excep_cond_expr == NULL)
12310     {
12311       /* We will have a NULL expression if back when we were creating
12312          the expressions, this location's had failed to parse.  */
12313       return true;
12314     }
12315
12316   stop = true;
12317   try
12318     {
12319       scoped_value_mark mark;
12320       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12321     }
12322   catch (const gdb_exception &ex)
12323     {
12324       exception_fprintf (gdb_stderr, ex,
12325                          _("Error in testing exception condition:\n"));
12326     }
12327
12328   return stop;
12329 }
12330
12331 /* Implement the CHECK_STATUS method in the structure for all
12332    exception catchpoint kinds.  */
12333
12334 void
12335 ada_catchpoint::check_status (bpstat *bs)
12336 {
12337   bs->stop = should_stop_exception (bs->bp_location_at.get ());
12338 }
12339
12340 /* Implement the PRINT_IT method in the structure for all exception
12341    catchpoint kinds.  */
12342
12343 enum print_stop_action
12344 ada_catchpoint::print_it (const bpstat *bs) const
12345 {
12346   struct ui_out *uiout = current_uiout;
12347
12348   annotate_catchpoint (number);
12349
12350   if (uiout->is_mi_like_p ())
12351     {
12352       uiout->field_string ("reason",
12353                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12354       uiout->field_string ("disp", bpdisp_text (disposition));
12355     }
12356
12357   uiout->text (disposition == disp_del
12358                ? "\nTemporary catchpoint " : "\nCatchpoint ");
12359   uiout->field_signed ("bkptno", number);
12360   uiout->text (", ");
12361
12362   /* ada_exception_name_addr relies on the selected frame being the
12363      current frame.  Need to do this here because this function may be
12364      called more than once when printing a stop, and below, we'll
12365      select the first frame past the Ada run-time (see
12366      ada_find_printable_frame).  */
12367   select_frame (get_current_frame ());
12368
12369   switch (m_kind)
12370     {
12371       case ada_catch_exception:
12372       case ada_catch_exception_unhandled:
12373       case ada_catch_handlers:
12374         {
12375           const CORE_ADDR addr = ada_exception_name_addr (m_kind);
12376           char exception_name[256];
12377
12378           if (addr != 0)
12379             {
12380               read_memory (addr, (gdb_byte *) exception_name,
12381                            sizeof (exception_name) - 1);
12382               exception_name [sizeof (exception_name) - 1] = '\0';
12383             }
12384           else
12385             {
12386               /* For some reason, we were unable to read the exception
12387                  name.  This could happen if the Runtime was compiled
12388                  without debugging info, for instance.  In that case,
12389                  just replace the exception name by the generic string
12390                  "exception" - it will read as "an exception" in the
12391                  notification we are about to print.  */
12392               memcpy (exception_name, "exception", sizeof ("exception"));
12393             }
12394           /* In the case of unhandled exception breakpoints, we print
12395              the exception name as "unhandled EXCEPTION_NAME", to make
12396              it clearer to the user which kind of catchpoint just got
12397              hit.  We used ui_out_text to make sure that this extra
12398              info does not pollute the exception name in the MI case.  */
12399           if (m_kind == ada_catch_exception_unhandled)
12400             uiout->text ("unhandled ");
12401           uiout->field_string ("exception-name", exception_name);
12402         }
12403         break;
12404       case ada_catch_assert:
12405         /* In this case, the name of the exception is not really
12406            important.  Just print "failed assertion" to make it clearer
12407            that his program just hit an assertion-failure catchpoint.
12408            We used ui_out_text because this info does not belong in
12409            the MI output.  */
12410         uiout->text ("failed assertion");
12411         break;
12412     }
12413
12414   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12415   if (exception_message != NULL)
12416     {
12417       uiout->text (" (");
12418       uiout->field_string ("exception-message", exception_message.get ());
12419       uiout->text (")");
12420     }
12421
12422   uiout->text (" at ");
12423   ada_find_printable_frame (get_current_frame ());
12424
12425   return PRINT_SRC_AND_LOC;
12426 }
12427
12428 /* Implement the PRINT_ONE method in the structure for all exception
12429    catchpoint kinds.  */
12430
12431 bool
12432 ada_catchpoint::print_one (bp_location **last_loc) const
12433
12434   struct ui_out *uiout = current_uiout;
12435   struct value_print_options opts;
12436
12437   get_user_print_options (&opts);
12438
12439   if (opts.addressprint)
12440     uiout->field_skip ("addr");
12441
12442   annotate_field (5);
12443   switch (m_kind)
12444     {
12445       case ada_catch_exception:
12446         if (!excep_string.empty ())
12447           {
12448             std::string msg = string_printf (_("`%s' Ada exception"),
12449                                              excep_string.c_str ());
12450
12451             uiout->field_string ("what", msg);
12452           }
12453         else
12454           uiout->field_string ("what", "all Ada exceptions");
12455         
12456         break;
12457
12458       case ada_catch_exception_unhandled:
12459         uiout->field_string ("what", "unhandled Ada exceptions");
12460         break;
12461       
12462       case ada_catch_handlers:
12463         if (!excep_string.empty ())
12464           {
12465             uiout->field_fmt ("what",
12466                               _("`%s' Ada exception handlers"),
12467                               excep_string.c_str ());
12468           }
12469         else
12470           uiout->field_string ("what", "all Ada exceptions handlers");
12471         break;
12472
12473       case ada_catch_assert:
12474         uiout->field_string ("what", "failed Ada assertions");
12475         break;
12476
12477       default:
12478         internal_error (_("unexpected catchpoint type"));
12479         break;
12480     }
12481
12482   return true;
12483 }
12484
12485 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12486    for all exception catchpoint kinds.  */
12487
12488 void
12489 ada_catchpoint::print_mention () const
12490 {
12491   struct ui_out *uiout = current_uiout;
12492
12493   uiout->text (disposition == disp_del ? _("Temporary catchpoint ")
12494                                                  : _("Catchpoint "));
12495   uiout->field_signed ("bkptno", number);
12496   uiout->text (": ");
12497
12498   switch (m_kind)
12499     {
12500       case ada_catch_exception:
12501         if (!excep_string.empty ())
12502           {
12503             std::string info = string_printf (_("`%s' Ada exception"),
12504                                               excep_string.c_str ());
12505             uiout->text (info);
12506           }
12507         else
12508           uiout->text (_("all Ada exceptions"));
12509         break;
12510
12511       case ada_catch_exception_unhandled:
12512         uiout->text (_("unhandled Ada exceptions"));
12513         break;
12514
12515       case ada_catch_handlers:
12516         if (!excep_string.empty ())
12517           {
12518             std::string info
12519               = string_printf (_("`%s' Ada exception handlers"),
12520                                excep_string.c_str ());
12521             uiout->text (info);
12522           }
12523         else
12524           uiout->text (_("all Ada exceptions handlers"));
12525         break;
12526
12527       case ada_catch_assert:
12528         uiout->text (_("failed Ada assertions"));
12529         break;
12530
12531       default:
12532         internal_error (_("unexpected catchpoint type"));
12533         break;
12534     }
12535 }
12536
12537 /* Implement the PRINT_RECREATE method in the structure for all
12538    exception catchpoint kinds.  */
12539
12540 void
12541 ada_catchpoint::print_recreate (struct ui_file *fp) const
12542 {
12543   switch (m_kind)
12544     {
12545       case ada_catch_exception:
12546         gdb_printf (fp, "catch exception");
12547         if (!excep_string.empty ())
12548           gdb_printf (fp, " %s", excep_string.c_str ());
12549         break;
12550
12551       case ada_catch_exception_unhandled:
12552         gdb_printf (fp, "catch exception unhandled");
12553         break;
12554
12555       case ada_catch_handlers:
12556         gdb_printf (fp, "catch handlers");
12557         break;
12558
12559       case ada_catch_assert:
12560         gdb_printf (fp, "catch assert");
12561         break;
12562
12563       default:
12564         internal_error (_("unexpected catchpoint type"));
12565     }
12566   print_recreate_thread (fp);
12567 }
12568
12569 /* See ada-lang.h.  */
12570
12571 bool
12572 is_ada_exception_catchpoint (breakpoint *bp)
12573 {
12574   return dynamic_cast<ada_catchpoint *> (bp) != nullptr;
12575 }
12576
12577 /* Split the arguments specified in a "catch exception" command.  
12578    Set EX to the appropriate catchpoint type.
12579    Set EXCEP_STRING to the name of the specific exception if
12580    specified by the user.
12581    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12582    "catch handlers" command.  False otherwise.
12583    If a condition is found at the end of the arguments, the condition
12584    expression is stored in COND_STRING (memory must be deallocated
12585    after use).  Otherwise COND_STRING is set to NULL.  */
12586
12587 static void
12588 catch_ada_exception_command_split (const char *args,
12589                                    bool is_catch_handlers_cmd,
12590                                    enum ada_exception_catchpoint_kind *ex,
12591                                    std::string *excep_string,
12592                                    std::string *cond_string)
12593 {
12594   std::string exception_name;
12595
12596   exception_name = extract_arg (&args);
12597   if (exception_name == "if")
12598     {
12599       /* This is not an exception name; this is the start of a condition
12600          expression for a catchpoint on all exceptions.  So, "un-get"
12601          this token, and set exception_name to NULL.  */
12602       exception_name.clear ();
12603       args -= 2;
12604     }
12605
12606   /* Check to see if we have a condition.  */
12607
12608   args = skip_spaces (args);
12609   if (startswith (args, "if")
12610       && (isspace (args[2]) || args[2] == '\0'))
12611     {
12612       args += 2;
12613       args = skip_spaces (args);
12614
12615       if (args[0] == '\0')
12616         error (_("Condition missing after `if' keyword"));
12617       *cond_string = args;
12618
12619       args += strlen (args);
12620     }
12621
12622   /* Check that we do not have any more arguments.  Anything else
12623      is unexpected.  */
12624
12625   if (args[0] != '\0')
12626     error (_("Junk at end of expression"));
12627
12628   if (is_catch_handlers_cmd)
12629     {
12630       /* Catch handling of exceptions.  */
12631       *ex = ada_catch_handlers;
12632       *excep_string = exception_name;
12633     }
12634   else if (exception_name.empty ())
12635     {
12636       /* Catch all exceptions.  */
12637       *ex = ada_catch_exception;
12638       excep_string->clear ();
12639     }
12640   else if (exception_name == "unhandled")
12641     {
12642       /* Catch unhandled exceptions.  */
12643       *ex = ada_catch_exception_unhandled;
12644       excep_string->clear ();
12645     }
12646   else
12647     {
12648       /* Catch a specific exception.  */
12649       *ex = ada_catch_exception;
12650       *excep_string = exception_name;
12651     }
12652 }
12653
12654 /* Return the name of the symbol on which we should break in order to
12655    implement a catchpoint of the EX kind.  */
12656
12657 static const char *
12658 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12659 {
12660   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12661
12662   gdb_assert (data->exception_info != NULL);
12663
12664   switch (ex)
12665     {
12666       case ada_catch_exception:
12667         return (data->exception_info->catch_exception_sym);
12668         break;
12669       case ada_catch_exception_unhandled:
12670         return (data->exception_info->catch_exception_unhandled_sym);
12671         break;
12672       case ada_catch_assert:
12673         return (data->exception_info->catch_assert_sym);
12674         break;
12675       case ada_catch_handlers:
12676         return (data->exception_info->catch_handlers_sym);
12677         break;
12678       default:
12679         internal_error (_("unexpected catchpoint kind (%d)"), ex);
12680     }
12681 }
12682
12683 /* Return the condition that will be used to match the current exception
12684    being raised with the exception that the user wants to catch.  This
12685    assumes that this condition is used when the inferior just triggered
12686    an exception catchpoint.
12687    EX: the type of catchpoints used for catching Ada exceptions.  */
12688
12689 static std::string
12690 ada_exception_catchpoint_cond_string (const char *excep_string,
12691                                       enum ada_exception_catchpoint_kind ex)
12692 {
12693   bool is_standard_exc = false;
12694   std::string result;
12695
12696   if (ex == ada_catch_handlers)
12697     {
12698       /* For exception handlers catchpoints, the condition string does
12699          not use the same parameter as for the other exceptions.  */
12700       result = ("long_integer (GNAT_GCC_exception_Access"
12701                 "(gcc_exception).all.occurrence.id)");
12702     }
12703   else
12704     result = "long_integer (e)";
12705
12706   /* The standard exceptions are a special case.  They are defined in
12707      runtime units that have been compiled without debugging info; if
12708      EXCEP_STRING is the not-fully-qualified name of a standard
12709      exception (e.g. "constraint_error") then, during the evaluation
12710      of the condition expression, the symbol lookup on this name would
12711      *not* return this standard exception.  The catchpoint condition
12712      may then be set only on user-defined exceptions which have the
12713      same not-fully-qualified name (e.g. my_package.constraint_error).
12714
12715      To avoid this unexcepted behavior, these standard exceptions are
12716      systematically prefixed by "standard".  This means that "catch
12717      exception constraint_error" is rewritten into "catch exception
12718      standard.constraint_error".
12719
12720      If an exception named constraint_error is defined in another package of
12721      the inferior program, then the only way to specify this exception as a
12722      breakpoint condition is to use its fully-qualified named:
12723      e.g. my_package.constraint_error.  */
12724
12725   for (const char *name : standard_exc)
12726     {
12727       if (strcmp (name, excep_string) == 0)
12728         {
12729           is_standard_exc = true;
12730           break;
12731         }
12732     }
12733
12734   result += " = ";
12735
12736   if (is_standard_exc)
12737     string_appendf (result, "long_integer (&standard.%s)", excep_string);
12738   else
12739     string_appendf (result, "long_integer (&%s)", excep_string);
12740
12741   return result;
12742 }
12743
12744 /* Return the symtab_and_line that should be used to insert an exception
12745    catchpoint of the TYPE kind.
12746
12747    ADDR_STRING returns the name of the function where the real
12748    breakpoint that implements the catchpoints is set, depending on the
12749    type of catchpoint we need to create.  */
12750
12751 static struct symtab_and_line
12752 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12753                    std::string *addr_string)
12754 {
12755   const char *sym_name;
12756   struct symbol *sym;
12757
12758   /* First, find out which exception support info to use.  */
12759   ada_exception_support_info_sniffer ();
12760
12761   /* Then lookup the function on which we will break in order to catch
12762      the Ada exceptions requested by the user.  */
12763   sym_name = ada_exception_sym_name (ex);
12764   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12765
12766   if (sym == NULL)
12767     error (_("Catchpoint symbol not found: %s"), sym_name);
12768
12769   if (sym->aclass () != LOC_BLOCK)
12770     error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12771
12772   /* Set ADDR_STRING.  */
12773   *addr_string = sym_name;
12774
12775   return find_function_start_sal (sym, 1);
12776 }
12777
12778 /* Create an Ada exception catchpoint.
12779
12780    EX_KIND is the kind of exception catchpoint to be created.
12781
12782    If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12783    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
12784    of the exception to which this catchpoint applies.
12785
12786    COND_STRING, if not empty, is the catchpoint condition.
12787
12788    TEMPFLAG, if nonzero, means that the underlying breakpoint
12789    should be temporary.
12790
12791    FROM_TTY is the usual argument passed to all commands implementations.  */
12792
12793 void
12794 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12795                                  enum ada_exception_catchpoint_kind ex_kind,
12796                                  const std::string &excep_string,
12797                                  const std::string &cond_string,
12798                                  int tempflag,
12799                                  int disabled,
12800                                  int from_tty)
12801 {
12802   std::string addr_string;
12803   struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string);
12804
12805   std::unique_ptr<ada_catchpoint> c
12806     (new ada_catchpoint (gdbarch, ex_kind, sal, addr_string.c_str (),
12807                          tempflag, disabled, from_tty));
12808   c->excep_string = excep_string;
12809   create_excep_cond_exprs (c.get (), ex_kind);
12810   if (!cond_string.empty ())
12811     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12812   install_breakpoint (0, std::move (c), 1);
12813 }
12814
12815 /* Implement the "catch exception" command.  */
12816
12817 static void
12818 catch_ada_exception_command (const char *arg_entry, int from_tty,
12819                              struct cmd_list_element *command)
12820 {
12821   const char *arg = arg_entry;
12822   struct gdbarch *gdbarch = get_current_arch ();
12823   int tempflag;
12824   enum ada_exception_catchpoint_kind ex_kind;
12825   std::string excep_string;
12826   std::string cond_string;
12827
12828   tempflag = command->context () == CATCH_TEMPORARY;
12829
12830   if (!arg)
12831     arg = "";
12832   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12833                                      &cond_string);
12834   create_ada_exception_catchpoint (gdbarch, ex_kind,
12835                                    excep_string, cond_string,
12836                                    tempflag, 1 /* enabled */,
12837                                    from_tty);
12838 }
12839
12840 /* Implement the "catch handlers" command.  */
12841
12842 static void
12843 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12844                             struct cmd_list_element *command)
12845 {
12846   const char *arg = arg_entry;
12847   struct gdbarch *gdbarch = get_current_arch ();
12848   int tempflag;
12849   enum ada_exception_catchpoint_kind ex_kind;
12850   std::string excep_string;
12851   std::string cond_string;
12852
12853   tempflag = command->context () == CATCH_TEMPORARY;
12854
12855   if (!arg)
12856     arg = "";
12857   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12858                                      &cond_string);
12859   create_ada_exception_catchpoint (gdbarch, ex_kind,
12860                                    excep_string, cond_string,
12861                                    tempflag, 1 /* enabled */,
12862                                    from_tty);
12863 }
12864
12865 /* Completion function for the Ada "catch" commands.  */
12866
12867 static void
12868 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12869                      const char *text, const char *word)
12870 {
12871   std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12872
12873   for (const ada_exc_info &info : exceptions)
12874     {
12875       if (startswith (info.name, word))
12876         tracker.add_completion (make_unique_xstrdup (info.name));
12877     }
12878 }
12879
12880 /* Split the arguments specified in a "catch assert" command.
12881
12882    ARGS contains the command's arguments (or the empty string if
12883    no arguments were passed).
12884
12885    If ARGS contains a condition, set COND_STRING to that condition
12886    (the memory needs to be deallocated after use).  */
12887
12888 static void
12889 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12890 {
12891   args = skip_spaces (args);
12892
12893   /* Check whether a condition was provided.  */
12894   if (startswith (args, "if")
12895       && (isspace (args[2]) || args[2] == '\0'))
12896     {
12897       args += 2;
12898       args = skip_spaces (args);
12899       if (args[0] == '\0')
12900         error (_("condition missing after `if' keyword"));
12901       cond_string.assign (args);
12902     }
12903
12904   /* Otherwise, there should be no other argument at the end of
12905      the command.  */
12906   else if (args[0] != '\0')
12907     error (_("Junk at end of arguments."));
12908 }
12909
12910 /* Implement the "catch assert" command.  */
12911
12912 static void
12913 catch_assert_command (const char *arg_entry, int from_tty,
12914                       struct cmd_list_element *command)
12915 {
12916   const char *arg = arg_entry;
12917   struct gdbarch *gdbarch = get_current_arch ();
12918   int tempflag;
12919   std::string cond_string;
12920
12921   tempflag = command->context () == CATCH_TEMPORARY;
12922
12923   if (!arg)
12924     arg = "";
12925   catch_ada_assert_command_split (arg, cond_string);
12926   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12927                                    "", cond_string,
12928                                    tempflag, 1 /* enabled */,
12929                                    from_tty);
12930 }
12931
12932 /* Return non-zero if the symbol SYM is an Ada exception object.  */
12933
12934 static int
12935 ada_is_exception_sym (struct symbol *sym)
12936 {
12937   const char *type_name = sym->type ()->name ();
12938
12939   return (sym->aclass () != LOC_TYPEDEF
12940           && sym->aclass () != LOC_BLOCK
12941           && sym->aclass () != LOC_CONST
12942           && sym->aclass () != LOC_UNRESOLVED
12943           && type_name != NULL && strcmp (type_name, "exception") == 0);
12944 }
12945
12946 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12947    Ada exception object.  This matches all exceptions except the ones
12948    defined by the Ada language.  */
12949
12950 static int
12951 ada_is_non_standard_exception_sym (struct symbol *sym)
12952 {
12953   if (!ada_is_exception_sym (sym))
12954     return 0;
12955
12956   for (const char *name : standard_exc)
12957     if (strcmp (sym->linkage_name (), name) == 0)
12958       return 0;  /* A standard exception.  */
12959
12960   /* Numeric_Error is also a standard exception, so exclude it.
12961      See the STANDARD_EXC description for more details as to why
12962      this exception is not listed in that array.  */
12963   if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12964     return 0;
12965
12966   return 1;
12967 }
12968
12969 /* A helper function for std::sort, comparing two struct ada_exc_info
12970    objects.
12971
12972    The comparison is determined first by exception name, and then
12973    by exception address.  */
12974
12975 bool
12976 ada_exc_info::operator< (const ada_exc_info &other) const
12977 {
12978   int result;
12979
12980   result = strcmp (name, other.name);
12981   if (result < 0)
12982     return true;
12983   if (result == 0 && addr < other.addr)
12984     return true;
12985   return false;
12986 }
12987
12988 bool
12989 ada_exc_info::operator== (const ada_exc_info &other) const
12990 {
12991   return addr == other.addr && strcmp (name, other.name) == 0;
12992 }
12993
12994 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12995    routine, but keeping the first SKIP elements untouched.
12996
12997    All duplicates are also removed.  */
12998
12999 static void
13000 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
13001                                       int skip)
13002 {
13003   std::sort (exceptions->begin () + skip, exceptions->end ());
13004   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13005                      exceptions->end ());
13006 }
13007
13008 /* Add all exceptions defined by the Ada standard whose name match
13009    a regular expression.
13010
13011    If PREG is not NULL, then this regexp_t object is used to
13012    perform the symbol name matching.  Otherwise, no name-based
13013    filtering is performed.
13014
13015    EXCEPTIONS is a vector of exceptions to which matching exceptions
13016    gets pushed.  */
13017
13018 static void
13019 ada_add_standard_exceptions (compiled_regex *preg,
13020                              std::vector<ada_exc_info> *exceptions)
13021 {
13022   for (const char *name : standard_exc)
13023     {
13024       if (preg == NULL || preg->exec (name, 0, NULL, 0) == 0)
13025         {
13026           symbol_name_match_type match_type = name_match_type_from_name (name);
13027           lookup_name_info lookup_name (name, match_type);
13028
13029           symbol_name_matcher_ftype *match_name
13030             = ada_get_symbol_name_matcher (lookup_name);
13031
13032           /* Iterate over all objfiles irrespective of scope or linker
13033              namespaces so we get all exceptions anywhere in the
13034              progspace.  */
13035           for (objfile *objfile : current_program_space->objfiles ())
13036             {
13037               for (minimal_symbol *msymbol : objfile->msymbols ())
13038                 {
13039                   if (match_name (msymbol->linkage_name (), lookup_name,
13040                                   nullptr)
13041                       && msymbol->type () != mst_solib_trampoline)
13042                     {
13043                       ada_exc_info info
13044                         = {name, msymbol->value_address (objfile)};
13045
13046                       exceptions->push_back (info);
13047                     }
13048                 }
13049             }
13050         }
13051     }
13052 }
13053
13054 /* Add all Ada exceptions defined locally and accessible from the given
13055    FRAME.
13056
13057    If PREG is not NULL, then this regexp_t object is used to
13058    perform the symbol name matching.  Otherwise, no name-based
13059    filtering is performed.
13060
13061    EXCEPTIONS is a vector of exceptions to which matching exceptions
13062    gets pushed.  */
13063
13064 static void
13065 ada_add_exceptions_from_frame (compiled_regex *preg,
13066                                frame_info_ptr frame,
13067                                std::vector<ada_exc_info> *exceptions)
13068 {
13069   const struct block *block = get_frame_block (frame, 0);
13070
13071   while (block != 0)
13072     {
13073       struct block_iterator iter;
13074       struct symbol *sym;
13075
13076       ALL_BLOCK_SYMBOLS (block, iter, sym)
13077         {
13078           switch (sym->aclass ())
13079             {
13080             case LOC_TYPEDEF:
13081             case LOC_BLOCK:
13082             case LOC_CONST:
13083               break;
13084             default:
13085               if (ada_is_exception_sym (sym))
13086                 {
13087                   struct ada_exc_info info = {sym->print_name (),
13088                                               sym->value_address ()};
13089
13090                   exceptions->push_back (info);
13091                 }
13092             }
13093         }
13094       if (block->function () != NULL)
13095         break;
13096       block = block->superblock ();
13097     }
13098 }
13099
13100 /* Return true if NAME matches PREG or if PREG is NULL.  */
13101
13102 static bool
13103 name_matches_regex (const char *name, compiled_regex *preg)
13104 {
13105   return (preg == NULL
13106           || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
13107 }
13108
13109 /* Add all exceptions defined globally whose name name match
13110    a regular expression, excluding standard exceptions.
13111
13112    The reason we exclude standard exceptions is that they need
13113    to be handled separately: Standard exceptions are defined inside
13114    a runtime unit which is normally not compiled with debugging info,
13115    and thus usually do not show up in our symbol search.  However,
13116    if the unit was in fact built with debugging info, we need to
13117    exclude them because they would duplicate the entry we found
13118    during the special loop that specifically searches for those
13119    standard exceptions.
13120
13121    If PREG is not NULL, then this regexp_t object is used to
13122    perform the symbol name matching.  Otherwise, no name-based
13123    filtering is performed.
13124
13125    EXCEPTIONS is a vector of exceptions to which matching exceptions
13126    gets pushed.  */
13127
13128 static void
13129 ada_add_global_exceptions (compiled_regex *preg,
13130                            std::vector<ada_exc_info> *exceptions)
13131 {
13132   /* In Ada, the symbol "search name" is a linkage name, whereas the
13133      regular expression used to do the matching refers to the natural
13134      name.  So match against the decoded name.  */
13135   expand_symtabs_matching (NULL,
13136                            lookup_name_info::match_any (),
13137                            [&] (const char *search_name)
13138                            {
13139                              std::string decoded = ada_decode (search_name);
13140                              return name_matches_regex (decoded.c_str (), preg);
13141                            },
13142                            NULL,
13143                            SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13144                            VARIABLES_DOMAIN);
13145
13146   /* Iterate over all objfiles irrespective of scope or linker namespaces
13147      so we get all exceptions anywhere in the progspace.  */
13148   for (objfile *objfile : current_program_space->objfiles ())
13149     {
13150       for (compunit_symtab *s : objfile->compunits ())
13151         {
13152           const struct blockvector *bv = s->blockvector ();
13153           int i;
13154
13155           for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13156             {
13157               const struct block *b = bv->block (i);
13158               struct block_iterator iter;
13159               struct symbol *sym;
13160
13161               ALL_BLOCK_SYMBOLS (b, iter, sym)
13162                 if (ada_is_non_standard_exception_sym (sym)
13163                     && name_matches_regex (sym->natural_name (), preg))
13164                   {
13165                     struct ada_exc_info info
13166                       = {sym->print_name (), sym->value_address ()};
13167
13168                     exceptions->push_back (info);
13169                   }
13170             }
13171         }
13172     }
13173 }
13174
13175 /* Implements ada_exceptions_list with the regular expression passed
13176    as a regex_t, rather than a string.
13177
13178    If not NULL, PREG is used to filter out exceptions whose names
13179    do not match.  Otherwise, all exceptions are listed.  */
13180
13181 static std::vector<ada_exc_info>
13182 ada_exceptions_list_1 (compiled_regex *preg)
13183 {
13184   std::vector<ada_exc_info> result;
13185   int prev_len;
13186
13187   /* First, list the known standard exceptions.  These exceptions
13188      need to be handled separately, as they are usually defined in
13189      runtime units that have been compiled without debugging info.  */
13190
13191   ada_add_standard_exceptions (preg, &result);
13192
13193   /* Next, find all exceptions whose scope is local and accessible
13194      from the currently selected frame.  */
13195
13196   if (has_stack_frames ())
13197     {
13198       prev_len = result.size ();
13199       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13200                                      &result);
13201       if (result.size () > prev_len)
13202         sort_remove_dups_ada_exceptions_list (&result, prev_len);
13203     }
13204
13205   /* Add all exceptions whose scope is global.  */
13206
13207   prev_len = result.size ();
13208   ada_add_global_exceptions (preg, &result);
13209   if (result.size () > prev_len)
13210     sort_remove_dups_ada_exceptions_list (&result, prev_len);
13211
13212   return result;
13213 }
13214
13215 /* Return a vector of ada_exc_info.
13216
13217    If REGEXP is NULL, all exceptions are included in the result.
13218    Otherwise, it should contain a valid regular expression,
13219    and only the exceptions whose names match that regular expression
13220    are included in the result.
13221
13222    The exceptions are sorted in the following order:
13223      - Standard exceptions (defined by the Ada language), in
13224        alphabetical order;
13225      - Exceptions only visible from the current frame, in
13226        alphabetical order;
13227      - Exceptions whose scope is global, in alphabetical order.  */
13228
13229 std::vector<ada_exc_info>
13230 ada_exceptions_list (const char *regexp)
13231 {
13232   if (regexp == NULL)
13233     return ada_exceptions_list_1 (NULL);
13234
13235   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13236   return ada_exceptions_list_1 (&reg);
13237 }
13238
13239 /* Implement the "info exceptions" command.  */
13240
13241 static void
13242 info_exceptions_command (const char *regexp, int from_tty)
13243 {
13244   struct gdbarch *gdbarch = get_current_arch ();
13245
13246   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13247
13248   if (regexp != NULL)
13249     gdb_printf
13250       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13251   else
13252     gdb_printf (_("All defined Ada exceptions:\n"));
13253
13254   for (const ada_exc_info &info : exceptions)
13255     gdb_printf ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13256 }
13257
13258 \f
13259                                 /* Language vector */
13260
13261 /* symbol_name_matcher_ftype adapter for wild_match.  */
13262
13263 static bool
13264 do_wild_match (const char *symbol_search_name,
13265                const lookup_name_info &lookup_name,
13266                completion_match_result *comp_match_res)
13267 {
13268   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
13269 }
13270
13271 /* symbol_name_matcher_ftype adapter for full_match.  */
13272
13273 static bool
13274 do_full_match (const char *symbol_search_name,
13275                const lookup_name_info &lookup_name,
13276                completion_match_result *comp_match_res)
13277 {
13278   const char *lname = lookup_name.ada ().lookup_name ().c_str ();
13279
13280   /* If both symbols start with "_ada_", just let the loop below
13281      handle the comparison.  However, if only the symbol name starts
13282      with "_ada_", skip the prefix and let the match proceed as
13283      usual.  */
13284   if (startswith (symbol_search_name, "_ada_")
13285       && !startswith (lname, "_ada"))
13286     symbol_search_name += 5;
13287   /* Likewise for ghost entities.  */
13288   if (startswith (symbol_search_name, "___ghost_")
13289       && !startswith (lname, "___ghost_"))
13290     symbol_search_name += 9;
13291
13292   int uscore_count = 0;
13293   while (*lname != '\0')
13294     {
13295       if (*symbol_search_name != *lname)
13296         {
13297           if (*symbol_search_name == 'B' && uscore_count == 2
13298               && symbol_search_name[1] == '_')
13299             {
13300               symbol_search_name += 2;
13301               while (isdigit (*symbol_search_name))
13302                 ++symbol_search_name;
13303               if (symbol_search_name[0] == '_'
13304                   && symbol_search_name[1] == '_')
13305                 {
13306                   symbol_search_name += 2;
13307                   continue;
13308                 }
13309             }
13310           return false;
13311         }
13312
13313       if (*symbol_search_name == '_')
13314         ++uscore_count;
13315       else
13316         uscore_count = 0;
13317
13318       ++symbol_search_name;
13319       ++lname;
13320     }
13321
13322   return is_name_suffix (symbol_search_name);
13323 }
13324
13325 /* symbol_name_matcher_ftype for exact (verbatim) matches.  */
13326
13327 static bool
13328 do_exact_match (const char *symbol_search_name,
13329                 const lookup_name_info &lookup_name,
13330                 completion_match_result *comp_match_res)
13331 {
13332   return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
13333 }
13334
13335 /* Build the Ada lookup name for LOOKUP_NAME.  */
13336
13337 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
13338 {
13339   gdb::string_view user_name = lookup_name.name ();
13340
13341   if (!user_name.empty () && user_name[0] == '<')
13342     {
13343       if (user_name.back () == '>')
13344         m_encoded_name
13345           = gdb::to_string (user_name.substr (1, user_name.size () - 2));
13346       else
13347         m_encoded_name
13348           = gdb::to_string (user_name.substr (1, user_name.size () - 1));
13349       m_encoded_p = true;
13350       m_verbatim_p = true;
13351       m_wild_match_p = false;
13352       m_standard_p = false;
13353     }
13354   else
13355     {
13356       m_verbatim_p = false;
13357
13358       m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
13359
13360       if (!m_encoded_p)
13361         {
13362           const char *folded = ada_fold_name (user_name);
13363           m_encoded_name = ada_encode_1 (folded, false);
13364           if (m_encoded_name.empty ())
13365             m_encoded_name = gdb::to_string (user_name);
13366         }
13367       else
13368         m_encoded_name = gdb::to_string (user_name);
13369
13370       /* Handle the 'package Standard' special case.  See description
13371          of m_standard_p.  */
13372       if (startswith (m_encoded_name.c_str (), "standard__"))
13373         {
13374           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
13375           m_standard_p = true;
13376         }
13377       else
13378         m_standard_p = false;
13379
13380       /* If the name contains a ".", then the user is entering a fully
13381          qualified entity name, and the match must not be done in wild
13382          mode.  Similarly, if the user wants to complete what looks
13383          like an encoded name, the match must not be done in wild
13384          mode.  Also, in the standard__ special case always do
13385          non-wild matching.  */
13386       m_wild_match_p
13387         = (lookup_name.match_type () != symbol_name_match_type::FULL
13388            && !m_encoded_p
13389            && !m_standard_p
13390            && user_name.find ('.') == std::string::npos);
13391     }
13392 }
13393
13394 /* symbol_name_matcher_ftype method for Ada.  This only handles
13395    completion mode.  */
13396
13397 static bool
13398 ada_symbol_name_matches (const char *symbol_search_name,
13399                          const lookup_name_info &lookup_name,
13400                          completion_match_result *comp_match_res)
13401 {
13402   return lookup_name.ada ().matches (symbol_search_name,
13403                                      lookup_name.match_type (),
13404                                      comp_match_res);
13405 }
13406
13407 /* A name matcher that matches the symbol name exactly, with
13408    strcmp.  */
13409
13410 static bool
13411 literal_symbol_name_matcher (const char *symbol_search_name,
13412                              const lookup_name_info &lookup_name,
13413                              completion_match_result *comp_match_res)
13414 {
13415   gdb::string_view name_view = lookup_name.name ();
13416
13417   if (lookup_name.completion_mode ()
13418       ? (strncmp (symbol_search_name, name_view.data (),
13419                   name_view.size ()) == 0)
13420       : symbol_search_name == name_view)
13421     {
13422       if (comp_match_res != NULL)
13423         comp_match_res->set_match (symbol_search_name);
13424       return true;
13425     }
13426   else
13427     return false;
13428 }
13429
13430 /* Implement the "get_symbol_name_matcher" language_defn method for
13431    Ada.  */
13432
13433 static symbol_name_matcher_ftype *
13434 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
13435 {
13436   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
13437     return literal_symbol_name_matcher;
13438
13439   if (lookup_name.completion_mode ())
13440     return ada_symbol_name_matches;
13441   else
13442     {
13443       if (lookup_name.ada ().wild_match_p ())
13444         return do_wild_match;
13445       else if (lookup_name.ada ().verbatim_p ())
13446         return do_exact_match;
13447       else
13448         return do_full_match;
13449     }
13450 }
13451
13452 /* Class representing the Ada language.  */
13453
13454 class ada_language : public language_defn
13455 {
13456 public:
13457   ada_language ()
13458     : language_defn (language_ada)
13459   { /* Nothing.  */ }
13460
13461   /* See language.h.  */
13462
13463   const char *name () const override
13464   { return "ada"; }
13465
13466   /* See language.h.  */
13467
13468   const char *natural_name () const override
13469   { return "Ada"; }
13470
13471   /* See language.h.  */
13472
13473   const std::vector<const char *> &filename_extensions () const override
13474   {
13475     static const std::vector<const char *> extensions
13476       = { ".adb", ".ads", ".a", ".ada", ".dg" };
13477     return extensions;
13478   }
13479
13480   /* Print an array element index using the Ada syntax.  */
13481
13482   void print_array_index (struct type *index_type,
13483                           LONGEST index,
13484                           struct ui_file *stream,
13485                           const value_print_options *options) const override
13486   {
13487     struct value *index_value = val_atr (index_type, index);
13488
13489     value_print (index_value, stream, options);
13490     gdb_printf (stream, " => ");
13491   }
13492
13493   /* Implement the "read_var_value" language_defn method for Ada.  */
13494
13495   struct value *read_var_value (struct symbol *var,
13496                                 const struct block *var_block,
13497                                 frame_info_ptr frame) const override
13498   {
13499     /* The only case where default_read_var_value is not sufficient
13500        is when VAR is a renaming...  */
13501     if (frame != nullptr)
13502       {
13503         const struct block *frame_block = get_frame_block (frame, NULL);
13504         if (frame_block != nullptr && ada_is_renaming_symbol (var))
13505           return ada_read_renaming_var_value (var, frame_block);
13506       }
13507
13508     /* This is a typical case where we expect the default_read_var_value
13509        function to work.  */
13510     return language_defn::read_var_value (var, var_block, frame);
13511   }
13512
13513   /* See language.h.  */
13514   bool symbol_printing_suppressed (struct symbol *symbol) const override
13515   {
13516     return symbol->is_artificial ();
13517   }
13518
13519   /* See language.h.  */
13520   void language_arch_info (struct gdbarch *gdbarch,
13521                            struct language_arch_info *lai) const override
13522   {
13523     const struct builtin_type *builtin = builtin_type (gdbarch);
13524
13525     /* Helper function to allow shorter lines below.  */
13526     auto add = [&] (struct type *t)
13527     {
13528       lai->add_primitive_type (t);
13529     };
13530
13531     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13532                             0, "integer"));
13533     add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13534                             0, "long_integer"));
13535     add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13536                             0, "short_integer"));
13537     struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
13538                                                   1, "character");
13539     lai->set_string_char_type (char_type);
13540     add (char_type);
13541     add (arch_character_type (gdbarch, 16, 1, "wide_character"));
13542     add (arch_character_type (gdbarch, 32, 1, "wide_wide_character"));
13543     add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13544                           "float", gdbarch_float_format (gdbarch)));
13545     add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13546                           "long_float", gdbarch_double_format (gdbarch)));
13547     add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13548                             0, "long_long_integer"));
13549     add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13550                           "long_long_float",
13551                           gdbarch_long_double_format (gdbarch)));
13552     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13553                             0, "natural"));
13554     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13555                             0, "positive"));
13556     add (builtin->builtin_void);
13557
13558     struct type *system_addr_ptr
13559       = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13560                                         "void"));
13561     system_addr_ptr->set_name ("system__address");
13562     add (system_addr_ptr);
13563
13564     /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13565        type.  This is a signed integral type whose size is the same as
13566        the size of addresses.  */
13567     unsigned int addr_length = system_addr_ptr->length ();
13568     add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13569                             "storage_offset"));
13570
13571     lai->set_bool_type (builtin->builtin_bool);
13572   }
13573
13574   /* See language.h.  */
13575
13576   bool iterate_over_symbols
13577         (const struct block *block, const lookup_name_info &name,
13578          domain_enum domain,
13579          gdb::function_view<symbol_found_callback_ftype> callback) const override
13580   {
13581     std::vector<struct block_symbol> results
13582       = ada_lookup_symbol_list_worker (name, block, domain, 0);
13583     for (block_symbol &sym : results)
13584       {
13585         if (!callback (&sym))
13586           return false;
13587       }
13588
13589     return true;
13590   }
13591
13592   /* See language.h.  */
13593   bool sniff_from_mangled_name
13594        (const char *mangled,
13595         gdb::unique_xmalloc_ptr<char> *out) const override
13596   {
13597     std::string demangled = ada_decode (mangled);
13598
13599     *out = NULL;
13600
13601     if (demangled != mangled && demangled[0] != '<')
13602       {
13603         /* Set the gsymbol language to Ada, but still return 0.
13604            Two reasons for that:
13605
13606            1. For Ada, we prefer computing the symbol's decoded name
13607            on the fly rather than pre-compute it, in order to save
13608            memory (Ada projects are typically very large).
13609
13610            2. There are some areas in the definition of the GNAT
13611            encoding where, with a bit of bad luck, we might be able
13612            to decode a non-Ada symbol, generating an incorrect
13613            demangled name (Eg: names ending with "TB" for instance
13614            are identified as task bodies and so stripped from
13615            the decoded name returned).
13616
13617            Returning true, here, but not setting *DEMANGLED, helps us get
13618            a little bit of the best of both worlds.  Because we're last,
13619            we should not affect any of the other languages that were
13620            able to demangle the symbol before us; we get to correctly
13621            tag Ada symbols as such; and even if we incorrectly tagged a
13622            non-Ada symbol, which should be rare, any routing through the
13623            Ada language should be transparent (Ada tries to behave much
13624            like C/C++ with non-Ada symbols).  */
13625         return true;
13626       }
13627
13628     return false;
13629   }
13630
13631   /* See language.h.  */
13632
13633   gdb::unique_xmalloc_ptr<char> demangle_symbol (const char *mangled,
13634                                                  int options) const override
13635   {
13636     return make_unique_xstrdup (ada_decode (mangled).c_str ());
13637   }
13638
13639   /* See language.h.  */
13640
13641   void print_type (struct type *type, const char *varstring,
13642                    struct ui_file *stream, int show, int level,
13643                    const struct type_print_options *flags) const override
13644   {
13645     ada_print_type (type, varstring, stream, show, level, flags);
13646   }
13647
13648   /* See language.h.  */
13649
13650   const char *word_break_characters (void) const override
13651   {
13652     return ada_completer_word_break_characters;
13653   }
13654
13655   /* See language.h.  */
13656
13657   void collect_symbol_completion_matches (completion_tracker &tracker,
13658                                           complete_symbol_mode mode,
13659                                           symbol_name_match_type name_match_type,
13660                                           const char *text, const char *word,
13661                                           enum type_code code) const override
13662   {
13663     struct symbol *sym;
13664     const struct block *b, *surrounding_static_block = 0;
13665     struct block_iterator iter;
13666
13667     gdb_assert (code == TYPE_CODE_UNDEF);
13668
13669     lookup_name_info lookup_name (text, name_match_type, true);
13670
13671     /* First, look at the partial symtab symbols.  */
13672     expand_symtabs_matching (NULL,
13673                              lookup_name,
13674                              NULL,
13675                              NULL,
13676                              SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13677                              ALL_DOMAIN);
13678
13679     /* At this point scan through the misc symbol vectors and add each
13680        symbol you find to the list.  Eventually we want to ignore
13681        anything that isn't a text symbol (everything else will be
13682        handled by the psymtab code above).  */
13683
13684     for (objfile *objfile : current_program_space->objfiles ())
13685       {
13686         for (minimal_symbol *msymbol : objfile->msymbols ())
13687           {
13688             QUIT;
13689
13690             if (completion_skip_symbol (mode, msymbol))
13691               continue;
13692
13693             language symbol_language = msymbol->language ();
13694
13695             /* Ada minimal symbols won't have their language set to Ada.  If
13696                we let completion_list_add_name compare using the
13697                default/C-like matcher, then when completing e.g., symbols in a
13698                package named "pck", we'd match internal Ada symbols like
13699                "pckS", which are invalid in an Ada expression, unless you wrap
13700                them in '<' '>' to request a verbatim match.
13701
13702                Unfortunately, some Ada encoded names successfully demangle as
13703                C++ symbols (using an old mangling scheme), such as "name__2Xn"
13704                -> "Xn::name(void)" and thus some Ada minimal symbols end up
13705                with the wrong language set.  Paper over that issue here.  */
13706             if (symbol_language == language_auto
13707                 || symbol_language == language_cplus)
13708               symbol_language = language_ada;
13709
13710             completion_list_add_name (tracker,
13711                                       symbol_language,
13712                                       msymbol->linkage_name (),
13713                                       lookup_name, text, word);
13714           }
13715       }
13716
13717     /* Search upwards from currently selected frame (so that we can
13718        complete on local vars.  */
13719
13720     for (b = get_selected_block (0); b != NULL; b = b->superblock ())
13721       {
13722         if (!b->superblock ())
13723           surrounding_static_block = b;   /* For elmin of dups */
13724
13725         ALL_BLOCK_SYMBOLS (b, iter, sym)
13726           {
13727             if (completion_skip_symbol (mode, sym))
13728               continue;
13729
13730             completion_list_add_name (tracker,
13731                                       sym->language (),
13732                                       sym->linkage_name (),
13733                                       lookup_name, text, word);
13734           }
13735       }
13736
13737     /* Go through the symtabs and check the externs and statics for
13738        symbols which match.  */
13739
13740     for (objfile *objfile : current_program_space->objfiles ())
13741       {
13742         for (compunit_symtab *s : objfile->compunits ())
13743           {
13744             QUIT;
13745             b = s->blockvector ()->global_block ();
13746             ALL_BLOCK_SYMBOLS (b, iter, sym)
13747               {
13748                 if (completion_skip_symbol (mode, sym))
13749                   continue;
13750
13751                 completion_list_add_name (tracker,
13752                                           sym->language (),
13753                                           sym->linkage_name (),
13754                                           lookup_name, text, word);
13755               }
13756           }
13757       }
13758
13759     for (objfile *objfile : current_program_space->objfiles ())
13760       {
13761         for (compunit_symtab *s : objfile->compunits ())
13762           {
13763             QUIT;
13764             b = s->blockvector ()->static_block ();
13765             /* Don't do this block twice.  */
13766             if (b == surrounding_static_block)
13767               continue;
13768             ALL_BLOCK_SYMBOLS (b, iter, sym)
13769               {
13770                 if (completion_skip_symbol (mode, sym))
13771                   continue;
13772
13773                 completion_list_add_name (tracker,
13774                                           sym->language (),
13775                                           sym->linkage_name (),
13776                                           lookup_name, text, word);
13777               }
13778           }
13779       }
13780   }
13781
13782   /* See language.h.  */
13783
13784   gdb::unique_xmalloc_ptr<char> watch_location_expression
13785         (struct type *type, CORE_ADDR addr) const override
13786   {
13787     type = check_typedef (check_typedef (type)->target_type ());
13788     std::string name = type_to_string (type);
13789     return xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr));
13790   }
13791
13792   /* See language.h.  */
13793
13794   void value_print (struct value *val, struct ui_file *stream,
13795                     const struct value_print_options *options) const override
13796   {
13797     return ada_value_print (val, stream, options);
13798   }
13799
13800   /* See language.h.  */
13801
13802   void value_print_inner
13803         (struct value *val, struct ui_file *stream, int recurse,
13804          const struct value_print_options *options) const override
13805   {
13806     return ada_value_print_inner (val, stream, recurse, options);
13807   }
13808
13809   /* See language.h.  */
13810
13811   struct block_symbol lookup_symbol_nonlocal
13812         (const char *name, const struct block *block,
13813          const domain_enum domain) const override
13814   {
13815     struct block_symbol sym;
13816
13817     sym = ada_lookup_symbol (name, block_static_block (block), domain);
13818     if (sym.symbol != NULL)
13819       return sym;
13820
13821     /* If we haven't found a match at this point, try the primitive
13822        types.  In other languages, this search is performed before
13823        searching for global symbols in order to short-circuit that
13824        global-symbol search if it happens that the name corresponds
13825        to a primitive type.  But we cannot do the same in Ada, because
13826        it is perfectly legitimate for a program to declare a type which
13827        has the same name as a standard type.  If looking up a type in
13828        that situation, we have traditionally ignored the primitive type
13829        in favor of user-defined types.  This is why, unlike most other
13830        languages, we search the primitive types this late and only after
13831        having searched the global symbols without success.  */
13832
13833     if (domain == VAR_DOMAIN)
13834       {
13835         struct gdbarch *gdbarch;
13836
13837         if (block == NULL)
13838           gdbarch = target_gdbarch ();
13839         else
13840           gdbarch = block_gdbarch (block);
13841         sym.symbol
13842           = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13843         if (sym.symbol != NULL)
13844           return sym;
13845       }
13846
13847     return {};
13848   }
13849
13850   /* See language.h.  */
13851
13852   int parser (struct parser_state *ps) const override
13853   {
13854     warnings_issued = 0;
13855     return ada_parse (ps);
13856   }
13857
13858   /* See language.h.  */
13859
13860   void emitchar (int ch, struct type *chtype,
13861                  struct ui_file *stream, int quoter) const override
13862   {
13863     ada_emit_char (ch, chtype, stream, quoter, 1);
13864   }
13865
13866   /* See language.h.  */
13867
13868   void printchar (int ch, struct type *chtype,
13869                   struct ui_file *stream) const override
13870   {
13871     ada_printchar (ch, chtype, stream);
13872   }
13873
13874   /* See language.h.  */
13875
13876   void printstr (struct ui_file *stream, struct type *elttype,
13877                  const gdb_byte *string, unsigned int length,
13878                  const char *encoding, int force_ellipses,
13879                  const struct value_print_options *options) const override
13880   {
13881     ada_printstr (stream, elttype, string, length, encoding,
13882                   force_ellipses, options);
13883   }
13884
13885   /* See language.h.  */
13886
13887   void print_typedef (struct type *type, struct symbol *new_symbol,
13888                       struct ui_file *stream) const override
13889   {
13890     ada_print_typedef (type, new_symbol, stream);
13891   }
13892
13893   /* See language.h.  */
13894
13895   bool is_string_type_p (struct type *type) const override
13896   {
13897     return ada_is_string_type (type);
13898   }
13899
13900   /* See language.h.  */
13901
13902   const char *struct_too_deep_ellipsis () const override
13903   { return "(...)"; }
13904
13905   /* See language.h.  */
13906
13907   bool c_style_arrays_p () const override
13908   { return false; }
13909
13910   /* See language.h.  */
13911
13912   bool store_sym_names_in_linkage_form_p () const override
13913   { return true; }
13914
13915   /* See language.h.  */
13916
13917   const struct lang_varobj_ops *varobj_ops () const override
13918   { return &ada_varobj_ops; }
13919
13920 protected:
13921   /* See language.h.  */
13922
13923   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13924         (const lookup_name_info &lookup_name) const override
13925   {
13926     return ada_get_symbol_name_matcher (lookup_name);
13927   }
13928 };
13929
13930 /* Single instance of the Ada language class.  */
13931
13932 static ada_language ada_language_defn;
13933
13934 /* Command-list for the "set/show ada" prefix command.  */
13935 static struct cmd_list_element *set_ada_list;
13936 static struct cmd_list_element *show_ada_list;
13937
13938 /* This module's 'new_objfile' observer.  */
13939
13940 static void
13941 ada_new_objfile_observer (struct objfile *objfile)
13942 {
13943   ada_clear_symbol_cache ();
13944 }
13945
13946 /* This module's 'free_objfile' observer.  */
13947
13948 static void
13949 ada_free_objfile_observer (struct objfile *objfile)
13950 {
13951   ada_clear_symbol_cache ();
13952 }
13953
13954 /* Charsets known to GNAT.  */
13955 static const char * const gnat_source_charsets[] =
13956 {
13957   /* Note that code below assumes that the default comes first.
13958      Latin-1 is the default here, because that is also GNAT's
13959      default.  */
13960   "ISO-8859-1",
13961   "ISO-8859-2",
13962   "ISO-8859-3",
13963   "ISO-8859-4",
13964   "ISO-8859-5",
13965   "ISO-8859-15",
13966   "CP437",
13967   "CP850",
13968   /* Note that this value is special-cased in the encoder and
13969      decoder.  */
13970   ada_utf8,
13971   nullptr
13972 };
13973
13974 void _initialize_ada_language ();
13975 void
13976 _initialize_ada_language ()
13977 {
13978   add_setshow_prefix_cmd
13979     ("ada", no_class,
13980      _("Prefix command for changing Ada-specific settings."),
13981      _("Generic command for showing Ada-specific settings."),
13982      &set_ada_list, &show_ada_list,
13983      &setlist, &showlist);
13984
13985   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13986                            &trust_pad_over_xvs, _("\
13987 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13988 Show whether an optimization trusting PAD types over XVS types is activated."),
13989                            _("\
13990 This is related to the encoding used by the GNAT compiler.  The debugger\n\
13991 should normally trust the contents of PAD types, but certain older versions\n\
13992 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13993 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
13994 work around this bug.  It is always safe to turn this option \"off\", but\n\
13995 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13996 this option to \"off\" unless necessary."),
13997                             NULL, NULL, &set_ada_list, &show_ada_list);
13998
13999   add_setshow_boolean_cmd ("print-signatures", class_vars,
14000                            &print_signatures, _("\
14001 Enable or disable the output of formal and return types for functions in the \
14002 overloads selection menu."), _("\
14003 Show whether the output of formal and return types for functions in the \
14004 overloads selection menu is activated."),
14005                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14006
14007   ada_source_charset = gnat_source_charsets[0];
14008   add_setshow_enum_cmd ("source-charset", class_files,
14009                         gnat_source_charsets,
14010                         &ada_source_charset,  _("\
14011 Set the Ada source character set."), _("\
14012 Show the Ada source character set."), _("\
14013 The character set used for Ada source files.\n\
14014 This must correspond to the '-gnati' or '-gnatW' option passed to GNAT."),
14015                         nullptr, nullptr,
14016                         &set_ada_list, &show_ada_list);
14017
14018   add_catch_command ("exception", _("\
14019 Catch Ada exceptions, when raised.\n\
14020 Usage: catch exception [ARG] [if CONDITION]\n\
14021 Without any argument, stop when any Ada exception is raised.\n\
14022 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14023 being raised does not have a handler (and will therefore lead to the task's\n\
14024 termination).\n\
14025 Otherwise, the catchpoint only stops when the name of the exception being\n\
14026 raised is the same as ARG.\n\
14027 CONDITION is a boolean expression that is evaluated to see whether the\n\
14028 exception should cause a stop."),
14029                      catch_ada_exception_command,
14030                      catch_ada_completer,
14031                      CATCH_PERMANENT,
14032                      CATCH_TEMPORARY);
14033
14034   add_catch_command ("handlers", _("\
14035 Catch Ada exceptions, when handled.\n\
14036 Usage: catch handlers [ARG] [if CONDITION]\n\
14037 Without any argument, stop when any Ada exception is handled.\n\
14038 With an argument, catch only exceptions with the given name.\n\
14039 CONDITION is a boolean expression that is evaluated to see whether the\n\
14040 exception should cause a stop."),
14041                      catch_ada_handlers_command,
14042                      catch_ada_completer,
14043                      CATCH_PERMANENT,
14044                      CATCH_TEMPORARY);
14045   add_catch_command ("assert", _("\
14046 Catch failed Ada assertions, when raised.\n\
14047 Usage: catch assert [if CONDITION]\n\
14048 CONDITION is a boolean expression that is evaluated to see whether the\n\
14049 exception should cause a stop."),
14050                      catch_assert_command,
14051                      NULL,
14052                      CATCH_PERMANENT,
14053                      CATCH_TEMPORARY);
14054
14055   add_info ("exceptions", info_exceptions_command,
14056             _("\
14057 List all Ada exception names.\n\
14058 Usage: info exceptions [REGEXP]\n\
14059 If a regular expression is passed as an argument, only those matching\n\
14060 the regular expression are listed."));
14061
14062   add_setshow_prefix_cmd ("ada", class_maintenance,
14063                           _("Set Ada maintenance-related variables."),
14064                           _("Show Ada maintenance-related variables."),
14065                           &maint_set_ada_cmdlist, &maint_show_ada_cmdlist,
14066                           &maintenance_set_cmdlist, &maintenance_show_cmdlist);
14067
14068   add_setshow_boolean_cmd
14069     ("ignore-descriptive-types", class_maintenance,
14070      &ada_ignore_descriptive_types_p,
14071      _("Set whether descriptive types generated by GNAT should be ignored."),
14072      _("Show whether descriptive types generated by GNAT should be ignored."),
14073      _("\
14074 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14075 DWARF attribute."),
14076      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14077
14078   decoded_names_store = htab_create_alloc (256, htab_hash_string,
14079                                            htab_eq_string,
14080                                            NULL, xcalloc, xfree);
14081
14082   /* The ada-lang observers.  */
14083   gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
14084   gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
14085   gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");
14086 }
This page took 0.809819 seconds and 4 git commands to generate.