]> Git Repo - binutils.git/blob - gdb/ada-lang.c
gdb: remove symtab::blockvector
[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 struct 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 struct program_space_key<ada_pspace_data> ada_pspace_data_handle;
380
381 /* Return this module's data for the given program space (PSPACE).
382    If not is found, add a zero'ed one now.
383
384    This function always returns a valid object.  */
385
386 static struct ada_pspace_data *
387 get_ada_pspace_data (struct program_space *pspace)
388 {
389   struct ada_pspace_data *data;
390
391   data = ada_pspace_data_handle.get (pspace);
392   if (data == NULL)
393     data = ada_pspace_data_handle.emplace (pspace);
394
395   return data;
396 }
397
398                         /* Utilities */
399
400 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
401    all typedef layers have been peeled.  Otherwise, return TYPE.
402
403    Normally, we really expect a typedef type to only have 1 typedef layer.
404    In other words, we really expect the target type of a typedef type to be
405    a non-typedef type.  This is particularly true for Ada units, because
406    the language does not have a typedef vs not-typedef distinction.
407    In that respect, the Ada compiler has been trying to eliminate as many
408    typedef definitions in the debugging information, since they generally
409    do not bring any extra information (we still use typedef under certain
410    circumstances related mostly to the GNAT encoding).
411
412    Unfortunately, we have seen situations where the debugging information
413    generated by the compiler leads to such multiple typedef layers.  For
414    instance, consider the following example with stabs:
415
416      .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
417      .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
418
419    This is an error in the debugging information which causes type
420    pck__float_array___XUP to be defined twice, and the second time,
421    it is defined as a typedef of a typedef.
422
423    This is on the fringe of legality as far as debugging information is
424    concerned, and certainly unexpected.  But it is easy to handle these
425    situations correctly, so we can afford to be lenient in this case.  */
426
427 static struct type *
428 ada_typedef_target_type (struct type *type)
429 {
430   while (type->code () == TYPE_CODE_TYPEDEF)
431     type = TYPE_TARGET_TYPE (type);
432   return type;
433 }
434
435 /* Given DECODED_NAME a string holding a symbol name in its
436    decoded form (ie using the Ada dotted notation), returns
437    its unqualified name.  */
438
439 static const char *
440 ada_unqualified_name (const char *decoded_name)
441 {
442   const char *result;
443   
444   /* If the decoded name starts with '<', it means that the encoded
445      name does not follow standard naming conventions, and thus that
446      it is not your typical Ada symbol name.  Trying to unqualify it
447      is therefore pointless and possibly erroneous.  */
448   if (decoded_name[0] == '<')
449     return decoded_name;
450
451   result = strrchr (decoded_name, '.');
452   if (result != NULL)
453     result++;                   /* Skip the dot...  */
454   else
455     result = decoded_name;
456
457   return result;
458 }
459
460 /* Return a string starting with '<', followed by STR, and '>'.  */
461
462 static std::string
463 add_angle_brackets (const char *str)
464 {
465   return string_printf ("<%s>", str);
466 }
467
468 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
469    suffix of FIELD_NAME beginning "___".  */
470
471 static int
472 field_name_match (const char *field_name, const char *target)
473 {
474   int len = strlen (target);
475
476   return
477     (strncmp (field_name, target, len) == 0
478      && (field_name[len] == '\0'
479          || (startswith (field_name + len, "___")
480              && strcmp (field_name + strlen (field_name) - 6,
481                         "___XVN") != 0)));
482 }
483
484
485 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
486    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
487    and return its index.  This function also handles fields whose name
488    have ___ suffixes because the compiler sometimes alters their name
489    by adding such a suffix to represent fields with certain constraints.
490    If the field could not be found, return a negative number if
491    MAYBE_MISSING is set.  Otherwise raise an error.  */
492
493 int
494 ada_get_field_index (const struct type *type, const char *field_name,
495                      int maybe_missing)
496 {
497   int fieldno;
498   struct type *struct_type = check_typedef ((struct type *) type);
499
500   for (fieldno = 0; fieldno < struct_type->num_fields (); fieldno++)
501     if (field_name_match (struct_type->field (fieldno).name (), field_name))
502       return fieldno;
503
504   if (!maybe_missing)
505     error (_("Unable to find field %s in struct %s.  Aborting"),
506            field_name, struct_type->name ());
507
508   return -1;
509 }
510
511 /* The length of the prefix of NAME prior to any "___" suffix.  */
512
513 int
514 ada_name_prefix_len (const char *name)
515 {
516   if (name == NULL)
517     return 0;
518   else
519     {
520       const char *p = strstr (name, "___");
521
522       if (p == NULL)
523         return strlen (name);
524       else
525         return p - name;
526     }
527 }
528
529 /* Return non-zero if SUFFIX is a suffix of STR.
530    Return zero if STR is null.  */
531
532 static int
533 is_suffix (const char *str, const char *suffix)
534 {
535   int len1, len2;
536
537   if (str == NULL)
538     return 0;
539   len1 = strlen (str);
540   len2 = strlen (suffix);
541   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
542 }
543
544 /* The contents of value VAL, treated as a value of type TYPE.  The
545    result is an lval in memory if VAL is.  */
546
547 static struct value *
548 coerce_unspec_val_to_type (struct value *val, struct type *type)
549 {
550   type = ada_check_typedef (type);
551   if (value_type (val) == type)
552     return val;
553   else
554     {
555       struct value *result;
556
557       if (value_optimized_out (val))
558         result = allocate_optimized_out_value (type);
559       else if (value_lazy (val)
560                /* Be careful not to make a lazy not_lval value.  */
561                || (VALUE_LVAL (val) != not_lval
562                    && TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val))))
563         result = allocate_value_lazy (type);
564       else
565         {
566           result = allocate_value (type);
567           value_contents_copy (result, 0, val, 0, TYPE_LENGTH (type));
568         }
569       set_value_component_location (result, val);
570       set_value_bitsize (result, value_bitsize (val));
571       set_value_bitpos (result, value_bitpos (val));
572       if (VALUE_LVAL (result) == lval_memory)
573         set_value_address (result, value_address (val));
574       return result;
575     }
576 }
577
578 static const gdb_byte *
579 cond_offset_host (const gdb_byte *valaddr, long offset)
580 {
581   if (valaddr == NULL)
582     return NULL;
583   else
584     return valaddr + offset;
585 }
586
587 static CORE_ADDR
588 cond_offset_target (CORE_ADDR address, long offset)
589 {
590   if (address == 0)
591     return 0;
592   else
593     return address + offset;
594 }
595
596 /* Issue a warning (as for the definition of warning in utils.c, but
597    with exactly one argument rather than ...), unless the limit on the
598    number of warnings has passed during the evaluation of the current
599    expression.  */
600
601 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
602    provided by "complaint".  */
603 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
604
605 static void
606 lim_warning (const char *format, ...)
607 {
608   va_list args;
609
610   va_start (args, format);
611   warnings_issued += 1;
612   if (warnings_issued <= warning_limit)
613     vwarning (format, args);
614
615   va_end (args);
616 }
617
618 /* Maximum value of a SIZE-byte signed integer type.  */
619 static LONGEST
620 max_of_size (int size)
621 {
622   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
623
624   return top_bit | (top_bit - 1);
625 }
626
627 /* Minimum value of a SIZE-byte signed integer type.  */
628 static LONGEST
629 min_of_size (int size)
630 {
631   return -max_of_size (size) - 1;
632 }
633
634 /* Maximum value of a SIZE-byte unsigned integer type.  */
635 static ULONGEST
636 umax_of_size (int size)
637 {
638   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
639
640   return top_bit | (top_bit - 1);
641 }
642
643 /* Maximum value of integral type T, as a signed quantity.  */
644 static LONGEST
645 max_of_type (struct type *t)
646 {
647   if (t->is_unsigned ())
648     return (LONGEST) umax_of_size (TYPE_LENGTH (t));
649   else
650     return max_of_size (TYPE_LENGTH (t));
651 }
652
653 /* Minimum value of integral type T, as a signed quantity.  */
654 static LONGEST
655 min_of_type (struct type *t)
656 {
657   if (t->is_unsigned ())
658     return 0;
659   else
660     return min_of_size (TYPE_LENGTH (t));
661 }
662
663 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
664 LONGEST
665 ada_discrete_type_high_bound (struct type *type)
666 {
667   type = resolve_dynamic_type (type, {}, 0);
668   switch (type->code ())
669     {
670     case TYPE_CODE_RANGE:
671       {
672         const dynamic_prop &high = type->bounds ()->high;
673
674         if (high.kind () == PROP_CONST)
675           return high.const_val ();
676         else
677           {
678             gdb_assert (high.kind () == PROP_UNDEFINED);
679
680             /* This happens when trying to evaluate a type's dynamic bound
681                without a live target.  There is nothing relevant for us to
682                return here, so return 0.  */
683             return 0;
684           }
685       }
686     case TYPE_CODE_ENUM:
687       return type->field (type->num_fields () - 1).loc_enumval ();
688     case TYPE_CODE_BOOL:
689       return 1;
690     case TYPE_CODE_CHAR:
691     case TYPE_CODE_INT:
692       return max_of_type (type);
693     default:
694       error (_("Unexpected type in ada_discrete_type_high_bound."));
695     }
696 }
697
698 /* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
699 LONGEST
700 ada_discrete_type_low_bound (struct type *type)
701 {
702   type = resolve_dynamic_type (type, {}, 0);
703   switch (type->code ())
704     {
705     case TYPE_CODE_RANGE:
706       {
707         const dynamic_prop &low = type->bounds ()->low;
708
709         if (low.kind () == PROP_CONST)
710           return low.const_val ();
711         else
712           {
713             gdb_assert (low.kind () == PROP_UNDEFINED);
714
715             /* This happens when trying to evaluate a type's dynamic bound
716                without a live target.  There is nothing relevant for us to
717                return here, so return 0.  */
718             return 0;
719           }
720       }
721     case TYPE_CODE_ENUM:
722       return type->field (0).loc_enumval ();
723     case TYPE_CODE_BOOL:
724       return 0;
725     case TYPE_CODE_CHAR:
726     case TYPE_CODE_INT:
727       return min_of_type (type);
728     default:
729       error (_("Unexpected type in ada_discrete_type_low_bound."));
730     }
731 }
732
733 /* The identity on non-range types.  For range types, the underlying
734    non-range scalar type.  */
735
736 static struct type *
737 get_base_type (struct type *type)
738 {
739   while (type != NULL && type->code () == TYPE_CODE_RANGE)
740     {
741       if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
742         return type;
743       type = TYPE_TARGET_TYPE (type);
744     }
745   return type;
746 }
747
748 /* Return a decoded version of the given VALUE.  This means returning
749    a value whose type is obtained by applying all the GNAT-specific
750    encodings, making the resulting type a static but standard description
751    of the initial type.  */
752
753 struct value *
754 ada_get_decoded_value (struct value *value)
755 {
756   struct type *type = ada_check_typedef (value_type (value));
757
758   if (ada_is_array_descriptor_type (type)
759       || (ada_is_constrained_packed_array_type (type)
760           && type->code () != TYPE_CODE_PTR))
761     {
762       if (type->code () == TYPE_CODE_TYPEDEF)  /* array access type.  */
763         value = ada_coerce_to_simple_array_ptr (value);
764       else
765         value = ada_coerce_to_simple_array (value);
766     }
767   else
768     value = ada_to_fixed_value (value);
769
770   return value;
771 }
772
773 /* Same as ada_get_decoded_value, but with the given TYPE.
774    Because there is no associated actual value for this type,
775    the resulting type might be a best-effort approximation in
776    the case of dynamic types.  */
777
778 struct type *
779 ada_get_decoded_type (struct type *type)
780 {
781   type = to_static_fixed_type (type);
782   if (ada_is_constrained_packed_array_type (type))
783     type = ada_coerce_to_simple_array_type (type);
784   return type;
785 }
786
787 \f
788
789                                 /* Language Selection */
790
791 /* If the main program is in Ada, return language_ada, otherwise return LANG
792    (the main program is in Ada iif the adainit symbol is found).  */
793
794 static enum language
795 ada_update_initial_language (enum language lang)
796 {
797   if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
798     return language_ada;
799
800   return lang;
801 }
802
803 /* If the main procedure is written in Ada, then return its name.
804    The result is good until the next call.  Return NULL if the main
805    procedure doesn't appear to be in Ada.  */
806
807 char *
808 ada_main_name (void)
809 {
810   struct bound_minimal_symbol msym;
811   static gdb::unique_xmalloc_ptr<char> main_program_name;
812
813   /* For Ada, the name of the main procedure is stored in a specific
814      string constant, generated by the binder.  Look for that symbol,
815      extract its address, and then read that string.  If we didn't find
816      that string, then most probably the main procedure is not written
817      in Ada.  */
818   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
819
820   if (msym.minsym != NULL)
821     {
822       CORE_ADDR main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
823       if (main_program_name_addr == 0)
824         error (_("Invalid address for Ada main program name."));
825
826       main_program_name = target_read_string (main_program_name_addr, 1024);
827       return main_program_name.get ();
828     }
829
830   /* The main procedure doesn't seem to be in Ada.  */
831   return NULL;
832 }
833 \f
834                                 /* Symbols */
835
836 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
837    of NULLs.  */
838
839 const struct ada_opname_map ada_opname_table[] = {
840   {"Oadd", "\"+\"", BINOP_ADD},
841   {"Osubtract", "\"-\"", BINOP_SUB},
842   {"Omultiply", "\"*\"", BINOP_MUL},
843   {"Odivide", "\"/\"", BINOP_DIV},
844   {"Omod", "\"mod\"", BINOP_MOD},
845   {"Orem", "\"rem\"", BINOP_REM},
846   {"Oexpon", "\"**\"", BINOP_EXP},
847   {"Olt", "\"<\"", BINOP_LESS},
848   {"Ole", "\"<=\"", BINOP_LEQ},
849   {"Ogt", "\">\"", BINOP_GTR},
850   {"Oge", "\">=\"", BINOP_GEQ},
851   {"Oeq", "\"=\"", BINOP_EQUAL},
852   {"One", "\"/=\"", BINOP_NOTEQUAL},
853   {"Oand", "\"and\"", BINOP_BITWISE_AND},
854   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
855   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
856   {"Oconcat", "\"&\"", BINOP_CONCAT},
857   {"Oabs", "\"abs\"", UNOP_ABS},
858   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
859   {"Oadd", "\"+\"", UNOP_PLUS},
860   {"Osubtract", "\"-\"", UNOP_NEG},
861   {NULL, NULL}
862 };
863
864 /* If STR is a decoded version of a compiler-provided suffix (like the
865    "[cold]" in "symbol[cold]"), return true.  Otherwise, return
866    false.  */
867
868 static bool
869 is_compiler_suffix (const char *str)
870 {
871   gdb_assert (*str == '[');
872   ++str;
873   while (*str != '\0' && isalpha (*str))
874     ++str;
875   /* We accept a missing "]" in order to support completion.  */
876   return *str == '\0' || (str[0] == ']' && str[1] == '\0');
877 }
878
879 /* Append a non-ASCII character to RESULT.  */
880 static void
881 append_hex_encoded (std::string &result, uint32_t one_char)
882 {
883   if (one_char <= 0xff)
884     {
885       result.append ("U");
886       result.append (phex (one_char, 1));
887     }
888   else if (one_char <= 0xffff)
889     {
890       result.append ("W");
891       result.append (phex (one_char, 2));
892     }
893   else
894     {
895       result.append ("WW");
896       result.append (phex (one_char, 4));
897     }
898 }
899
900 /* Return a string that is a copy of the data in STORAGE, with
901    non-ASCII characters replaced by the appropriate hex encoding.  A
902    template is used because, for UTF-8, we actually want to work with
903    UTF-32 codepoints.  */
904 template<typename T>
905 std::string
906 copy_and_hex_encode (struct obstack *storage)
907 {
908   const T *chars = (T *) obstack_base (storage);
909   int num_chars = obstack_object_size (storage) / sizeof (T);
910   std::string result;
911   for (int i = 0; i < num_chars; ++i)
912     {
913       if (chars[i] <= 0x7f)
914         {
915           /* The host character set has to be a superset of ASCII, as
916              are all the other character sets we can use.  */
917           result.push_back (chars[i]);
918         }
919       else
920         append_hex_encoded (result, chars[i]);
921     }
922   return result;
923 }
924
925 /* The "encoded" form of DECODED, according to GNAT conventions.  If
926    THROW_ERRORS, throw an error if invalid operator name is found.
927    Otherwise, return the empty string in that case.  */
928
929 static std::string
930 ada_encode_1 (const char *decoded, bool throw_errors)
931 {
932   if (decoded == NULL)
933     return {};
934
935   std::string encoding_buffer;
936   bool saw_non_ascii = false;
937   for (const char *p = decoded; *p != '\0'; p += 1)
938     {
939       if ((*p & 0x80) != 0)
940         saw_non_ascii = true;
941
942       if (*p == '.')
943         encoding_buffer.append ("__");
944       else if (*p == '[' && is_compiler_suffix (p))
945         {
946           encoding_buffer = encoding_buffer + "." + (p + 1);
947           if (encoding_buffer.back () == ']')
948             encoding_buffer.pop_back ();
949           break;
950         }
951       else if (*p == '"')
952         {
953           const struct ada_opname_map *mapping;
954
955           for (mapping = ada_opname_table;
956                mapping->encoded != NULL
957                && !startswith (p, mapping->decoded); mapping += 1)
958             ;
959           if (mapping->encoded == NULL)
960             {
961               if (throw_errors)
962                 error (_("invalid Ada operator name: %s"), p);
963               else
964                 return {};
965             }
966           encoding_buffer.append (mapping->encoded);
967           break;
968         }
969       else
970         encoding_buffer.push_back (*p);
971     }
972
973   /* If a non-ASCII character is seen, we must convert it to the
974      appropriate hex form.  As this is more expensive, we keep track
975      of whether it is even necessary.  */
976   if (saw_non_ascii)
977     {
978       auto_obstack storage;
979       bool is_utf8 = ada_source_charset == ada_utf8;
980       try
981         {
982           convert_between_encodings
983             (host_charset (),
984              is_utf8 ? HOST_UTF32 : ada_source_charset,
985              (const gdb_byte *) encoding_buffer.c_str (),
986              encoding_buffer.length (), 1,
987              &storage, translit_none);
988         }
989       catch (const gdb_exception &)
990         {
991           static bool warned = false;
992
993           /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
994              might like to know why.  */
995           if (!warned)
996             {
997               warned = true;
998               warning (_("charset conversion failure for '%s'.\n"
999                          "You may have the wrong value for 'set ada source-charset'."),
1000                        encoding_buffer.c_str ());
1001             }
1002
1003           /* We don't try to recover from errors.  */
1004           return encoding_buffer;
1005         }
1006
1007       if (is_utf8)
1008         return copy_and_hex_encode<uint32_t> (&storage);
1009       return copy_and_hex_encode<gdb_byte> (&storage);
1010     }
1011
1012   return encoding_buffer;
1013 }
1014
1015 /* Find the entry for C in the case-folding table.  Return nullptr if
1016    the entry does not cover C.  */
1017 static const utf8_entry *
1018 find_case_fold_entry (uint32_t c)
1019 {
1020   auto iter = std::lower_bound (std::begin (ada_case_fold),
1021                                 std::end (ada_case_fold),
1022                                 c);
1023   if (iter == std::end (ada_case_fold)
1024       || c < iter->start
1025       || c > iter->end)
1026     return nullptr;
1027   return &*iter;
1028 }
1029
1030 /* Return NAME folded to lower case, or, if surrounded by single
1031    quotes, unfolded, but with the quotes stripped away.  If
1032    THROW_ON_ERROR is true, encoding failures will throw an exception
1033    rather than emitting a warning.  Result good to next call.  */
1034
1035 static const char *
1036 ada_fold_name (gdb::string_view name, bool throw_on_error = false)
1037 {
1038   static std::string fold_storage;
1039
1040   if (!name.empty () && name[0] == '\'')
1041     fold_storage = gdb::to_string (name.substr (1, name.size () - 2));
1042   else
1043     {
1044       /* Why convert to UTF-32 and implement our own case-folding,
1045          rather than convert to wchar_t and use the platform's
1046          functions?  I'm glad you asked.
1047
1048          The main problem is that GNAT implements an unusual rule for
1049          case folding.  For ASCII letters, letters in single-byte
1050          encodings (such as ISO-8859-*), and Unicode letters that fit
1051          in a single byte (i.e., code point is <= 0xff), the letter is
1052          folded to lower case.  Other Unicode letters are folded to
1053          upper case.
1054
1055          This rule means that the code must be able to examine the
1056          value of the character.  And, some hosts do not use Unicode
1057          for wchar_t, so examining the value of such characters is
1058          forbidden.  */
1059       auto_obstack storage;
1060       try
1061         {
1062           convert_between_encodings
1063             (host_charset (), HOST_UTF32,
1064              (const gdb_byte *) name.data (),
1065              name.length (), 1,
1066              &storage, translit_none);
1067         }
1068       catch (const gdb_exception &)
1069         {
1070           if (throw_on_error)
1071             throw;
1072
1073           static bool warned = false;
1074
1075           /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
1076              might like to know why.  */
1077           if (!warned)
1078             {
1079               warned = true;
1080               warning (_("could not convert '%s' from the host encoding (%s) to UTF-32.\n"
1081                          "This normally should not happen, please file a bug report."),
1082                        gdb::to_string (name).c_str (), host_charset ());
1083             }
1084
1085           /* We don't try to recover from errors; just return the
1086              original string.  */
1087           fold_storage = gdb::to_string (name);
1088           return fold_storage.c_str ();
1089         }
1090
1091       bool is_utf8 = ada_source_charset == ada_utf8;
1092       uint32_t *chars = (uint32_t *) obstack_base (&storage);
1093       int num_chars = obstack_object_size (&storage) / sizeof (uint32_t);
1094       for (int i = 0; i < num_chars; ++i)
1095         {
1096           const struct utf8_entry *entry = find_case_fold_entry (chars[i]);
1097           if (entry != nullptr)
1098             {
1099               uint32_t low = chars[i] + entry->lower_delta;
1100               if (!is_utf8 || low <= 0xff)
1101                 chars[i] = low;
1102               else
1103                 chars[i] = chars[i] + entry->upper_delta;
1104             }
1105         }
1106
1107       /* Now convert back to ordinary characters.  */
1108       auto_obstack reconverted;
1109       try
1110         {
1111           convert_between_encodings (HOST_UTF32,
1112                                      host_charset (),
1113                                      (const gdb_byte *) chars,
1114                                      num_chars * sizeof (uint32_t),
1115                                      sizeof (uint32_t),
1116                                      &reconverted,
1117                                      translit_none);
1118           obstack_1grow (&reconverted, '\0');
1119           fold_storage = std::string ((const char *) obstack_base (&reconverted));
1120         }
1121       catch (const gdb_exception &)
1122         {
1123           if (throw_on_error)
1124             throw;
1125
1126           static bool warned = false;
1127
1128           /* Converting back from UTF-32 shouldn't normally fail, but
1129              there are some host encodings without upper/lower
1130              equivalence.  */
1131           if (!warned)
1132             {
1133               warned = true;
1134               warning (_("could not convert the lower-cased variant of '%s'\n"
1135                          "from UTF-32 to the host encoding (%s)."),
1136                        gdb::to_string (name).c_str (), host_charset ());
1137             }
1138
1139           /* We don't try to recover from errors; just return the
1140              original string.  */
1141           fold_storage = gdb::to_string (name);
1142         }
1143     }
1144
1145   return fold_storage.c_str ();
1146 }
1147
1148 /* The "encoded" form of DECODED, according to GNAT conventions.  */
1149
1150 std::string
1151 ada_encode (const char *decoded)
1152 {
1153   if (decoded[0] != '<')
1154     decoded = ada_fold_name (decoded);
1155   return ada_encode_1 (decoded, true);
1156 }
1157
1158 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
1159
1160 static int
1161 is_lower_alphanum (const char c)
1162 {
1163   return (isdigit (c) || (isalpha (c) && islower (c)));
1164 }
1165
1166 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1167    This function saves in LEN the length of that same symbol name but
1168    without either of these suffixes:
1169      . .{DIGIT}+
1170      . ${DIGIT}+
1171      . ___{DIGIT}+
1172      . __{DIGIT}+.
1173
1174    These are suffixes introduced by the compiler for entities such as
1175    nested subprogram for instance, in order to avoid name clashes.
1176    They do not serve any purpose for the debugger.  */
1177
1178 static void
1179 ada_remove_trailing_digits (const char *encoded, int *len)
1180 {
1181   if (*len > 1 && isdigit (encoded[*len - 1]))
1182     {
1183       int i = *len - 2;
1184
1185       while (i > 0 && isdigit (encoded[i]))
1186         i--;
1187       if (i >= 0 && encoded[i] == '.')
1188         *len = i;
1189       else if (i >= 0 && encoded[i] == '$')
1190         *len = i;
1191       else if (i >= 2 && startswith (encoded + i - 2, "___"))
1192         *len = i - 2;
1193       else if (i >= 1 && startswith (encoded + i - 1, "__"))
1194         *len = i - 1;
1195     }
1196 }
1197
1198 /* Remove the suffix introduced by the compiler for protected object
1199    subprograms.  */
1200
1201 static void
1202 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1203 {
1204   /* Remove trailing N.  */
1205
1206   /* Protected entry subprograms are broken into two
1207      separate subprograms: The first one is unprotected, and has
1208      a 'N' suffix; the second is the protected version, and has
1209      the 'P' suffix.  The second calls the first one after handling
1210      the protection.  Since the P subprograms are internally generated,
1211      we leave these names undecoded, giving the user a clue that this
1212      entity is internal.  */
1213
1214   if (*len > 1
1215       && encoded[*len - 1] == 'N'
1216       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1217     *len = *len - 1;
1218 }
1219
1220 /* If ENCODED ends with a compiler-provided suffix (like ".cold"),
1221    then update *LEN to remove the suffix and return the offset of the
1222    character just past the ".".  Otherwise, return -1.  */
1223
1224 static int
1225 remove_compiler_suffix (const char *encoded, int *len)
1226 {
1227   int offset = *len - 1;
1228   while (offset > 0 && isalpha (encoded[offset]))
1229     --offset;
1230   if (offset > 0 && encoded[offset] == '.')
1231     {
1232       *len = offset;
1233       return offset + 1;
1234     }
1235   return -1;
1236 }
1237
1238 /* Convert an ASCII hex string to a number.  Reads exactly N
1239    characters from STR.  Returns true on success, false if one of the
1240    digits was not a hex digit.  */
1241 static bool
1242 convert_hex (const char *str, int n, uint32_t *out)
1243 {
1244   uint32_t result = 0;
1245
1246   for (int i = 0; i < n; ++i)
1247     {
1248       if (!isxdigit (str[i]))
1249         return false;
1250       result <<= 4;
1251       result |= fromhex (str[i]);
1252     }
1253
1254   *out = result;
1255   return true;
1256 }
1257
1258 /* Convert a wide character from its ASCII hex representation in STR
1259    (consisting of exactly N characters) to the host encoding,
1260    appending the resulting bytes to OUT.  If N==2 and the Ada source
1261    charset is not UTF-8, then hex refers to an encoding in the
1262    ADA_SOURCE_CHARSET; otherwise, use UTF-32.  Return true on success.
1263    Return false and do not modify OUT on conversion failure.  */
1264 static bool
1265 convert_from_hex_encoded (std::string &out, const char *str, int n)
1266 {
1267   uint32_t value;
1268
1269   if (!convert_hex (str, n, &value))
1270     return false;
1271   try
1272     {
1273       auto_obstack bytes;
1274       /* In the 'U' case, the hex digits encode the character in the
1275          Ada source charset.  However, if the source charset is UTF-8,
1276          this really means it is a single-byte UTF-32 character.  */
1277       if (n == 2 && ada_source_charset != ada_utf8)
1278         {
1279           gdb_byte one_char = (gdb_byte) value;
1280
1281           convert_between_encodings (ada_source_charset, host_charset (),
1282                                      &one_char,
1283                                      sizeof (one_char), sizeof (one_char),
1284                                      &bytes, translit_none);
1285         }
1286       else
1287         convert_between_encodings (HOST_UTF32, host_charset (),
1288                                    (const gdb_byte *) &value,
1289                                    sizeof (value), sizeof (value),
1290                                    &bytes, translit_none);
1291       obstack_1grow (&bytes, '\0');
1292       out.append ((const char *) obstack_base (&bytes));
1293     }
1294   catch (const gdb_exception &)
1295     {
1296       /* On failure, the caller will just let the encoded form
1297          through, which seems basically reasonable.  */
1298       return false;
1299     }
1300
1301   return true;
1302 }
1303
1304 /* See ada-lang.h.  */
1305
1306 std::string
1307 ada_decode (const char *encoded, bool wrap)
1308 {
1309   int i;
1310   int len0;
1311   const char *p;
1312   int at_start_name;
1313   std::string decoded;
1314   int suffix = -1;
1315
1316   /* With function descriptors on PPC64, the value of a symbol named
1317      ".FN", if it exists, is the entry point of the function "FN".  */
1318   if (encoded[0] == '.')
1319     encoded += 1;
1320
1321   /* The name of the Ada main procedure starts with "_ada_".
1322      This prefix is not part of the decoded name, so skip this part
1323      if we see this prefix.  */
1324   if (startswith (encoded, "_ada_"))
1325     encoded += 5;
1326   /* The "___ghost_" prefix is used for ghost entities.  Normally
1327      these aren't preserved but when they are, it's useful to see
1328      them.  */
1329   if (startswith (encoded, "___ghost_"))
1330     encoded += 9;
1331
1332   /* If the name starts with '_', then it is not a properly encoded
1333      name, so do not attempt to decode it.  Similarly, if the name
1334      starts with '<', the name should not be decoded.  */
1335   if (encoded[0] == '_' || encoded[0] == '<')
1336     goto Suppress;
1337
1338   len0 = strlen (encoded);
1339
1340   suffix = remove_compiler_suffix (encoded, &len0);
1341
1342   ada_remove_trailing_digits (encoded, &len0);
1343   ada_remove_po_subprogram_suffix (encoded, &len0);
1344
1345   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1346      the suffix is located before the current "end" of ENCODED.  We want
1347      to avoid re-matching parts of ENCODED that have previously been
1348      marked as discarded (by decrementing LEN0).  */
1349   p = strstr (encoded, "___");
1350   if (p != NULL && p - encoded < len0 - 3)
1351     {
1352       if (p[3] == 'X')
1353         len0 = p - encoded;
1354       else
1355         goto Suppress;
1356     }
1357
1358   /* Remove any trailing TKB suffix.  It tells us that this symbol
1359      is for the body of a task, but that information does not actually
1360      appear in the decoded name.  */
1361
1362   if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1363     len0 -= 3;
1364
1365   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1366      from the TKB suffix because it is used for non-anonymous task
1367      bodies.  */
1368
1369   if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1370     len0 -= 2;
1371
1372   /* Remove trailing "B" suffixes.  */
1373   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1374
1375   if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1376     len0 -= 1;
1377
1378   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1379
1380   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1381     {
1382       i = len0 - 2;
1383       while ((i >= 0 && isdigit (encoded[i]))
1384              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1385         i -= 1;
1386       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1387         len0 = i - 1;
1388       else if (encoded[i] == '$')
1389         len0 = i;
1390     }
1391
1392   /* The first few characters that are not alphabetic are not part
1393      of any encoding we use, so we can copy them over verbatim.  */
1394
1395   for (i = 0; i < len0 && !isalpha (encoded[i]); i += 1)
1396     decoded.push_back (encoded[i]);
1397
1398   at_start_name = 1;
1399   while (i < len0)
1400     {
1401       /* Is this a symbol function?  */
1402       if (at_start_name && encoded[i] == 'O')
1403         {
1404           int k;
1405
1406           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1407             {
1408               int op_len = strlen (ada_opname_table[k].encoded);
1409               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1410                             op_len - 1) == 0)
1411                   && !isalnum (encoded[i + op_len]))
1412                 {
1413                   decoded.append (ada_opname_table[k].decoded);
1414                   at_start_name = 0;
1415                   i += op_len;
1416                   break;
1417                 }
1418             }
1419           if (ada_opname_table[k].encoded != NULL)
1420             continue;
1421         }
1422       at_start_name = 0;
1423
1424       /* Replace "TK__" with "__", which will eventually be translated
1425          into "." (just below).  */
1426
1427       if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1428         i += 2;
1429
1430       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1431          be translated into "." (just below).  These are internal names
1432          generated for anonymous blocks inside which our symbol is nested.  */
1433
1434       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1435           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1436           && isdigit (encoded [i+4]))
1437         {
1438           int k = i + 5;
1439           
1440           while (k < len0 && isdigit (encoded[k]))
1441             k++;  /* Skip any extra digit.  */
1442
1443           /* Double-check that the "__B_{DIGITS}+" sequence we found
1444              is indeed followed by "__".  */
1445           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1446             i = k;
1447         }
1448
1449       /* Remove _E{DIGITS}+[sb] */
1450
1451       /* Just as for protected object subprograms, there are 2 categories
1452          of subprograms created by the compiler for each entry.  The first
1453          one implements the actual entry code, and has a suffix following
1454          the convention above; the second one implements the barrier and
1455          uses the same convention as above, except that the 'E' is replaced
1456          by a 'B'.
1457
1458          Just as above, we do not decode the name of barrier functions
1459          to give the user a clue that the code he is debugging has been
1460          internally generated.  */
1461
1462       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1463           && isdigit (encoded[i+2]))
1464         {
1465           int k = i + 3;
1466
1467           while (k < len0 && isdigit (encoded[k]))
1468             k++;
1469
1470           if (k < len0
1471               && (encoded[k] == 'b' || encoded[k] == 's'))
1472             {
1473               k++;
1474               /* Just as an extra precaution, make sure that if this
1475                  suffix is followed by anything else, it is a '_'.
1476                  Otherwise, we matched this sequence by accident.  */
1477               if (k == len0
1478                   || (k < len0 && encoded[k] == '_'))
1479                 i = k;
1480             }
1481         }
1482
1483       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1484          the GNAT front-end in protected object subprograms.  */
1485
1486       if (i < len0 + 3
1487           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1488         {
1489           /* Backtrack a bit up until we reach either the begining of
1490              the encoded name, or "__".  Make sure that we only find
1491              digits or lowercase characters.  */
1492           const char *ptr = encoded + i - 1;
1493
1494           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1495             ptr--;
1496           if (ptr < encoded
1497               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1498             i++;
1499         }
1500
1501       if (i < len0 + 3 && encoded[i] == 'U' && isxdigit (encoded[i + 1]))
1502         {
1503           if (convert_from_hex_encoded (decoded, &encoded[i + 1], 2))
1504             {
1505               i += 3;
1506               continue;
1507             }
1508         }
1509       else if (i < len0 + 5 && encoded[i] == 'W' && isxdigit (encoded[i + 1]))
1510         {
1511           if (convert_from_hex_encoded (decoded, &encoded[i + 1], 4))
1512             {
1513               i += 5;
1514               continue;
1515             }
1516         }
1517       else if (i < len0 + 10 && encoded[i] == 'W' && encoded[i + 1] == 'W'
1518                && isxdigit (encoded[i + 2]))
1519         {
1520           if (convert_from_hex_encoded (decoded, &encoded[i + 2], 8))
1521             {
1522               i += 10;
1523               continue;
1524             }
1525         }
1526
1527       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1528         {
1529           /* This is a X[bn]* sequence not separated from the previous
1530              part of the name with a non-alpha-numeric character (in other
1531              words, immediately following an alpha-numeric character), then
1532              verify that it is placed at the end of the encoded name.  If
1533              not, then the encoding is not valid and we should abort the
1534              decoding.  Otherwise, just skip it, it is used in body-nested
1535              package names.  */
1536           do
1537             i += 1;
1538           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1539           if (i < len0)
1540             goto Suppress;
1541         }
1542       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1543         {
1544          /* Replace '__' by '.'.  */
1545           decoded.push_back ('.');
1546           at_start_name = 1;
1547           i += 2;
1548         }
1549       else
1550         {
1551           /* It's a character part of the decoded name, so just copy it
1552              over.  */
1553           decoded.push_back (encoded[i]);
1554           i += 1;
1555         }
1556     }
1557
1558   /* Decoded names should never contain any uppercase character.
1559      Double-check this, and abort the decoding if we find one.  */
1560
1561   for (i = 0; i < decoded.length(); ++i)
1562     if (isupper (decoded[i]) || decoded[i] == ' ')
1563       goto Suppress;
1564
1565   /* If the compiler added a suffix, append it now.  */
1566   if (suffix >= 0)
1567     decoded = decoded + "[" + &encoded[suffix] + "]";
1568
1569   return decoded;
1570
1571 Suppress:
1572   if (!wrap)
1573     return {};
1574
1575   if (encoded[0] == '<')
1576     decoded = encoded;
1577   else
1578     decoded = '<' + std::string(encoded) + '>';
1579   return decoded;
1580 }
1581
1582 /* Table for keeping permanent unique copies of decoded names.  Once
1583    allocated, names in this table are never released.  While this is a
1584    storage leak, it should not be significant unless there are massive
1585    changes in the set of decoded names in successive versions of a 
1586    symbol table loaded during a single session.  */
1587 static struct htab *decoded_names_store;
1588
1589 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1590    in the language-specific part of GSYMBOL, if it has not been
1591    previously computed.  Tries to save the decoded name in the same
1592    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1593    in any case, the decoded symbol has a lifetime at least that of
1594    GSYMBOL).
1595    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1596    const, but nevertheless modified to a semantically equivalent form
1597    when a decoded name is cached in it.  */
1598
1599 const char *
1600 ada_decode_symbol (const struct general_symbol_info *arg)
1601 {
1602   struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1603   const char **resultp =
1604     &gsymbol->language_specific.demangled_name;
1605
1606   if (!gsymbol->ada_mangled)
1607     {
1608       std::string decoded = ada_decode (gsymbol->linkage_name ());
1609       struct obstack *obstack = gsymbol->language_specific.obstack;
1610
1611       gsymbol->ada_mangled = 1;
1612
1613       if (obstack != NULL)
1614         *resultp = obstack_strdup (obstack, decoded.c_str ());
1615       else
1616         {
1617           /* Sometimes, we can't find a corresponding objfile, in
1618              which case, we put the result on the heap.  Since we only
1619              decode when needed, we hope this usually does not cause a
1620              significant memory leak (FIXME).  */
1621
1622           char **slot = (char **) htab_find_slot (decoded_names_store,
1623                                                   decoded.c_str (), INSERT);
1624
1625           if (*slot == NULL)
1626             *slot = xstrdup (decoded.c_str ());
1627           *resultp = *slot;
1628         }
1629     }
1630
1631   return *resultp;
1632 }
1633
1634 \f
1635
1636                                 /* Arrays */
1637
1638 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1639    generated by the GNAT compiler to describe the index type used
1640    for each dimension of an array, check whether it follows the latest
1641    known encoding.  If not, fix it up to conform to the latest encoding.
1642    Otherwise, do nothing.  This function also does nothing if
1643    INDEX_DESC_TYPE is NULL.
1644
1645    The GNAT encoding used to describe the array index type evolved a bit.
1646    Initially, the information would be provided through the name of each
1647    field of the structure type only, while the type of these fields was
1648    described as unspecified and irrelevant.  The debugger was then expected
1649    to perform a global type lookup using the name of that field in order
1650    to get access to the full index type description.  Because these global
1651    lookups can be very expensive, the encoding was later enhanced to make
1652    the global lookup unnecessary by defining the field type as being
1653    the full index type description.
1654
1655    The purpose of this routine is to allow us to support older versions
1656    of the compiler by detecting the use of the older encoding, and by
1657    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1658    we essentially replace each field's meaningless type by the associated
1659    index subtype).  */
1660
1661 void
1662 ada_fixup_array_indexes_type (struct type *index_desc_type)
1663 {
1664   int i;
1665
1666   if (index_desc_type == NULL)
1667     return;
1668   gdb_assert (index_desc_type->num_fields () > 0);
1669
1670   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1671      to check one field only, no need to check them all).  If not, return
1672      now.
1673
1674      If our INDEX_DESC_TYPE was generated using the older encoding,
1675      the field type should be a meaningless integer type whose name
1676      is not equal to the field name.  */
1677   if (index_desc_type->field (0).type ()->name () != NULL
1678       && strcmp (index_desc_type->field (0).type ()->name (),
1679                  index_desc_type->field (0).name ()) == 0)
1680     return;
1681
1682   /* Fixup each field of INDEX_DESC_TYPE.  */
1683   for (i = 0; i < index_desc_type->num_fields (); i++)
1684    {
1685      const char *name = index_desc_type->field (i).name ();
1686      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1687
1688      if (raw_type)
1689        index_desc_type->field (i).set_type (raw_type);
1690    }
1691 }
1692
1693 /* The desc_* routines return primitive portions of array descriptors
1694    (fat pointers).  */
1695
1696 /* The descriptor or array type, if any, indicated by TYPE; removes
1697    level of indirection, if needed.  */
1698
1699 static struct type *
1700 desc_base_type (struct type *type)
1701 {
1702   if (type == NULL)
1703     return NULL;
1704   type = ada_check_typedef (type);
1705   if (type->code () == TYPE_CODE_TYPEDEF)
1706     type = ada_typedef_target_type (type);
1707
1708   if (type != NULL
1709       && (type->code () == TYPE_CODE_PTR
1710           || type->code () == TYPE_CODE_REF))
1711     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1712   else
1713     return type;
1714 }
1715
1716 /* True iff TYPE indicates a "thin" array pointer type.  */
1717
1718 static int
1719 is_thin_pntr (struct type *type)
1720 {
1721   return
1722     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1723     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1724 }
1725
1726 /* The descriptor type for thin pointer type TYPE.  */
1727
1728 static struct type *
1729 thin_descriptor_type (struct type *type)
1730 {
1731   struct type *base_type = desc_base_type (type);
1732
1733   if (base_type == NULL)
1734     return NULL;
1735   if (is_suffix (ada_type_name (base_type), "___XVE"))
1736     return base_type;
1737   else
1738     {
1739       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1740
1741       if (alt_type == NULL)
1742         return base_type;
1743       else
1744         return alt_type;
1745     }
1746 }
1747
1748 /* A pointer to the array data for thin-pointer value VAL.  */
1749
1750 static struct value *
1751 thin_data_pntr (struct value *val)
1752 {
1753   struct type *type = ada_check_typedef (value_type (val));
1754   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1755
1756   data_type = lookup_pointer_type (data_type);
1757
1758   if (type->code () == TYPE_CODE_PTR)
1759     return value_cast (data_type, value_copy (val));
1760   else
1761     return value_from_longest (data_type, value_address (val));
1762 }
1763
1764 /* True iff TYPE indicates a "thick" array pointer type.  */
1765
1766 static int
1767 is_thick_pntr (struct type *type)
1768 {
1769   type = desc_base_type (type);
1770   return (type != NULL && type->code () == TYPE_CODE_STRUCT
1771           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1772 }
1773
1774 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1775    pointer to one, the type of its bounds data; otherwise, NULL.  */
1776
1777 static struct type *
1778 desc_bounds_type (struct type *type)
1779 {
1780   struct type *r;
1781
1782   type = desc_base_type (type);
1783
1784   if (type == NULL)
1785     return NULL;
1786   else if (is_thin_pntr (type))
1787     {
1788       type = thin_descriptor_type (type);
1789       if (type == NULL)
1790         return NULL;
1791       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1792       if (r != NULL)
1793         return ada_check_typedef (r);
1794     }
1795   else if (type->code () == TYPE_CODE_STRUCT)
1796     {
1797       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1798       if (r != NULL)
1799         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1800     }
1801   return NULL;
1802 }
1803
1804 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1805    one, a pointer to its bounds data.   Otherwise NULL.  */
1806
1807 static struct value *
1808 desc_bounds (struct value *arr)
1809 {
1810   struct type *type = ada_check_typedef (value_type (arr));
1811
1812   if (is_thin_pntr (type))
1813     {
1814       struct type *bounds_type =
1815         desc_bounds_type (thin_descriptor_type (type));
1816       LONGEST addr;
1817
1818       if (bounds_type == NULL)
1819         error (_("Bad GNAT array descriptor"));
1820
1821       /* NOTE: The following calculation is not really kosher, but
1822          since desc_type is an XVE-encoded type (and shouldn't be),
1823          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1824       if (type->code () == TYPE_CODE_PTR)
1825         addr = value_as_long (arr);
1826       else
1827         addr = value_address (arr);
1828
1829       return
1830         value_from_longest (lookup_pointer_type (bounds_type),
1831                             addr - TYPE_LENGTH (bounds_type));
1832     }
1833
1834   else if (is_thick_pntr (type))
1835     {
1836       struct value *p_bounds = value_struct_elt (&arr, {}, "P_BOUNDS", NULL,
1837                                                _("Bad GNAT array descriptor"));
1838       struct type *p_bounds_type = value_type (p_bounds);
1839
1840       if (p_bounds_type
1841           && p_bounds_type->code () == TYPE_CODE_PTR)
1842         {
1843           struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1844
1845           if (target_type->is_stub ())
1846             p_bounds = value_cast (lookup_pointer_type
1847                                    (ada_check_typedef (target_type)),
1848                                    p_bounds);
1849         }
1850       else
1851         error (_("Bad GNAT array descriptor"));
1852
1853       return p_bounds;
1854     }
1855   else
1856     return NULL;
1857 }
1858
1859 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1860    position of the field containing the address of the bounds data.  */
1861
1862 static int
1863 fat_pntr_bounds_bitpos (struct type *type)
1864 {
1865   return desc_base_type (type)->field (1).loc_bitpos ();
1866 }
1867
1868 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1869    size of the field containing the address of the bounds data.  */
1870
1871 static int
1872 fat_pntr_bounds_bitsize (struct type *type)
1873 {
1874   type = desc_base_type (type);
1875
1876   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1877     return TYPE_FIELD_BITSIZE (type, 1);
1878   else
1879     return 8 * TYPE_LENGTH (ada_check_typedef (type->field (1).type ()));
1880 }
1881
1882 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1883    pointer to one, the type of its array data (a array-with-no-bounds type);
1884    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1885    data.  */
1886
1887 static struct type *
1888 desc_data_target_type (struct type *type)
1889 {
1890   type = desc_base_type (type);
1891
1892   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1893   if (is_thin_pntr (type))
1894     return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1895   else if (is_thick_pntr (type))
1896     {
1897       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1898
1899       if (data_type
1900           && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1901         return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1902     }
1903
1904   return NULL;
1905 }
1906
1907 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1908    its array data.  */
1909
1910 static struct value *
1911 desc_data (struct value *arr)
1912 {
1913   struct type *type = value_type (arr);
1914
1915   if (is_thin_pntr (type))
1916     return thin_data_pntr (arr);
1917   else if (is_thick_pntr (type))
1918     return value_struct_elt (&arr, {}, "P_ARRAY", NULL,
1919                              _("Bad GNAT array descriptor"));
1920   else
1921     return NULL;
1922 }
1923
1924
1925 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1926    position of the field containing the address of the data.  */
1927
1928 static int
1929 fat_pntr_data_bitpos (struct type *type)
1930 {
1931   return desc_base_type (type)->field (0).loc_bitpos ();
1932 }
1933
1934 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1935    size of the field containing the address of the data.  */
1936
1937 static int
1938 fat_pntr_data_bitsize (struct type *type)
1939 {
1940   type = desc_base_type (type);
1941
1942   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1943     return TYPE_FIELD_BITSIZE (type, 0);
1944   else
1945     return TARGET_CHAR_BIT * TYPE_LENGTH (type->field (0).type ());
1946 }
1947
1948 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1949    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1950    bound, if WHICH is 1.  The first bound is I=1.  */
1951
1952 static struct value *
1953 desc_one_bound (struct value *bounds, int i, int which)
1954 {
1955   char bound_name[20];
1956   xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1957              which ? 'U' : 'L', i - 1);
1958   return value_struct_elt (&bounds, {}, bound_name, NULL,
1959                            _("Bad GNAT array descriptor bounds"));
1960 }
1961
1962 /* If BOUNDS is an array-bounds structure type, return the bit position
1963    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1964    bound, if WHICH is 1.  The first bound is I=1.  */
1965
1966 static int
1967 desc_bound_bitpos (struct type *type, int i, int which)
1968 {
1969   return desc_base_type (type)->field (2 * i + which - 2).loc_bitpos ();
1970 }
1971
1972 /* If BOUNDS is an array-bounds structure type, return the bit field size
1973    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1974    bound, if WHICH is 1.  The first bound is I=1.  */
1975
1976 static int
1977 desc_bound_bitsize (struct type *type, int i, int which)
1978 {
1979   type = desc_base_type (type);
1980
1981   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1982     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1983   else
1984     return 8 * TYPE_LENGTH (type->field (2 * i + which - 2).type ());
1985 }
1986
1987 /* If TYPE is the type of an array-bounds structure, the type of its
1988    Ith bound (numbering from 1).  Otherwise, NULL.  */
1989
1990 static struct type *
1991 desc_index_type (struct type *type, int i)
1992 {
1993   type = desc_base_type (type);
1994
1995   if (type->code () == TYPE_CODE_STRUCT)
1996     {
1997       char bound_name[20];
1998       xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
1999       return lookup_struct_elt_type (type, bound_name, 1);
2000     }
2001   else
2002     return NULL;
2003 }
2004
2005 /* The number of index positions in the array-bounds type TYPE.
2006    Return 0 if TYPE is NULL.  */
2007
2008 static int
2009 desc_arity (struct type *type)
2010 {
2011   type = desc_base_type (type);
2012
2013   if (type != NULL)
2014     return type->num_fields () / 2;
2015   return 0;
2016 }
2017
2018 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
2019    an array descriptor type (representing an unconstrained array
2020    type).  */
2021
2022 static int
2023 ada_is_direct_array_type (struct type *type)
2024 {
2025   if (type == NULL)
2026     return 0;
2027   type = ada_check_typedef (type);
2028   return (type->code () == TYPE_CODE_ARRAY
2029           || ada_is_array_descriptor_type (type));
2030 }
2031
2032 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
2033  * to one.  */
2034
2035 static int
2036 ada_is_array_type (struct type *type)
2037 {
2038   while (type != NULL
2039          && (type->code () == TYPE_CODE_PTR
2040              || type->code () == TYPE_CODE_REF))
2041     type = TYPE_TARGET_TYPE (type);
2042   return ada_is_direct_array_type (type);
2043 }
2044
2045 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
2046
2047 int
2048 ada_is_simple_array_type (struct type *type)
2049 {
2050   if (type == NULL)
2051     return 0;
2052   type = ada_check_typedef (type);
2053   return (type->code () == TYPE_CODE_ARRAY
2054           || (type->code () == TYPE_CODE_PTR
2055               && (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ()
2056                   == TYPE_CODE_ARRAY)));
2057 }
2058
2059 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
2060
2061 int
2062 ada_is_array_descriptor_type (struct type *type)
2063 {
2064   struct type *data_type = desc_data_target_type (type);
2065
2066   if (type == NULL)
2067     return 0;
2068   type = ada_check_typedef (type);
2069   return (data_type != NULL
2070           && data_type->code () == TYPE_CODE_ARRAY
2071           && desc_arity (desc_bounds_type (type)) > 0);
2072 }
2073
2074 /* Non-zero iff type is a partially mal-formed GNAT array
2075    descriptor.  FIXME: This is to compensate for some problems with
2076    debugging output from GNAT.  Re-examine periodically to see if it
2077    is still needed.  */
2078
2079 int
2080 ada_is_bogus_array_descriptor (struct type *type)
2081 {
2082   return
2083     type != NULL
2084     && type->code () == TYPE_CODE_STRUCT
2085     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
2086         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
2087     && !ada_is_array_descriptor_type (type);
2088 }
2089
2090
2091 /* If ARR has a record type in the form of a standard GNAT array descriptor,
2092    (fat pointer) returns the type of the array data described---specifically,
2093    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
2094    in from the descriptor; otherwise, they are left unspecified.  If
2095    the ARR denotes a null array descriptor and BOUNDS is non-zero,
2096    returns NULL.  The result is simply the type of ARR if ARR is not
2097    a descriptor.  */
2098
2099 static struct type *
2100 ada_type_of_array (struct value *arr, int bounds)
2101 {
2102   if (ada_is_constrained_packed_array_type (value_type (arr)))
2103     return decode_constrained_packed_array_type (value_type (arr));
2104
2105   if (!ada_is_array_descriptor_type (value_type (arr)))
2106     return value_type (arr);
2107
2108   if (!bounds)
2109     {
2110       struct type *array_type =
2111         ada_check_typedef (desc_data_target_type (value_type (arr)));
2112
2113       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2114         TYPE_FIELD_BITSIZE (array_type, 0) =
2115           decode_packed_array_bitsize (value_type (arr));
2116       
2117       return array_type;
2118     }
2119   else
2120     {
2121       struct type *elt_type;
2122       int arity;
2123       struct value *descriptor;
2124
2125       elt_type = ada_array_element_type (value_type (arr), -1);
2126       arity = ada_array_arity (value_type (arr));
2127
2128       if (elt_type == NULL || arity == 0)
2129         return ada_check_typedef (value_type (arr));
2130
2131       descriptor = desc_bounds (arr);
2132       if (value_as_long (descriptor) == 0)
2133         return NULL;
2134       while (arity > 0)
2135         {
2136           struct type *range_type = alloc_type_copy (value_type (arr));
2137           struct type *array_type = alloc_type_copy (value_type (arr));
2138           struct value *low = desc_one_bound (descriptor, arity, 0);
2139           struct value *high = desc_one_bound (descriptor, arity, 1);
2140
2141           arity -= 1;
2142           create_static_range_type (range_type, value_type (low),
2143                                     longest_to_int (value_as_long (low)),
2144                                     longest_to_int (value_as_long (high)));
2145           elt_type = create_array_type (array_type, elt_type, range_type);
2146
2147           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2148             {
2149               /* We need to store the element packed bitsize, as well as
2150                  recompute the array size, because it was previously
2151                  computed based on the unpacked element size.  */
2152               LONGEST lo = value_as_long (low);
2153               LONGEST hi = value_as_long (high);
2154
2155               TYPE_FIELD_BITSIZE (elt_type, 0) =
2156                 decode_packed_array_bitsize (value_type (arr));
2157               /* If the array has no element, then the size is already
2158                  zero, and does not need to be recomputed.  */
2159               if (lo < hi)
2160                 {
2161                   int array_bitsize =
2162                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2163
2164                   TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2165                 }
2166             }
2167         }
2168
2169       return lookup_pointer_type (elt_type);
2170     }
2171 }
2172
2173 /* If ARR does not represent an array, returns ARR unchanged.
2174    Otherwise, returns either a standard GDB array with bounds set
2175    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2176    GDB array.  Returns NULL if ARR is a null fat pointer.  */
2177
2178 struct value *
2179 ada_coerce_to_simple_array_ptr (struct value *arr)
2180 {
2181   if (ada_is_array_descriptor_type (value_type (arr)))
2182     {
2183       struct type *arrType = ada_type_of_array (arr, 1);
2184
2185       if (arrType == NULL)
2186         return NULL;
2187       return value_cast (arrType, value_copy (desc_data (arr)));
2188     }
2189   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2190     return decode_constrained_packed_array (arr);
2191   else
2192     return arr;
2193 }
2194
2195 /* If ARR does not represent an array, returns ARR unchanged.
2196    Otherwise, returns a standard GDB array describing ARR (which may
2197    be ARR itself if it already is in the proper form).  */
2198
2199 struct value *
2200 ada_coerce_to_simple_array (struct value *arr)
2201 {
2202   if (ada_is_array_descriptor_type (value_type (arr)))
2203     {
2204       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2205
2206       if (arrVal == NULL)
2207         error (_("Bounds unavailable for null array pointer."));
2208       return value_ind (arrVal);
2209     }
2210   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2211     return decode_constrained_packed_array (arr);
2212   else
2213     return arr;
2214 }
2215
2216 /* If TYPE represents a GNAT array type, return it translated to an
2217    ordinary GDB array type (possibly with BITSIZE fields indicating
2218    packing).  For other types, is the identity.  */
2219
2220 struct type *
2221 ada_coerce_to_simple_array_type (struct type *type)
2222 {
2223   if (ada_is_constrained_packed_array_type (type))
2224     return decode_constrained_packed_array_type (type);
2225
2226   if (ada_is_array_descriptor_type (type))
2227     return ada_check_typedef (desc_data_target_type (type));
2228
2229   return type;
2230 }
2231
2232 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
2233
2234 static int
2235 ada_is_gnat_encoded_packed_array_type  (struct type *type)
2236 {
2237   if (type == NULL)
2238     return 0;
2239   type = desc_base_type (type);
2240   type = ada_check_typedef (type);
2241   return
2242     ada_type_name (type) != NULL
2243     && strstr (ada_type_name (type), "___XP") != NULL;
2244 }
2245
2246 /* Non-zero iff TYPE represents a standard GNAT constrained
2247    packed-array type.  */
2248
2249 int
2250 ada_is_constrained_packed_array_type (struct type *type)
2251 {
2252   return ada_is_gnat_encoded_packed_array_type (type)
2253     && !ada_is_array_descriptor_type (type);
2254 }
2255
2256 /* Non-zero iff TYPE represents an array descriptor for a
2257    unconstrained packed-array type.  */
2258
2259 static int
2260 ada_is_unconstrained_packed_array_type (struct type *type)
2261 {
2262   if (!ada_is_array_descriptor_type (type))
2263     return 0;
2264
2265   if (ada_is_gnat_encoded_packed_array_type (type))
2266     return 1;
2267
2268   /* If we saw GNAT encodings, then the above code is sufficient.
2269      However, with minimal encodings, we will just have a thick
2270      pointer instead.  */
2271   if (is_thick_pntr (type))
2272     {
2273       type = desc_base_type (type);
2274       /* The structure's first field is a pointer to an array, so this
2275          fetches the array type.  */
2276       type = TYPE_TARGET_TYPE (type->field (0).type ());
2277       if (type->code () == TYPE_CODE_TYPEDEF)
2278         type = ada_typedef_target_type (type);
2279       /* Now we can see if the array elements are packed.  */
2280       return TYPE_FIELD_BITSIZE (type, 0) > 0;
2281     }
2282
2283   return 0;
2284 }
2285
2286 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2287    type, or if it is an ordinary (non-Gnat-encoded) packed array.  */
2288
2289 static bool
2290 ada_is_any_packed_array_type (struct type *type)
2291 {
2292   return (ada_is_constrained_packed_array_type (type)
2293           || (type->code () == TYPE_CODE_ARRAY
2294               && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
2295 }
2296
2297 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2298    return the size of its elements in bits.  */
2299
2300 static long
2301 decode_packed_array_bitsize (struct type *type)
2302 {
2303   const char *raw_name;
2304   const char *tail;
2305   long bits;
2306
2307   /* Access to arrays implemented as fat pointers are encoded as a typedef
2308      of the fat pointer type.  We need the name of the fat pointer type
2309      to do the decoding, so strip the typedef layer.  */
2310   if (type->code () == TYPE_CODE_TYPEDEF)
2311     type = ada_typedef_target_type (type);
2312
2313   raw_name = ada_type_name (ada_check_typedef (type));
2314   if (!raw_name)
2315     raw_name = ada_type_name (desc_base_type (type));
2316
2317   if (!raw_name)
2318     return 0;
2319
2320   tail = strstr (raw_name, "___XP");
2321   if (tail == nullptr)
2322     {
2323       gdb_assert (is_thick_pntr (type));
2324       /* The structure's first field is a pointer to an array, so this
2325          fetches the array type.  */
2326       type = TYPE_TARGET_TYPE (type->field (0).type ());
2327       /* Now we can see if the array elements are packed.  */
2328       return TYPE_FIELD_BITSIZE (type, 0);
2329     }
2330
2331   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2332     {
2333       lim_warning
2334         (_("could not understand bit size information on packed array"));
2335       return 0;
2336     }
2337
2338   return bits;
2339 }
2340
2341 /* Given that TYPE is a standard GDB array type with all bounds filled
2342    in, and that the element size of its ultimate scalar constituents
2343    (that is, either its elements, or, if it is an array of arrays, its
2344    elements' elements, etc.) is *ELT_BITS, return an identical type,
2345    but with the bit sizes of its elements (and those of any
2346    constituent arrays) recorded in the BITSIZE components of its
2347    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2348    in bits.
2349
2350    Note that, for arrays whose index type has an XA encoding where
2351    a bound references a record discriminant, getting that discriminant,
2352    and therefore the actual value of that bound, is not possible
2353    because none of the given parameters gives us access to the record.
2354    This function assumes that it is OK in the context where it is being
2355    used to return an array whose bounds are still dynamic and where
2356    the length is arbitrary.  */
2357
2358 static struct type *
2359 constrained_packed_array_type (struct type *type, long *elt_bits)
2360 {
2361   struct type *new_elt_type;
2362   struct type *new_type;
2363   struct type *index_type_desc;
2364   struct type *index_type;
2365   LONGEST low_bound, high_bound;
2366
2367   type = ada_check_typedef (type);
2368   if (type->code () != TYPE_CODE_ARRAY)
2369     return type;
2370
2371   index_type_desc = ada_find_parallel_type (type, "___XA");
2372   if (index_type_desc)
2373     index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2374                                       NULL);
2375   else
2376     index_type = type->index_type ();
2377
2378   new_type = alloc_type_copy (type);
2379   new_elt_type =
2380     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2381                                    elt_bits);
2382   create_array_type (new_type, new_elt_type, index_type);
2383   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2384   new_type->set_name (ada_type_name (type));
2385
2386   if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2387        && is_dynamic_type (check_typedef (index_type)))
2388       || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2389     low_bound = high_bound = 0;
2390   if (high_bound < low_bound)
2391     *elt_bits = TYPE_LENGTH (new_type) = 0;
2392   else
2393     {
2394       *elt_bits *= (high_bound - low_bound + 1);
2395       TYPE_LENGTH (new_type) =
2396         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2397     }
2398
2399   new_type->set_is_fixed_instance (true);
2400   return new_type;
2401 }
2402
2403 /* The array type encoded by TYPE, where
2404    ada_is_constrained_packed_array_type (TYPE).  */
2405
2406 static struct type *
2407 decode_constrained_packed_array_type (struct type *type)
2408 {
2409   const char *raw_name = ada_type_name (ada_check_typedef (type));
2410   char *name;
2411   const char *tail;
2412   struct type *shadow_type;
2413   long bits;
2414
2415   if (!raw_name)
2416     raw_name = ada_type_name (desc_base_type (type));
2417
2418   if (!raw_name)
2419     return NULL;
2420
2421   name = (char *) alloca (strlen (raw_name) + 1);
2422   tail = strstr (raw_name, "___XP");
2423   type = desc_base_type (type);
2424
2425   memcpy (name, raw_name, tail - raw_name);
2426   name[tail - raw_name] = '\000';
2427
2428   shadow_type = ada_find_parallel_type_with_name (type, name);
2429
2430   if (shadow_type == NULL)
2431     {
2432       lim_warning (_("could not find bounds information on packed array"));
2433       return NULL;
2434     }
2435   shadow_type = check_typedef (shadow_type);
2436
2437   if (shadow_type->code () != TYPE_CODE_ARRAY)
2438     {
2439       lim_warning (_("could not understand bounds "
2440                      "information on packed array"));
2441       return NULL;
2442     }
2443
2444   bits = decode_packed_array_bitsize (type);
2445   return constrained_packed_array_type (shadow_type, &bits);
2446 }
2447
2448 /* Helper function for decode_constrained_packed_array.  Set the field
2449    bitsize on a series of packed arrays.  Returns the number of
2450    elements in TYPE.  */
2451
2452 static LONGEST
2453 recursively_update_array_bitsize (struct type *type)
2454 {
2455   gdb_assert (type->code () == TYPE_CODE_ARRAY);
2456
2457   LONGEST low, high;
2458   if (!get_discrete_bounds (type->index_type (), &low, &high)
2459       || low > high)
2460     return 0;
2461   LONGEST our_len = high - low + 1;
2462
2463   struct type *elt_type = TYPE_TARGET_TYPE (type);
2464   if (elt_type->code () == TYPE_CODE_ARRAY)
2465     {
2466       LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2467       LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2468       TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2469
2470       TYPE_LENGTH (type) = ((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2471                             / HOST_CHAR_BIT);
2472     }
2473
2474   return our_len;
2475 }
2476
2477 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2478    array, returns a simple array that denotes that array.  Its type is a
2479    standard GDB array type except that the BITSIZEs of the array
2480    target types are set to the number of bits in each element, and the
2481    type length is set appropriately.  */
2482
2483 static struct value *
2484 decode_constrained_packed_array (struct value *arr)
2485 {
2486   struct type *type;
2487
2488   /* If our value is a pointer, then dereference it. Likewise if
2489      the value is a reference.  Make sure that this operation does not
2490      cause the target type to be fixed, as this would indirectly cause
2491      this array to be decoded.  The rest of the routine assumes that
2492      the array hasn't been decoded yet, so we use the basic "coerce_ref"
2493      and "value_ind" routines to perform the dereferencing, as opposed
2494      to using "ada_coerce_ref" or "ada_value_ind".  */
2495   arr = coerce_ref (arr);
2496   if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2497     arr = value_ind (arr);
2498
2499   type = decode_constrained_packed_array_type (value_type (arr));
2500   if (type == NULL)
2501     {
2502       error (_("can't unpack array"));
2503       return NULL;
2504     }
2505
2506   /* Decoding the packed array type could not correctly set the field
2507      bitsizes for any dimension except the innermost, because the
2508      bounds may be variable and were not passed to that function.  So,
2509      we further resolve the array bounds here and then update the
2510      sizes.  */
2511   const gdb_byte *valaddr = value_contents_for_printing (arr).data ();
2512   CORE_ADDR address = value_address (arr);
2513   gdb::array_view<const gdb_byte> view
2514     = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
2515   type = resolve_dynamic_type (type, view, address);
2516   recursively_update_array_bitsize (type);
2517
2518   if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2519       && ada_is_modular_type (value_type (arr)))
2520     {
2521        /* This is a (right-justified) modular type representing a packed
2522           array with no wrapper.  In order to interpret the value through
2523           the (left-justified) packed array type we just built, we must
2524           first left-justify it.  */
2525       int bit_size, bit_pos;
2526       ULONGEST mod;
2527
2528       mod = ada_modulus (value_type (arr)) - 1;
2529       bit_size = 0;
2530       while (mod > 0)
2531         {
2532           bit_size += 1;
2533           mod >>= 1;
2534         }
2535       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2536       arr = ada_value_primitive_packed_val (arr, NULL,
2537                                             bit_pos / HOST_CHAR_BIT,
2538                                             bit_pos % HOST_CHAR_BIT,
2539                                             bit_size,
2540                                             type);
2541     }
2542
2543   return coerce_unspec_val_to_type (arr, type);
2544 }
2545
2546
2547 /* The value of the element of packed array ARR at the ARITY indices
2548    given in IND.   ARR must be a simple array.  */
2549
2550 static struct value *
2551 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2552 {
2553   int i;
2554   int bits, elt_off, bit_off;
2555   long elt_total_bit_offset;
2556   struct type *elt_type;
2557   struct value *v;
2558
2559   bits = 0;
2560   elt_total_bit_offset = 0;
2561   elt_type = ada_check_typedef (value_type (arr));
2562   for (i = 0; i < arity; i += 1)
2563     {
2564       if (elt_type->code () != TYPE_CODE_ARRAY
2565           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2566         error
2567           (_("attempt to do packed indexing of "
2568              "something other than a packed array"));
2569       else
2570         {
2571           struct type *range_type = elt_type->index_type ();
2572           LONGEST lowerbound, upperbound;
2573           LONGEST idx;
2574
2575           if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2576             {
2577               lim_warning (_("don't know bounds of array"));
2578               lowerbound = upperbound = 0;
2579             }
2580
2581           idx = pos_atr (ind[i]);
2582           if (idx < lowerbound || idx > upperbound)
2583             lim_warning (_("packed array index %ld out of bounds"),
2584                          (long) idx);
2585           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2586           elt_total_bit_offset += (idx - lowerbound) * bits;
2587           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2588         }
2589     }
2590   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2591   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2592
2593   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2594                                       bits, elt_type);
2595   return v;
2596 }
2597
2598 /* Non-zero iff TYPE includes negative integer values.  */
2599
2600 static int
2601 has_negatives (struct type *type)
2602 {
2603   switch (type->code ())
2604     {
2605     default:
2606       return 0;
2607     case TYPE_CODE_INT:
2608       return !type->is_unsigned ();
2609     case TYPE_CODE_RANGE:
2610       return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2611     }
2612 }
2613
2614 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2615    unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
2616    the unpacked buffer.
2617
2618    The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2619    enough to contain at least BIT_OFFSET bits.  If not, an error is raised.
2620
2621    IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2622    zero otherwise.
2623
2624    IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2625
2626    IS_SCALAR is nonzero if the data corresponds to a signed type.  */
2627
2628 static void
2629 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2630                           gdb_byte *unpacked, int unpacked_len,
2631                           int is_big_endian, int is_signed_type,
2632                           int is_scalar)
2633 {
2634   int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2635   int src_idx;                  /* Index into the source area */
2636   int src_bytes_left;           /* Number of source bytes left to process.  */
2637   int srcBitsLeft;              /* Number of source bits left to move */
2638   int unusedLS;                 /* Number of bits in next significant
2639                                    byte of source that are unused */
2640
2641   int unpacked_idx;             /* Index into the unpacked buffer */
2642   int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */
2643
2644   unsigned long accum;          /* Staging area for bits being transferred */
2645   int accumSize;                /* Number of meaningful bits in accum */
2646   unsigned char sign;
2647
2648   /* Transmit bytes from least to most significant; delta is the direction
2649      the indices move.  */
2650   int delta = is_big_endian ? -1 : 1;
2651
2652   /* Make sure that unpacked is large enough to receive the BIT_SIZE
2653      bits from SRC.  .*/
2654   if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2655     error (_("Cannot unpack %d bits into buffer of %d bytes"),
2656            bit_size, unpacked_len);
2657
2658   srcBitsLeft = bit_size;
2659   src_bytes_left = src_len;
2660   unpacked_bytes_left = unpacked_len;
2661   sign = 0;
2662
2663   if (is_big_endian)
2664     {
2665       src_idx = src_len - 1;
2666       if (is_signed_type
2667           && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2668         sign = ~0;
2669
2670       unusedLS =
2671         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2672         % HOST_CHAR_BIT;
2673
2674       if (is_scalar)
2675         {
2676           accumSize = 0;
2677           unpacked_idx = unpacked_len - 1;
2678         }
2679       else
2680         {
2681           /* Non-scalar values must be aligned at a byte boundary...  */
2682           accumSize =
2683             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2684           /* ... And are placed at the beginning (most-significant) bytes
2685              of the target.  */
2686           unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2687           unpacked_bytes_left = unpacked_idx + 1;
2688         }
2689     }
2690   else
2691     {
2692       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2693
2694       src_idx = unpacked_idx = 0;
2695       unusedLS = bit_offset;
2696       accumSize = 0;
2697
2698       if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2699         sign = ~0;
2700     }
2701
2702   accum = 0;
2703   while (src_bytes_left > 0)
2704     {
2705       /* Mask for removing bits of the next source byte that are not
2706          part of the value.  */
2707       unsigned int unusedMSMask =
2708         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2709         1;
2710       /* Sign-extend bits for this byte.  */
2711       unsigned int signMask = sign & ~unusedMSMask;
2712
2713       accum |=
2714         (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2715       accumSize += HOST_CHAR_BIT - unusedLS;
2716       if (accumSize >= HOST_CHAR_BIT)
2717         {
2718           unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2719           accumSize -= HOST_CHAR_BIT;
2720           accum >>= HOST_CHAR_BIT;
2721           unpacked_bytes_left -= 1;
2722           unpacked_idx += delta;
2723         }
2724       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2725       unusedLS = 0;
2726       src_bytes_left -= 1;
2727       src_idx += delta;
2728     }
2729   while (unpacked_bytes_left > 0)
2730     {
2731       accum |= sign << accumSize;
2732       unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2733       accumSize -= HOST_CHAR_BIT;
2734       if (accumSize < 0)
2735         accumSize = 0;
2736       accum >>= HOST_CHAR_BIT;
2737       unpacked_bytes_left -= 1;
2738       unpacked_idx += delta;
2739     }
2740 }
2741
2742 /* Create a new value of type TYPE from the contents of OBJ starting
2743    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2744    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2745    assigning through the result will set the field fetched from.
2746    VALADDR is ignored unless OBJ is NULL, in which case,
2747    VALADDR+OFFSET must address the start of storage containing the 
2748    packed value.  The value returned  in this case is never an lval.
2749    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2750
2751 struct value *
2752 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2753                                 long offset, int bit_offset, int bit_size,
2754                                 struct type *type)
2755 {
2756   struct value *v;
2757   const gdb_byte *src;                /* First byte containing data to unpack */
2758   gdb_byte *unpacked;
2759   const int is_scalar = is_scalar_type (type);
2760   const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2761   gdb::byte_vector staging;
2762
2763   type = ada_check_typedef (type);
2764
2765   if (obj == NULL)
2766     src = valaddr + offset;
2767   else
2768     src = value_contents (obj).data () + offset;
2769
2770   if (is_dynamic_type (type))
2771     {
2772       /* The length of TYPE might by dynamic, so we need to resolve
2773          TYPE in order to know its actual size, which we then use
2774          to create the contents buffer of the value we return.
2775          The difficulty is that the data containing our object is
2776          packed, and therefore maybe not at a byte boundary.  So, what
2777          we do, is unpack the data into a byte-aligned buffer, and then
2778          use that buffer as our object's value for resolving the type.  */
2779       int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2780       staging.resize (staging_len);
2781
2782       ada_unpack_from_contents (src, bit_offset, bit_size,
2783                                 staging.data (), staging.size (),
2784                                 is_big_endian, has_negatives (type),
2785                                 is_scalar);
2786       type = resolve_dynamic_type (type, staging, 0);
2787       if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2788         {
2789           /* This happens when the length of the object is dynamic,
2790              and is actually smaller than the space reserved for it.
2791              For instance, in an array of variant records, the bit_size
2792              we're given is the array stride, which is constant and
2793              normally equal to the maximum size of its element.
2794              But, in reality, each element only actually spans a portion
2795              of that stride.  */
2796           bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2797         }
2798     }
2799
2800   if (obj == NULL)
2801     {
2802       v = allocate_value (type);
2803       src = valaddr + offset;
2804     }
2805   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2806     {
2807       int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2808       gdb_byte *buf;
2809
2810       v = value_at (type, value_address (obj) + offset);
2811       buf = (gdb_byte *) alloca (src_len);
2812       read_memory (value_address (v), buf, src_len);
2813       src = buf;
2814     }
2815   else
2816     {
2817       v = allocate_value (type);
2818       src = value_contents (obj).data () + offset;
2819     }
2820
2821   if (obj != NULL)
2822     {
2823       long new_offset = offset;
2824
2825       set_value_component_location (v, obj);
2826       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2827       set_value_bitsize (v, bit_size);
2828       if (value_bitpos (v) >= HOST_CHAR_BIT)
2829         {
2830           ++new_offset;
2831           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2832         }
2833       set_value_offset (v, new_offset);
2834
2835       /* Also set the parent value.  This is needed when trying to
2836          assign a new value (in inferior memory).  */
2837       set_value_parent (v, obj);
2838     }
2839   else
2840     set_value_bitsize (v, bit_size);
2841   unpacked = value_contents_writeable (v).data ();
2842
2843   if (bit_size == 0)
2844     {
2845       memset (unpacked, 0, TYPE_LENGTH (type));
2846       return v;
2847     }
2848
2849   if (staging.size () == TYPE_LENGTH (type))
2850     {
2851       /* Small short-cut: If we've unpacked the data into a buffer
2852          of the same size as TYPE's length, then we can reuse that,
2853          instead of doing the unpacking again.  */
2854       memcpy (unpacked, staging.data (), staging.size ());
2855     }
2856   else
2857     ada_unpack_from_contents (src, bit_offset, bit_size,
2858                               unpacked, TYPE_LENGTH (type),
2859                               is_big_endian, has_negatives (type), is_scalar);
2860
2861   return v;
2862 }
2863
2864 /* Store the contents of FROMVAL into the location of TOVAL.
2865    Return a new value with the location of TOVAL and contents of
2866    FROMVAL.   Handles assignment into packed fields that have
2867    floating-point or non-scalar types.  */
2868
2869 static struct value *
2870 ada_value_assign (struct value *toval, struct value *fromval)
2871 {
2872   struct type *type = value_type (toval);
2873   int bits = value_bitsize (toval);
2874
2875   toval = ada_coerce_ref (toval);
2876   fromval = ada_coerce_ref (fromval);
2877
2878   if (ada_is_direct_array_type (value_type (toval)))
2879     toval = ada_coerce_to_simple_array (toval);
2880   if (ada_is_direct_array_type (value_type (fromval)))
2881     fromval = ada_coerce_to_simple_array (fromval);
2882
2883   if (!deprecated_value_modifiable (toval))
2884     error (_("Left operand of assignment is not a modifiable lvalue."));
2885
2886   if (VALUE_LVAL (toval) == lval_memory
2887       && bits > 0
2888       && (type->code () == TYPE_CODE_FLT
2889           || type->code () == TYPE_CODE_STRUCT))
2890     {
2891       int len = (value_bitpos (toval)
2892                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2893       int from_size;
2894       gdb_byte *buffer = (gdb_byte *) alloca (len);
2895       struct value *val;
2896       CORE_ADDR to_addr = value_address (toval);
2897
2898       if (type->code () == TYPE_CODE_FLT)
2899         fromval = value_cast (type, fromval);
2900
2901       read_memory (to_addr, buffer, len);
2902       from_size = value_bitsize (fromval);
2903       if (from_size == 0)
2904         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2905
2906       const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2907       ULONGEST from_offset = 0;
2908       if (is_big_endian && is_scalar_type (value_type (fromval)))
2909         from_offset = from_size - bits;
2910       copy_bitwise (buffer, value_bitpos (toval),
2911                     value_contents (fromval).data (), from_offset,
2912                     bits, is_big_endian);
2913       write_memory_with_notification (to_addr, buffer, len);
2914
2915       val = value_copy (toval);
2916       memcpy (value_contents_raw (val).data (),
2917               value_contents (fromval).data (),
2918               TYPE_LENGTH (type));
2919       deprecated_set_value_type (val, type);
2920
2921       return val;
2922     }
2923
2924   return value_assign (toval, fromval);
2925 }
2926
2927
2928 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2929    CONTAINER, assign the contents of VAL to COMPONENTS's place in
2930    CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2931    COMPONENT, and not the inferior's memory.  The current contents
2932    of COMPONENT are ignored.
2933
2934    Although not part of the initial design, this function also works
2935    when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2936    had a null address, and COMPONENT had an address which is equal to
2937    its offset inside CONTAINER.  */
2938
2939 static void
2940 value_assign_to_component (struct value *container, struct value *component,
2941                            struct value *val)
2942 {
2943   LONGEST offset_in_container =
2944     (LONGEST)  (value_address (component) - value_address (container));
2945   int bit_offset_in_container =
2946     value_bitpos (component) - value_bitpos (container);
2947   int bits;
2948
2949   val = value_cast (value_type (component), val);
2950
2951   if (value_bitsize (component) == 0)
2952     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2953   else
2954     bits = value_bitsize (component);
2955
2956   if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2957     {
2958       int src_offset;
2959
2960       if (is_scalar_type (check_typedef (value_type (component))))
2961         src_offset
2962           = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2963       else
2964         src_offset = 0;
2965       copy_bitwise ((value_contents_writeable (container).data ()
2966                      + offset_in_container),
2967                     value_bitpos (container) + bit_offset_in_container,
2968                     value_contents (val).data (), src_offset, bits, 1);
2969     }
2970   else
2971     copy_bitwise ((value_contents_writeable (container).data ()
2972                    + offset_in_container),
2973                   value_bitpos (container) + bit_offset_in_container,
2974                   value_contents (val).data (), 0, bits, 0);
2975 }
2976
2977 /* Determine if TYPE is an access to an unconstrained array.  */
2978
2979 bool
2980 ada_is_access_to_unconstrained_array (struct type *type)
2981 {
2982   return (type->code () == TYPE_CODE_TYPEDEF
2983           && is_thick_pntr (ada_typedef_target_type (type)));
2984 }
2985
2986 /* The value of the element of array ARR at the ARITY indices given in IND.
2987    ARR may be either a simple array, GNAT array descriptor, or pointer
2988    thereto.  */
2989
2990 struct value *
2991 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2992 {
2993   int k;
2994   struct value *elt;
2995   struct type *elt_type;
2996
2997   elt = ada_coerce_to_simple_array (arr);
2998
2999   elt_type = ada_check_typedef (value_type (elt));
3000   if (elt_type->code () == TYPE_CODE_ARRAY
3001       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
3002     return value_subscript_packed (elt, arity, ind);
3003
3004   for (k = 0; k < arity; k += 1)
3005     {
3006       struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
3007
3008       if (elt_type->code () != TYPE_CODE_ARRAY)
3009         error (_("too many subscripts (%d expected)"), k);
3010
3011       elt = value_subscript (elt, pos_atr (ind[k]));
3012
3013       if (ada_is_access_to_unconstrained_array (saved_elt_type)
3014           && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
3015         {
3016           /* The element is a typedef to an unconstrained array,
3017              except that the value_subscript call stripped the
3018              typedef layer.  The typedef layer is GNAT's way to
3019              specify that the element is, at the source level, an
3020              access to the unconstrained array, rather than the
3021              unconstrained array.  So, we need to restore that
3022              typedef layer, which we can do by forcing the element's
3023              type back to its original type. Otherwise, the returned
3024              value is going to be printed as the array, rather
3025              than as an access.  Another symptom of the same issue
3026              would be that an expression trying to dereference the
3027              element would also be improperly rejected.  */
3028           deprecated_set_value_type (elt, saved_elt_type);
3029         }
3030
3031       elt_type = ada_check_typedef (value_type (elt));
3032     }
3033
3034   return elt;
3035 }
3036
3037 /* Assuming ARR is a pointer to a GDB array, the value of the element
3038    of *ARR at the ARITY indices given in IND.
3039    Does not read the entire array into memory.
3040
3041    Note: Unlike what one would expect, this function is used instead of
3042    ada_value_subscript for basically all non-packed array types.  The reason
3043    for this is that a side effect of doing our own pointer arithmetics instead
3044    of relying on value_subscript is that there is no implicit typedef peeling.
3045    This is important for arrays of array accesses, where it allows us to
3046    preserve the fact that the array's element is an array access, where the
3047    access part os encoded in a typedef layer.  */
3048
3049 static struct value *
3050 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
3051 {
3052   int k;
3053   struct value *array_ind = ada_value_ind (arr);
3054   struct type *type
3055     = check_typedef (value_enclosing_type (array_ind));
3056
3057   if (type->code () == TYPE_CODE_ARRAY
3058       && TYPE_FIELD_BITSIZE (type, 0) > 0)
3059     return value_subscript_packed (array_ind, arity, ind);
3060
3061   for (k = 0; k < arity; k += 1)
3062     {
3063       LONGEST lwb, upb;
3064
3065       if (type->code () != TYPE_CODE_ARRAY)
3066         error (_("too many subscripts (%d expected)"), k);
3067       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
3068                         value_copy (arr));
3069       get_discrete_bounds (type->index_type (), &lwb, &upb);
3070       arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
3071       type = TYPE_TARGET_TYPE (type);
3072     }
3073
3074   return value_ind (arr);
3075 }
3076
3077 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
3078    actual type of ARRAY_PTR is ignored), returns the Ada slice of
3079    HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
3080    this array is LOW, as per Ada rules.  */
3081 static struct value *
3082 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
3083                           int low, int high)
3084 {
3085   struct type *type0 = ada_check_typedef (type);
3086   struct type *base_index_type = TYPE_TARGET_TYPE (type0->index_type ());
3087   struct type *index_type
3088     = create_static_range_type (NULL, base_index_type, low, high);
3089   struct type *slice_type = create_array_type_with_stride
3090                               (NULL, TYPE_TARGET_TYPE (type0), index_type,
3091                                type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
3092                                TYPE_FIELD_BITSIZE (type0, 0));
3093   int base_low =  ada_discrete_type_low_bound (type0->index_type ());
3094   gdb::optional<LONGEST> base_low_pos, low_pos;
3095   CORE_ADDR base;
3096
3097   low_pos = discrete_position (base_index_type, low);
3098   base_low_pos = discrete_position (base_index_type, base_low);
3099
3100   if (!low_pos.has_value () || !base_low_pos.has_value ())
3101     {
3102       warning (_("unable to get positions in slice, use bounds instead"));
3103       low_pos = low;
3104       base_low_pos = base_low;
3105     }
3106
3107   ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
3108   if (stride == 0)
3109     stride = TYPE_LENGTH (TYPE_TARGET_TYPE (type0));
3110
3111   base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
3112   return value_at_lazy (slice_type, base);
3113 }
3114
3115
3116 static struct value *
3117 ada_value_slice (struct value *array, int low, int high)
3118 {
3119   struct type *type = ada_check_typedef (value_type (array));
3120   struct type *base_index_type = TYPE_TARGET_TYPE (type->index_type ());
3121   struct type *index_type
3122     = create_static_range_type (NULL, type->index_type (), low, high);
3123   struct type *slice_type = create_array_type_with_stride
3124                               (NULL, TYPE_TARGET_TYPE (type), index_type,
3125                                type->dyn_prop (DYN_PROP_BYTE_STRIDE),
3126                                TYPE_FIELD_BITSIZE (type, 0));
3127   gdb::optional<LONGEST> low_pos, high_pos;
3128
3129
3130   low_pos = discrete_position (base_index_type, low);
3131   high_pos = discrete_position (base_index_type, high);
3132
3133   if (!low_pos.has_value () || !high_pos.has_value ())
3134     {
3135       warning (_("unable to get positions in slice, use bounds instead"));
3136       low_pos = low;
3137       high_pos = high;
3138     }
3139
3140   return value_cast (slice_type,
3141                      value_slice (array, low, *high_pos - *low_pos + 1));
3142 }
3143
3144 /* If type is a record type in the form of a standard GNAT array
3145    descriptor, returns the number of dimensions for type.  If arr is a
3146    simple array, returns the number of "array of"s that prefix its
3147    type designation.  Otherwise, returns 0.  */
3148
3149 int
3150 ada_array_arity (struct type *type)
3151 {
3152   int arity;
3153
3154   if (type == NULL)
3155     return 0;
3156
3157   type = desc_base_type (type);
3158
3159   arity = 0;
3160   if (type->code () == TYPE_CODE_STRUCT)
3161     return desc_arity (desc_bounds_type (type));
3162   else
3163     while (type->code () == TYPE_CODE_ARRAY)
3164       {
3165         arity += 1;
3166         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
3167       }
3168
3169   return arity;
3170 }
3171
3172 /* If TYPE is a record type in the form of a standard GNAT array
3173    descriptor or a simple array type, returns the element type for
3174    TYPE after indexing by NINDICES indices, or by all indices if
3175    NINDICES is -1.  Otherwise, returns NULL.  */
3176
3177 struct type *
3178 ada_array_element_type (struct type *type, int nindices)
3179 {
3180   type = desc_base_type (type);
3181
3182   if (type->code () == TYPE_CODE_STRUCT)
3183     {
3184       int k;
3185       struct type *p_array_type;
3186
3187       p_array_type = desc_data_target_type (type);
3188
3189       k = ada_array_arity (type);
3190       if (k == 0)
3191         return NULL;
3192
3193       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
3194       if (nindices >= 0 && k > nindices)
3195         k = nindices;
3196       while (k > 0 && p_array_type != NULL)
3197         {
3198           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
3199           k -= 1;
3200         }
3201       return p_array_type;
3202     }
3203   else if (type->code () == TYPE_CODE_ARRAY)
3204     {
3205       while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
3206         {
3207           type = TYPE_TARGET_TYPE (type);
3208           nindices -= 1;
3209         }
3210       return type;
3211     }
3212
3213   return NULL;
3214 }
3215
3216 /* See ada-lang.h.  */
3217
3218 struct type *
3219 ada_index_type (struct type *type, int n, const char *name)
3220 {
3221   struct type *result_type;
3222
3223   type = desc_base_type (type);
3224
3225   if (n < 0 || n > ada_array_arity (type))
3226     error (_("invalid dimension number to '%s"), name);
3227
3228   if (ada_is_simple_array_type (type))
3229     {
3230       int i;
3231
3232       for (i = 1; i < n; i += 1)
3233         {
3234           type = ada_check_typedef (type);
3235           type = TYPE_TARGET_TYPE (type);
3236         }
3237       result_type = TYPE_TARGET_TYPE (ada_check_typedef (type)->index_type ());
3238       /* FIXME: The stabs type r(0,0);bound;bound in an array type
3239          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
3240          perhaps stabsread.c would make more sense.  */
3241       if (result_type && result_type->code () == TYPE_CODE_UNDEF)
3242         result_type = NULL;
3243     }
3244   else
3245     {
3246       result_type = desc_index_type (desc_bounds_type (type), n);
3247       if (result_type == NULL)
3248         error (_("attempt to take bound of something that is not an array"));
3249     }
3250
3251   return result_type;
3252 }
3253
3254 /* Given that arr is an array type, returns the lower bound of the
3255    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3256    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
3257    array-descriptor type.  It works for other arrays with bounds supplied
3258    by run-time quantities other than discriminants.  */
3259
3260 static LONGEST
3261 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3262 {
3263   struct type *type, *index_type_desc, *index_type;
3264   int i;
3265
3266   gdb_assert (which == 0 || which == 1);
3267
3268   if (ada_is_constrained_packed_array_type (arr_type))
3269     arr_type = decode_constrained_packed_array_type (arr_type);
3270
3271   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3272     return (LONGEST) - which;
3273
3274   if (arr_type->code () == TYPE_CODE_PTR)
3275     type = TYPE_TARGET_TYPE (arr_type);
3276   else
3277     type = arr_type;
3278
3279   if (type->is_fixed_instance ())
3280     {
3281       /* The array has already been fixed, so we do not need to
3282          check the parallel ___XA type again.  That encoding has
3283          already been applied, so ignore it now.  */
3284       index_type_desc = NULL;
3285     }
3286   else
3287     {
3288       index_type_desc = ada_find_parallel_type (type, "___XA");
3289       ada_fixup_array_indexes_type (index_type_desc);
3290     }
3291
3292   if (index_type_desc != NULL)
3293     index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
3294                                       NULL);
3295   else
3296     {
3297       struct type *elt_type = check_typedef (type);
3298
3299       for (i = 1; i < n; i++)
3300         elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3301
3302       index_type = elt_type->index_type ();
3303     }
3304
3305   return
3306     (LONGEST) (which == 0
3307                ? ada_discrete_type_low_bound (index_type)
3308                : ada_discrete_type_high_bound (index_type));
3309 }
3310
3311 /* Given that arr is an array value, returns the lower bound of the
3312    nth index (numbering from 1) if WHICH is 0, and the upper bound if
3313    WHICH is 1.  This routine will also work for arrays with bounds
3314    supplied by run-time quantities other than discriminants.  */
3315
3316 static LONGEST
3317 ada_array_bound (struct value *arr, int n, int which)
3318 {
3319   struct type *arr_type;
3320
3321   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3322     arr = value_ind (arr);
3323   arr_type = value_enclosing_type (arr);
3324
3325   if (ada_is_constrained_packed_array_type (arr_type))
3326     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3327   else if (ada_is_simple_array_type (arr_type))
3328     return ada_array_bound_from_type (arr_type, n, which);
3329   else
3330     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3331 }
3332
3333 /* Given that arr is an array value, returns the length of the
3334    nth index.  This routine will also work for arrays with bounds
3335    supplied by run-time quantities other than discriminants.
3336    Does not work for arrays indexed by enumeration types with representation
3337    clauses at the moment.  */
3338
3339 static LONGEST
3340 ada_array_length (struct value *arr, int n)
3341 {
3342   struct type *arr_type, *index_type;
3343   int low, high;
3344
3345   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3346     arr = value_ind (arr);
3347   arr_type = value_enclosing_type (arr);
3348
3349   if (ada_is_constrained_packed_array_type (arr_type))
3350     return ada_array_length (decode_constrained_packed_array (arr), n);
3351
3352   if (ada_is_simple_array_type (arr_type))
3353     {
3354       low = ada_array_bound_from_type (arr_type, n, 0);
3355       high = ada_array_bound_from_type (arr_type, n, 1);
3356     }
3357   else
3358     {
3359       low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3360       high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3361     }
3362
3363   arr_type = check_typedef (arr_type);
3364   index_type = ada_index_type (arr_type, n, "length");
3365   if (index_type != NULL)
3366     {
3367       struct type *base_type;
3368       if (index_type->code () == TYPE_CODE_RANGE)
3369         base_type = TYPE_TARGET_TYPE (index_type);
3370       else
3371         base_type = index_type;
3372
3373       low = pos_atr (value_from_longest (base_type, low));
3374       high = pos_atr (value_from_longest (base_type, high));
3375     }
3376   return high - low + 1;
3377 }
3378
3379 /* An array whose type is that of ARR_TYPE (an array type), with
3380    bounds LOW to HIGH, but whose contents are unimportant.  If HIGH is
3381    less than LOW, then LOW-1 is used.  */
3382
3383 static struct value *
3384 empty_array (struct type *arr_type, int low, int high)
3385 {
3386   struct type *arr_type0 = ada_check_typedef (arr_type);
3387   struct type *index_type
3388     = create_static_range_type
3389         (NULL, TYPE_TARGET_TYPE (arr_type0->index_type ()), low,
3390          high < low ? low - 1 : high);
3391   struct type *elt_type = ada_array_element_type (arr_type0, 1);
3392
3393   return allocate_value (create_array_type (NULL, elt_type, index_type));
3394 }
3395 \f
3396
3397                                 /* Name resolution */
3398
3399 /* The "decoded" name for the user-definable Ada operator corresponding
3400    to OP.  */
3401
3402 static const char *
3403 ada_decoded_op_name (enum exp_opcode op)
3404 {
3405   int i;
3406
3407   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3408     {
3409       if (ada_opname_table[i].op == op)
3410         return ada_opname_table[i].decoded;
3411     }
3412   error (_("Could not find operator name for opcode"));
3413 }
3414
3415 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3416    in a listing of choices during disambiguation (see sort_choices, below).
3417    The idea is that overloadings of a subprogram name from the
3418    same package should sort in their source order.  We settle for ordering
3419    such symbols by their trailing number (__N  or $N).  */
3420
3421 static int
3422 encoded_ordered_before (const char *N0, const char *N1)
3423 {
3424   if (N1 == NULL)
3425     return 0;
3426   else if (N0 == NULL)
3427     return 1;
3428   else
3429     {
3430       int k0, k1;
3431
3432       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3433         ;
3434       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3435         ;
3436       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3437           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3438         {
3439           int n0, n1;
3440
3441           n0 = k0;
3442           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3443             n0 -= 1;
3444           n1 = k1;
3445           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3446             n1 -= 1;
3447           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3448             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3449         }
3450       return (strcmp (N0, N1) < 0);
3451     }
3452 }
3453
3454 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3455    encoded names.  */
3456
3457 static void
3458 sort_choices (struct block_symbol syms[], int nsyms)
3459 {
3460   int i;
3461
3462   for (i = 1; i < nsyms; i += 1)
3463     {
3464       struct block_symbol sym = syms[i];
3465       int j;
3466
3467       for (j = i - 1; j >= 0; j -= 1)
3468         {
3469           if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3470                                       sym.symbol->linkage_name ()))
3471             break;
3472           syms[j + 1] = syms[j];
3473         }
3474       syms[j + 1] = sym;
3475     }
3476 }
3477
3478 /* Whether GDB should display formals and return types for functions in the
3479    overloads selection menu.  */
3480 static bool print_signatures = true;
3481
3482 /* Print the signature for SYM on STREAM according to the FLAGS options.  For
3483    all but functions, the signature is just the name of the symbol.  For
3484    functions, this is the name of the function, the list of types for formals
3485    and the return type (if any).  */
3486
3487 static void
3488 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3489                             const struct type_print_options *flags)
3490 {
3491   struct type *type = sym->type ();
3492
3493   gdb_printf (stream, "%s", sym->print_name ());
3494   if (!print_signatures
3495       || type == NULL
3496       || type->code () != TYPE_CODE_FUNC)
3497     return;
3498
3499   if (type->num_fields () > 0)
3500     {
3501       int i;
3502
3503       gdb_printf (stream, " (");
3504       for (i = 0; i < type->num_fields (); ++i)
3505         {
3506           if (i > 0)
3507             gdb_printf (stream, "; ");
3508           ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3509                           flags);
3510         }
3511       gdb_printf (stream, ")");
3512     }
3513   if (TYPE_TARGET_TYPE (type) != NULL
3514       && TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_VOID)
3515     {
3516       gdb_printf (stream, " return ");
3517       ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3518     }
3519 }
3520
3521 /* Read and validate a set of numeric choices from the user in the
3522    range 0 .. N_CHOICES-1.  Place the results in increasing
3523    order in CHOICES[0 .. N-1], and return N.
3524
3525    The user types choices as a sequence of numbers on one line
3526    separated by blanks, encoding them as follows:
3527
3528      + A choice of 0 means to cancel the selection, throwing an error.
3529      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3530      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3531
3532    The user is not allowed to choose more than MAX_RESULTS values.
3533
3534    ANNOTATION_SUFFIX, if present, is used to annotate the input
3535    prompts (for use with the -f switch).  */
3536
3537 static int
3538 get_selections (int *choices, int n_choices, int max_results,
3539                 int is_all_choice, const char *annotation_suffix)
3540 {
3541   const char *args;
3542   const char *prompt;
3543   int n_chosen;
3544   int first_choice = is_all_choice ? 2 : 1;
3545
3546   prompt = getenv ("PS2");
3547   if (prompt == NULL)
3548     prompt = "> ";
3549
3550   args = command_line_input (prompt, annotation_suffix);
3551
3552   if (args == NULL)
3553     error_no_arg (_("one or more choice numbers"));
3554
3555   n_chosen = 0;
3556
3557   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3558      order, as given in args.  Choices are validated.  */
3559   while (1)
3560     {
3561       char *args2;
3562       int choice, j;
3563
3564       args = skip_spaces (args);
3565       if (*args == '\0' && n_chosen == 0)
3566         error_no_arg (_("one or more choice numbers"));
3567       else if (*args == '\0')
3568         break;
3569
3570       choice = strtol (args, &args2, 10);
3571       if (args == args2 || choice < 0
3572           || choice > n_choices + first_choice - 1)
3573         error (_("Argument must be choice number"));
3574       args = args2;
3575
3576       if (choice == 0)
3577         error (_("cancelled"));
3578
3579       if (choice < first_choice)
3580         {
3581           n_chosen = n_choices;
3582           for (j = 0; j < n_choices; j += 1)
3583             choices[j] = j;
3584           break;
3585         }
3586       choice -= first_choice;
3587
3588       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3589         {
3590         }
3591
3592       if (j < 0 || choice != choices[j])
3593         {
3594           int k;
3595
3596           for (k = n_chosen - 1; k > j; k -= 1)
3597             choices[k + 1] = choices[k];
3598           choices[j + 1] = choice;
3599           n_chosen += 1;
3600         }
3601     }
3602
3603   if (n_chosen > max_results)
3604     error (_("Select no more than %d of the above"), max_results);
3605
3606   return n_chosen;
3607 }
3608
3609 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3610    by asking the user (if necessary), returning the number selected,
3611    and setting the first elements of SYMS items.  Error if no symbols
3612    selected.  */
3613
3614 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3615    to be re-integrated one of these days.  */
3616
3617 static int
3618 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3619 {
3620   int i;
3621   int *chosen = XALLOCAVEC (int , nsyms);
3622   int n_chosen;
3623   int first_choice = (max_results == 1) ? 1 : 2;
3624   const char *select_mode = multiple_symbols_select_mode ();
3625
3626   if (max_results < 1)
3627     error (_("Request to select 0 symbols!"));
3628   if (nsyms <= 1)
3629     return nsyms;
3630
3631   if (select_mode == multiple_symbols_cancel)
3632     error (_("\
3633 canceled because the command is ambiguous\n\
3634 See set/show multiple-symbol."));
3635
3636   /* If select_mode is "all", then return all possible symbols.
3637      Only do that if more than one symbol can be selected, of course.
3638      Otherwise, display the menu as usual.  */
3639   if (select_mode == multiple_symbols_all && max_results > 1)
3640     return nsyms;
3641
3642   gdb_printf (_("[0] cancel\n"));
3643   if (max_results > 1)
3644     gdb_printf (_("[1] all\n"));
3645
3646   sort_choices (syms, nsyms);
3647
3648   for (i = 0; i < nsyms; i += 1)
3649     {
3650       if (syms[i].symbol == NULL)
3651         continue;
3652
3653       if (syms[i].symbol->aclass () == LOC_BLOCK)
3654         {
3655           struct symtab_and_line sal =
3656             find_function_start_sal (syms[i].symbol, 1);
3657
3658           gdb_printf ("[%d] ", i + first_choice);
3659           ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3660                                       &type_print_raw_options);
3661           if (sal.symtab == NULL)
3662             gdb_printf (_(" at %p[<no source file available>%p]:%d\n"),
3663                         metadata_style.style ().ptr (), nullptr, sal.line);
3664           else
3665             gdb_printf
3666               (_(" at %ps:%d\n"),
3667                styled_string (file_name_style.style (),
3668                               symtab_to_filename_for_display (sal.symtab)),
3669                sal.line);
3670           continue;
3671         }
3672       else
3673         {
3674           int is_enumeral =
3675             (syms[i].symbol->aclass () == LOC_CONST
3676              && syms[i].symbol->type () != NULL
3677              && syms[i].symbol->type ()->code () == TYPE_CODE_ENUM);
3678           struct symtab *symtab = NULL;
3679
3680           if (syms[i].symbol->is_objfile_owned ())
3681             symtab = symbol_symtab (syms[i].symbol);
3682
3683           if (syms[i].symbol->line () != 0 && symtab != NULL)
3684             {
3685               gdb_printf ("[%d] ", i + first_choice);
3686               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3687                                           &type_print_raw_options);
3688               gdb_printf (_(" at %s:%d\n"),
3689                           symtab_to_filename_for_display (symtab),
3690                           syms[i].symbol->line ());
3691             }
3692           else if (is_enumeral
3693                    && syms[i].symbol->type ()->name () != NULL)
3694             {
3695               gdb_printf (("[%d] "), i + first_choice);
3696               ada_print_type (syms[i].symbol->type (), NULL,
3697                               gdb_stdout, -1, 0, &type_print_raw_options);
3698               gdb_printf (_("'(%s) (enumeral)\n"),
3699                           syms[i].symbol->print_name ());
3700             }
3701           else
3702             {
3703               gdb_printf ("[%d] ", i + first_choice);
3704               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3705                                           &type_print_raw_options);
3706
3707               if (symtab != NULL)
3708                 gdb_printf (is_enumeral
3709                             ? _(" in %s (enumeral)\n")
3710                             : _(" at %s:?\n"),
3711                             symtab_to_filename_for_display (symtab));
3712               else
3713                 gdb_printf (is_enumeral
3714                             ? _(" (enumeral)\n")
3715                             : _(" at ?\n"));
3716             }
3717         }
3718     }
3719
3720   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3721                              "overload-choice");
3722
3723   for (i = 0; i < n_chosen; i += 1)
3724     syms[i] = syms[chosen[i]];
3725
3726   return n_chosen;
3727 }
3728
3729 /* See ada-lang.h.  */
3730
3731 block_symbol
3732 ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
3733                           int nargs, value *argvec[])
3734 {
3735   if (possible_user_operator_p (op, argvec))
3736     {
3737       std::vector<struct block_symbol> candidates
3738         = ada_lookup_symbol_list (ada_decoded_op_name (op),
3739                                   NULL, VAR_DOMAIN);
3740
3741       int i = ada_resolve_function (candidates, argvec,
3742                                     nargs, ada_decoded_op_name (op), NULL,
3743                                     parse_completion);
3744       if (i >= 0)
3745         return candidates[i];
3746     }
3747   return {};
3748 }
3749
3750 /* See ada-lang.h.  */
3751
3752 block_symbol
3753 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3754                      struct type *context_type,
3755                      bool parse_completion,
3756                      int nargs, value *argvec[],
3757                      innermost_block_tracker *tracker)
3758 {
3759   std::vector<struct block_symbol> candidates
3760     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3761
3762   int i;
3763   if (candidates.size () == 1)
3764     i = 0;
3765   else
3766     {
3767       i = ada_resolve_function
3768         (candidates,
3769          argvec, nargs,
3770          sym->linkage_name (),
3771          context_type, parse_completion);
3772       if (i < 0)
3773         error (_("Could not find a match for %s"), sym->print_name ());
3774     }
3775
3776   tracker->update (candidates[i]);
3777   return candidates[i];
3778 }
3779
3780 /* Resolve a mention of a name where the context type is an
3781    enumeration type.  */
3782
3783 static int
3784 ada_resolve_enum (std::vector<struct block_symbol> &syms,
3785                   const char *name, struct type *context_type,
3786                   bool parse_completion)
3787 {
3788   gdb_assert (context_type->code () == TYPE_CODE_ENUM);
3789   context_type = ada_check_typedef (context_type);
3790
3791   for (int i = 0; i < syms.size (); ++i)
3792     {
3793       /* We already know the name matches, so we're just looking for
3794          an element of the correct enum type.  */
3795       if (ada_check_typedef (syms[i].symbol->type ()) == context_type)
3796         return i;
3797     }
3798
3799   error (_("No name '%s' in enumeration type '%s'"), name,
3800          ada_type_name (context_type));
3801 }
3802
3803 /* See ada-lang.h.  */
3804
3805 block_symbol
3806 ada_resolve_variable (struct symbol *sym, const struct block *block,
3807                       struct type *context_type,
3808                       bool parse_completion,
3809                       int deprocedure_p,
3810                       innermost_block_tracker *tracker)
3811 {
3812   std::vector<struct block_symbol> candidates
3813     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3814
3815   if (std::any_of (candidates.begin (),
3816                    candidates.end (),
3817                    [] (block_symbol &bsym)
3818                    {
3819                      switch (bsym.symbol->aclass ())
3820                        {
3821                        case LOC_REGISTER:
3822                        case LOC_ARG:
3823                        case LOC_REF_ARG:
3824                        case LOC_REGPARM_ADDR:
3825                        case LOC_LOCAL:
3826                        case LOC_COMPUTED:
3827                          return true;
3828                        default:
3829                          return false;
3830                        }
3831                    }))
3832     {
3833       /* Types tend to get re-introduced locally, so if there
3834          are any local symbols that are not types, first filter
3835          out all types.  */
3836       candidates.erase
3837         (std::remove_if
3838          (candidates.begin (),
3839           candidates.end (),
3840           [] (block_symbol &bsym)
3841           {
3842             return bsym.symbol->aclass () == LOC_TYPEDEF;
3843           }),
3844          candidates.end ());
3845     }
3846
3847   /* Filter out artificial symbols.  */
3848   candidates.erase
3849     (std::remove_if
3850      (candidates.begin (),
3851       candidates.end (),
3852       [] (block_symbol &bsym)
3853       {
3854        return bsym.symbol->artificial;
3855       }),
3856      candidates.end ());
3857
3858   int i;
3859   if (candidates.empty ())
3860     error (_("No definition found for %s"), sym->print_name ());
3861   else if (candidates.size () == 1)
3862     i = 0;
3863   else if (context_type != nullptr
3864            && context_type->code () == TYPE_CODE_ENUM)
3865     i = ada_resolve_enum (candidates, sym->linkage_name (), context_type,
3866                           parse_completion);
3867   else if (deprocedure_p && !is_nonfunction (candidates))
3868     {
3869       i = ada_resolve_function
3870         (candidates, NULL, 0,
3871          sym->linkage_name (),
3872          context_type, parse_completion);
3873       if (i < 0)
3874         error (_("Could not find a match for %s"), sym->print_name ());
3875     }
3876   else
3877     {
3878       gdb_printf (_("Multiple matches for %s\n"), sym->print_name ());
3879       user_select_syms (candidates.data (), candidates.size (), 1);
3880       i = 0;
3881     }
3882
3883   tracker->update (candidates[i]);
3884   return candidates[i];
3885 }
3886
3887 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  */
3888 /* The term "match" here is rather loose.  The match is heuristic and
3889    liberal.  */
3890
3891 static int
3892 ada_type_match (struct type *ftype, struct type *atype)
3893 {
3894   ftype = ada_check_typedef (ftype);
3895   atype = ada_check_typedef (atype);
3896
3897   if (ftype->code () == TYPE_CODE_REF)
3898     ftype = TYPE_TARGET_TYPE (ftype);
3899   if (atype->code () == TYPE_CODE_REF)
3900     atype = TYPE_TARGET_TYPE (atype);
3901
3902   switch (ftype->code ())
3903     {
3904     default:
3905       return ftype->code () == atype->code ();
3906     case TYPE_CODE_PTR:
3907       if (atype->code () != TYPE_CODE_PTR)
3908         return 0;
3909       atype = TYPE_TARGET_TYPE (atype);
3910       /* This can only happen if the actual argument is 'null'.  */
3911       if (atype->code () == TYPE_CODE_INT && TYPE_LENGTH (atype) == 0)
3912         return 1;
3913       return ada_type_match (TYPE_TARGET_TYPE (ftype), atype);
3914     case TYPE_CODE_INT:
3915     case TYPE_CODE_ENUM:
3916     case TYPE_CODE_RANGE:
3917       switch (atype->code ())
3918         {
3919         case TYPE_CODE_INT:
3920         case TYPE_CODE_ENUM:
3921         case TYPE_CODE_RANGE:
3922           return 1;
3923         default:
3924           return 0;
3925         }
3926
3927     case TYPE_CODE_ARRAY:
3928       return (atype->code () == TYPE_CODE_ARRAY
3929               || ada_is_array_descriptor_type (atype));
3930
3931     case TYPE_CODE_STRUCT:
3932       if (ada_is_array_descriptor_type (ftype))
3933         return (atype->code () == TYPE_CODE_ARRAY
3934                 || ada_is_array_descriptor_type (atype));
3935       else
3936         return (atype->code () == TYPE_CODE_STRUCT
3937                 && !ada_is_array_descriptor_type (atype));
3938
3939     case TYPE_CODE_UNION:
3940     case TYPE_CODE_FLT:
3941       return (atype->code () == ftype->code ());
3942     }
3943 }
3944
3945 /* Return non-zero if the formals of FUNC "sufficiently match" the
3946    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3947    may also be an enumeral, in which case it is treated as a 0-
3948    argument function.  */
3949
3950 static int
3951 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3952 {
3953   int i;
3954   struct type *func_type = func->type ();
3955
3956   if (func->aclass () == LOC_CONST
3957       && func_type->code () == TYPE_CODE_ENUM)
3958     return (n_actuals == 0);
3959   else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3960     return 0;
3961
3962   if (func_type->num_fields () != n_actuals)
3963     return 0;
3964
3965   for (i = 0; i < n_actuals; i += 1)
3966     {
3967       if (actuals[i] == NULL)
3968         return 0;
3969       else
3970         {
3971           struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3972           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3973
3974           if (!ada_type_match (ftype, atype))
3975             return 0;
3976         }
3977     }
3978   return 1;
3979 }
3980
3981 /* False iff function type FUNC_TYPE definitely does not produce a value
3982    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3983    FUNC_TYPE is not a valid function type with a non-null return type
3984    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3985
3986 static int
3987 return_match (struct type *func_type, struct type *context_type)
3988 {
3989   struct type *return_type;
3990
3991   if (func_type == NULL)
3992     return 1;
3993
3994   if (func_type->code () == TYPE_CODE_FUNC)
3995     return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3996   else
3997     return_type = get_base_type (func_type);
3998   if (return_type == NULL)
3999     return 1;
4000
4001   context_type = get_base_type (context_type);
4002
4003   if (return_type->code () == TYPE_CODE_ENUM)
4004     return context_type == NULL || return_type == context_type;
4005   else if (context_type == NULL)
4006     return return_type->code () != TYPE_CODE_VOID;
4007   else
4008     return return_type->code () == context_type->code ();
4009 }
4010
4011
4012 /* Returns the index in SYMS that contains the symbol for the
4013    function (if any) that matches the types of the NARGS arguments in
4014    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
4015    that returns that type, then eliminate matches that don't.  If
4016    CONTEXT_TYPE is void and there is at least one match that does not
4017    return void, eliminate all matches that do.
4018
4019    Asks the user if there is more than one match remaining.  Returns -1
4020    if there is no such symbol or none is selected.  NAME is used
4021    solely for messages.  May re-arrange and modify SYMS in
4022    the process; the index returned is for the modified vector.  */
4023
4024 static int
4025 ada_resolve_function (std::vector<struct block_symbol> &syms,
4026                       struct value **args, int nargs,
4027                       const char *name, struct type *context_type,
4028                       bool parse_completion)
4029 {
4030   int fallback;
4031   int k;
4032   int m;                        /* Number of hits */
4033
4034   m = 0;
4035   /* In the first pass of the loop, we only accept functions matching
4036      context_type.  If none are found, we add a second pass of the loop
4037      where every function is accepted.  */
4038   for (fallback = 0; m == 0 && fallback < 2; fallback++)
4039     {
4040       for (k = 0; k < syms.size (); k += 1)
4041         {
4042           struct type *type = ada_check_typedef (syms[k].symbol->type ());
4043
4044           if (ada_args_match (syms[k].symbol, args, nargs)
4045               && (fallback || return_match (type, context_type)))
4046             {
4047               syms[m] = syms[k];
4048               m += 1;
4049             }
4050         }
4051     }
4052
4053   /* If we got multiple matches, ask the user which one to use.  Don't do this
4054      interactive thing during completion, though, as the purpose of the
4055      completion is providing a list of all possible matches.  Prompting the
4056      user to filter it down would be completely unexpected in this case.  */
4057   if (m == 0)
4058     return -1;
4059   else if (m > 1 && !parse_completion)
4060     {
4061       gdb_printf (_("Multiple matches for %s\n"), name);
4062       user_select_syms (syms.data (), m, 1);
4063       return 0;
4064     }
4065   return 0;
4066 }
4067
4068 /* Type-class predicates */
4069
4070 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4071    or FLOAT).  */
4072
4073 static int
4074 numeric_type_p (struct type *type)
4075 {
4076   if (type == NULL)
4077     return 0;
4078   else
4079     {
4080       switch (type->code ())
4081         {
4082         case TYPE_CODE_INT:
4083         case TYPE_CODE_FLT:
4084         case TYPE_CODE_FIXED_POINT:
4085           return 1;
4086         case TYPE_CODE_RANGE:
4087           return (type == TYPE_TARGET_TYPE (type)
4088                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
4089         default:
4090           return 0;
4091         }
4092     }
4093 }
4094
4095 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
4096
4097 static int
4098 integer_type_p (struct type *type)
4099 {
4100   if (type == NULL)
4101     return 0;
4102   else
4103     {
4104       switch (type->code ())
4105         {
4106         case TYPE_CODE_INT:
4107           return 1;
4108         case TYPE_CODE_RANGE:
4109           return (type == TYPE_TARGET_TYPE (type)
4110                   || integer_type_p (TYPE_TARGET_TYPE (type)));
4111         default:
4112           return 0;
4113         }
4114     }
4115 }
4116
4117 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
4118
4119 static int
4120 scalar_type_p (struct type *type)
4121 {
4122   if (type == NULL)
4123     return 0;
4124   else
4125     {
4126       switch (type->code ())
4127         {
4128         case TYPE_CODE_INT:
4129         case TYPE_CODE_RANGE:
4130         case TYPE_CODE_ENUM:
4131         case TYPE_CODE_FLT:
4132         case TYPE_CODE_FIXED_POINT:
4133           return 1;
4134         default:
4135           return 0;
4136         }
4137     }
4138 }
4139
4140 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
4141
4142 static int
4143 discrete_type_p (struct type *type)
4144 {
4145   if (type == NULL)
4146     return 0;
4147   else
4148     {
4149       switch (type->code ())
4150         {
4151         case TYPE_CODE_INT:
4152         case TYPE_CODE_RANGE:
4153         case TYPE_CODE_ENUM:
4154         case TYPE_CODE_BOOL:
4155           return 1;
4156         default:
4157           return 0;
4158         }
4159     }
4160 }
4161
4162 /* Returns non-zero if OP with operands in the vector ARGS could be
4163    a user-defined function.  Errs on the side of pre-defined operators
4164    (i.e., result 0).  */
4165
4166 static int
4167 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4168 {
4169   struct type *type0 =
4170     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4171   struct type *type1 =
4172     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4173
4174   if (type0 == NULL)
4175     return 0;
4176
4177   switch (op)
4178     {
4179     default:
4180       return 0;
4181
4182     case BINOP_ADD:
4183     case BINOP_SUB:
4184     case BINOP_MUL:
4185     case BINOP_DIV:
4186       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4187
4188     case BINOP_REM:
4189     case BINOP_MOD:
4190     case BINOP_BITWISE_AND:
4191     case BINOP_BITWISE_IOR:
4192     case BINOP_BITWISE_XOR:
4193       return (!(integer_type_p (type0) && integer_type_p (type1)));
4194
4195     case BINOP_EQUAL:
4196     case BINOP_NOTEQUAL:
4197     case BINOP_LESS:
4198     case BINOP_GTR:
4199     case BINOP_LEQ:
4200     case BINOP_GEQ:
4201       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4202
4203     case BINOP_CONCAT:
4204       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4205
4206     case BINOP_EXP:
4207       return (!(numeric_type_p (type0) && integer_type_p (type1)));
4208
4209     case UNOP_NEG:
4210     case UNOP_PLUS:
4211     case UNOP_LOGICAL_NOT:
4212     case UNOP_ABS:
4213       return (!numeric_type_p (type0));
4214
4215     }
4216 }
4217 \f
4218                                 /* Renaming */
4219
4220 /* NOTES: 
4221
4222    1. In the following, we assume that a renaming type's name may
4223       have an ___XD suffix.  It would be nice if this went away at some
4224       point.
4225    2. We handle both the (old) purely type-based representation of 
4226       renamings and the (new) variable-based encoding.  At some point,
4227       it is devoutly to be hoped that the former goes away 
4228       (FIXME: hilfinger-2007-07-09).
4229    3. Subprogram renamings are not implemented, although the XRS
4230       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
4231
4232 /* If SYM encodes a renaming, 
4233
4234        <renaming> renames <renamed entity>,
4235
4236    sets *LEN to the length of the renamed entity's name,
4237    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4238    the string describing the subcomponent selected from the renamed
4239    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4240    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4241    are undefined).  Otherwise, returns a value indicating the category
4242    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4243    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4244    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
4245    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4246    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4247    may be NULL, in which case they are not assigned.
4248
4249    [Currently, however, GCC does not generate subprogram renamings.]  */
4250
4251 enum ada_renaming_category
4252 ada_parse_renaming (struct symbol *sym,
4253                     const char **renamed_entity, int *len, 
4254                     const char **renaming_expr)
4255 {
4256   enum ada_renaming_category kind;
4257   const char *info;
4258   const char *suffix;
4259
4260   if (sym == NULL)
4261     return ADA_NOT_RENAMING;
4262   switch (sym->aclass ()) 
4263     {
4264     default:
4265       return ADA_NOT_RENAMING;
4266     case LOC_LOCAL:
4267     case LOC_STATIC:
4268     case LOC_COMPUTED:
4269     case LOC_OPTIMIZED_OUT:
4270       info = strstr (sym->linkage_name (), "___XR");
4271       if (info == NULL)
4272         return ADA_NOT_RENAMING;
4273       switch (info[5])
4274         {
4275         case '_':
4276           kind = ADA_OBJECT_RENAMING;
4277           info += 6;
4278           break;
4279         case 'E':
4280           kind = ADA_EXCEPTION_RENAMING;
4281           info += 7;
4282           break;
4283         case 'P':
4284           kind = ADA_PACKAGE_RENAMING;
4285           info += 7;
4286           break;
4287         case 'S':
4288           kind = ADA_SUBPROGRAM_RENAMING;
4289           info += 7;
4290           break;
4291         default:
4292           return ADA_NOT_RENAMING;
4293         }
4294     }
4295
4296   if (renamed_entity != NULL)
4297     *renamed_entity = info;
4298   suffix = strstr (info, "___XE");
4299   if (suffix == NULL || suffix == info)
4300     return ADA_NOT_RENAMING;
4301   if (len != NULL)
4302     *len = strlen (info) - strlen (suffix);
4303   suffix += 5;
4304   if (renaming_expr != NULL)
4305     *renaming_expr = suffix;
4306   return kind;
4307 }
4308
4309 /* Compute the value of the given RENAMING_SYM, which is expected to
4310    be a symbol encoding a renaming expression.  BLOCK is the block
4311    used to evaluate the renaming.  */
4312
4313 static struct value *
4314 ada_read_renaming_var_value (struct symbol *renaming_sym,
4315                              const struct block *block)
4316 {
4317   const char *sym_name;
4318
4319   sym_name = renaming_sym->linkage_name ();
4320   expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4321   return evaluate_expression (expr.get ());
4322 }
4323 \f
4324
4325                                 /* Evaluation: Function Calls */
4326
4327 /* Return an lvalue containing the value VAL.  This is the identity on
4328    lvalues, and otherwise has the side-effect of allocating memory
4329    in the inferior where a copy of the value contents is copied.  */
4330
4331 static struct value *
4332 ensure_lval (struct value *val)
4333 {
4334   if (VALUE_LVAL (val) == not_lval
4335       || VALUE_LVAL (val) == lval_internalvar)
4336     {
4337       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4338       const CORE_ADDR addr =
4339         value_as_long (value_allocate_space_in_inferior (len));
4340
4341       VALUE_LVAL (val) = lval_memory;
4342       set_value_address (val, addr);
4343       write_memory (addr, value_contents (val).data (), len);
4344     }
4345
4346   return val;
4347 }
4348
4349 /* Given ARG, a value of type (pointer or reference to a)*
4350    structure/union, extract the component named NAME from the ultimate
4351    target structure/union and return it as a value with its
4352    appropriate type.
4353
4354    The routine searches for NAME among all members of the structure itself
4355    and (recursively) among all members of any wrapper members
4356    (e.g., '_parent').
4357
4358    If NO_ERR, then simply return NULL in case of error, rather than
4359    calling error.  */
4360
4361 static struct value *
4362 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
4363 {
4364   struct type *t, *t1;
4365   struct value *v;
4366   int check_tag;
4367
4368   v = NULL;
4369   t1 = t = ada_check_typedef (value_type (arg));
4370   if (t->code () == TYPE_CODE_REF)
4371     {
4372       t1 = TYPE_TARGET_TYPE (t);
4373       if (t1 == NULL)
4374         goto BadValue;
4375       t1 = ada_check_typedef (t1);
4376       if (t1->code () == TYPE_CODE_PTR)
4377         {
4378           arg = coerce_ref (arg);
4379           t = t1;
4380         }
4381     }
4382
4383   while (t->code () == TYPE_CODE_PTR)
4384     {
4385       t1 = TYPE_TARGET_TYPE (t);
4386       if (t1 == NULL)
4387         goto BadValue;
4388       t1 = ada_check_typedef (t1);
4389       if (t1->code () == TYPE_CODE_PTR)
4390         {
4391           arg = value_ind (arg);
4392           t = t1;
4393         }
4394       else
4395         break;
4396     }
4397
4398   if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4399     goto BadValue;
4400
4401   if (t1 == t)
4402     v = ada_search_struct_field (name, arg, 0, t);
4403   else
4404     {
4405       int bit_offset, bit_size, byte_offset;
4406       struct type *field_type;
4407       CORE_ADDR address;
4408
4409       if (t->code () == TYPE_CODE_PTR)
4410         address = value_address (ada_value_ind (arg));
4411       else
4412         address = value_address (ada_coerce_ref (arg));
4413
4414       /* Check to see if this is a tagged type.  We also need to handle
4415          the case where the type is a reference to a tagged type, but
4416          we have to be careful to exclude pointers to tagged types.
4417          The latter should be shown as usual (as a pointer), whereas
4418          a reference should mostly be transparent to the user.  */
4419
4420       if (ada_is_tagged_type (t1, 0)
4421           || (t1->code () == TYPE_CODE_REF
4422               && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
4423         {
4424           /* We first try to find the searched field in the current type.
4425              If not found then let's look in the fixed type.  */
4426
4427           if (!find_struct_field (name, t1, 0,
4428                                   nullptr, nullptr, nullptr,
4429                                   nullptr, nullptr))
4430             check_tag = 1;
4431           else
4432             check_tag = 0;
4433         }
4434       else
4435         check_tag = 0;
4436
4437       /* Convert to fixed type in all cases, so that we have proper
4438          offsets to each field in unconstrained record types.  */
4439       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4440                               address, NULL, check_tag);
4441
4442       /* Resolve the dynamic type as well.  */
4443       arg = value_from_contents_and_address (t1, nullptr, address);
4444       t1 = value_type (arg);
4445
4446       if (find_struct_field (name, t1, 0,
4447                              &field_type, &byte_offset, &bit_offset,
4448                              &bit_size, NULL))
4449         {
4450           if (bit_size != 0)
4451             {
4452               if (t->code () == TYPE_CODE_REF)
4453                 arg = ada_coerce_ref (arg);
4454               else
4455                 arg = ada_value_ind (arg);
4456               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4457                                                   bit_offset, bit_size,
4458                                                   field_type);
4459             }
4460           else
4461             v = value_at_lazy (field_type, address + byte_offset);
4462         }
4463     }
4464
4465   if (v != NULL || no_err)
4466     return v;
4467   else
4468     error (_("There is no member named %s."), name);
4469
4470  BadValue:
4471   if (no_err)
4472     return NULL;
4473   else
4474     error (_("Attempt to extract a component of "
4475              "a value that is not a record."));
4476 }
4477
4478 /* Return the value ACTUAL, converted to be an appropriate value for a
4479    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4480    allocating any necessary descriptors (fat pointers), or copies of
4481    values not residing in memory, updating it as needed.  */
4482
4483 struct value *
4484 ada_convert_actual (struct value *actual, struct type *formal_type0)
4485 {
4486   struct type *actual_type = ada_check_typedef (value_type (actual));
4487   struct type *formal_type = ada_check_typedef (formal_type0);
4488   struct type *formal_target =
4489     formal_type->code () == TYPE_CODE_PTR
4490     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4491   struct type *actual_target =
4492     actual_type->code () == TYPE_CODE_PTR
4493     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4494
4495   if (ada_is_array_descriptor_type (formal_target)
4496       && actual_target->code () == TYPE_CODE_ARRAY)
4497     return make_array_descriptor (formal_type, actual);
4498   else if (formal_type->code () == TYPE_CODE_PTR
4499            || formal_type->code () == TYPE_CODE_REF)
4500     {
4501       struct value *result;
4502
4503       if (formal_target->code () == TYPE_CODE_ARRAY
4504           && ada_is_array_descriptor_type (actual_target))
4505         result = desc_data (actual);
4506       else if (formal_type->code () != TYPE_CODE_PTR)
4507         {
4508           if (VALUE_LVAL (actual) != lval_memory)
4509             {
4510               struct value *val;
4511
4512               actual_type = ada_check_typedef (value_type (actual));
4513               val = allocate_value (actual_type);
4514               copy (value_contents (actual), value_contents_raw (val));
4515               actual = ensure_lval (val);
4516             }
4517           result = value_addr (actual);
4518         }
4519       else
4520         return actual;
4521       return value_cast_pointers (formal_type, result, 0);
4522     }
4523   else if (actual_type->code () == TYPE_CODE_PTR)
4524     return ada_value_ind (actual);
4525   else if (ada_is_aligner_type (formal_type))
4526     {
4527       /* We need to turn this parameter into an aligner type
4528          as well.  */
4529       struct value *aligner = allocate_value (formal_type);
4530       struct value *component = ada_value_struct_elt (aligner, "F", 0);
4531
4532       value_assign_to_component (aligner, component, actual);
4533       return aligner;
4534     }
4535
4536   return actual;
4537 }
4538
4539 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4540    type TYPE.  This is usually an inefficient no-op except on some targets
4541    (such as AVR) where the representation of a pointer and an address
4542    differs.  */
4543
4544 static CORE_ADDR
4545 value_pointer (struct value *value, struct type *type)
4546 {
4547   unsigned len = TYPE_LENGTH (type);
4548   gdb_byte *buf = (gdb_byte *) alloca (len);
4549   CORE_ADDR addr;
4550
4551   addr = value_address (value);
4552   gdbarch_address_to_pointer (type->arch (), type, buf, addr);
4553   addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4554   return addr;
4555 }
4556
4557
4558 /* Push a descriptor of type TYPE for array value ARR on the stack at
4559    *SP, updating *SP to reflect the new descriptor.  Return either
4560    an lvalue representing the new descriptor, or (if TYPE is a pointer-
4561    to-descriptor type rather than a descriptor type), a struct value *
4562    representing a pointer to this descriptor.  */
4563
4564 static struct value *
4565 make_array_descriptor (struct type *type, struct value *arr)
4566 {
4567   struct type *bounds_type = desc_bounds_type (type);
4568   struct type *desc_type = desc_base_type (type);
4569   struct value *descriptor = allocate_value (desc_type);
4570   struct value *bounds = allocate_value (bounds_type);
4571   int i;
4572
4573   for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4574        i > 0; i -= 1)
4575     {
4576       modify_field (value_type (bounds),
4577                     value_contents_writeable (bounds).data (),
4578                     ada_array_bound (arr, i, 0),
4579                     desc_bound_bitpos (bounds_type, i, 0),
4580                     desc_bound_bitsize (bounds_type, i, 0));
4581       modify_field (value_type (bounds),
4582                     value_contents_writeable (bounds).data (),
4583                     ada_array_bound (arr, i, 1),
4584                     desc_bound_bitpos (bounds_type, i, 1),
4585                     desc_bound_bitsize (bounds_type, i, 1));
4586     }
4587
4588   bounds = ensure_lval (bounds);
4589
4590   modify_field (value_type (descriptor),
4591                 value_contents_writeable (descriptor).data (),
4592                 value_pointer (ensure_lval (arr),
4593                                desc_type->field (0).type ()),
4594                 fat_pntr_data_bitpos (desc_type),
4595                 fat_pntr_data_bitsize (desc_type));
4596
4597   modify_field (value_type (descriptor),
4598                 value_contents_writeable (descriptor).data (),
4599                 value_pointer (bounds,
4600                                desc_type->field (1).type ()),
4601                 fat_pntr_bounds_bitpos (desc_type),
4602                 fat_pntr_bounds_bitsize (desc_type));
4603
4604   descriptor = ensure_lval (descriptor);
4605
4606   if (type->code () == TYPE_CODE_PTR)
4607     return value_addr (descriptor);
4608   else
4609     return descriptor;
4610 }
4611 \f
4612                                 /* Symbol Cache Module */
4613
4614 /* Performance measurements made as of 2010-01-15 indicate that
4615    this cache does bring some noticeable improvements.  Depending
4616    on the type of entity being printed, the cache can make it as much
4617    as an order of magnitude faster than without it.
4618
4619    The descriptive type DWARF extension has significantly reduced
4620    the need for this cache, at least when DWARF is being used.  However,
4621    even in this case, some expensive name-based symbol searches are still
4622    sometimes necessary - to find an XVZ variable, mostly.  */
4623
4624 /* Return the symbol cache associated to the given program space PSPACE.
4625    If not allocated for this PSPACE yet, allocate and initialize one.  */
4626
4627 static struct ada_symbol_cache *
4628 ada_get_symbol_cache (struct program_space *pspace)
4629 {
4630   struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4631
4632   if (pspace_data->sym_cache == nullptr)
4633     pspace_data->sym_cache.reset (new ada_symbol_cache);
4634
4635   return pspace_data->sym_cache.get ();
4636 }
4637
4638 /* Clear all entries from the symbol cache.  */
4639
4640 static void
4641 ada_clear_symbol_cache ()
4642 {
4643   struct ada_pspace_data *pspace_data
4644     = get_ada_pspace_data (current_program_space);
4645
4646   if (pspace_data->sym_cache != nullptr)
4647     pspace_data->sym_cache.reset ();
4648 }
4649
4650 /* Search our cache for an entry matching NAME and DOMAIN.
4651    Return it if found, or NULL otherwise.  */
4652
4653 static struct cache_entry **
4654 find_entry (const char *name, domain_enum domain)
4655 {
4656   struct ada_symbol_cache *sym_cache
4657     = ada_get_symbol_cache (current_program_space);
4658   int h = msymbol_hash (name) % HASH_SIZE;
4659   struct cache_entry **e;
4660
4661   for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4662     {
4663       if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4664         return e;
4665     }
4666   return NULL;
4667 }
4668
4669 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4670    Return 1 if found, 0 otherwise.
4671
4672    If an entry was found and SYM is not NULL, set *SYM to the entry's
4673    SYM.  Same principle for BLOCK if not NULL.  */
4674
4675 static int
4676 lookup_cached_symbol (const char *name, domain_enum domain,
4677                       struct symbol **sym, const struct block **block)
4678 {
4679   struct cache_entry **e = find_entry (name, domain);
4680
4681   if (e == NULL)
4682     return 0;
4683   if (sym != NULL)
4684     *sym = (*e)->sym;
4685   if (block != NULL)
4686     *block = (*e)->block;
4687   return 1;
4688 }
4689
4690 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4691    in domain DOMAIN, save this result in our symbol cache.  */
4692
4693 static void
4694 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4695               const struct block *block)
4696 {
4697   struct ada_symbol_cache *sym_cache
4698     = ada_get_symbol_cache (current_program_space);
4699   int h;
4700   struct cache_entry *e;
4701
4702   /* Symbols for builtin types don't have a block.
4703      For now don't cache such symbols.  */
4704   if (sym != NULL && !sym->is_objfile_owned ())
4705     return;
4706
4707   /* If the symbol is a local symbol, then do not cache it, as a search
4708      for that symbol depends on the context.  To determine whether
4709      the symbol is local or not, we check the block where we found it
4710      against the global and static blocks of its associated symtab.  */
4711   if (sym
4712       && BLOCKVECTOR_BLOCK (symbol_symtab (sym)->compunit ()->blockvector (),
4713                             GLOBAL_BLOCK) != block
4714       && BLOCKVECTOR_BLOCK (symbol_symtab (sym)->compunit ()->blockvector (),
4715                             STATIC_BLOCK) != block)
4716     return;
4717
4718   h = msymbol_hash (name) % HASH_SIZE;
4719   e = XOBNEW (&sym_cache->cache_space, cache_entry);
4720   e->next = sym_cache->root[h];
4721   sym_cache->root[h] = e;
4722   e->name = obstack_strdup (&sym_cache->cache_space, name);
4723   e->sym = sym;
4724   e->domain = domain;
4725   e->block = block;
4726 }
4727 \f
4728                                 /* Symbol Lookup */
4729
4730 /* Return the symbol name match type that should be used used when
4731    searching for all symbols matching LOOKUP_NAME.
4732
4733    LOOKUP_NAME is expected to be a symbol name after transformation
4734    for Ada lookups.  */
4735
4736 static symbol_name_match_type
4737 name_match_type_from_name (const char *lookup_name)
4738 {
4739   return (strstr (lookup_name, "__") == NULL
4740           ? symbol_name_match_type::WILD
4741           : symbol_name_match_type::FULL);
4742 }
4743
4744 /* Return the result of a standard (literal, C-like) lookup of NAME in
4745    given DOMAIN, visible from lexical block BLOCK.  */
4746
4747 static struct symbol *
4748 standard_lookup (const char *name, const struct block *block,
4749                  domain_enum domain)
4750 {
4751   /* Initialize it just to avoid a GCC false warning.  */
4752   struct block_symbol sym = {};
4753
4754   if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4755     return sym.symbol;
4756   ada_lookup_encoded_symbol (name, block, domain, &sym);
4757   cache_symbol (name, domain, sym.symbol, sym.block);
4758   return sym.symbol;
4759 }
4760
4761
4762 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4763    in the symbol fields of SYMS.  We treat enumerals as functions, 
4764    since they contend in overloading in the same way.  */
4765 static int
4766 is_nonfunction (const std::vector<struct block_symbol> &syms)
4767 {
4768   for (const block_symbol &sym : syms)
4769     if (sym.symbol->type ()->code () != TYPE_CODE_FUNC
4770         && (sym.symbol->type ()->code () != TYPE_CODE_ENUM
4771             || sym.symbol->aclass () != LOC_CONST))
4772       return 1;
4773
4774   return 0;
4775 }
4776
4777 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4778    struct types.  Otherwise, they may not.  */
4779
4780 static int
4781 equiv_types (struct type *type0, struct type *type1)
4782 {
4783   if (type0 == type1)
4784     return 1;
4785   if (type0 == NULL || type1 == NULL
4786       || type0->code () != type1->code ())
4787     return 0;
4788   if ((type0->code () == TYPE_CODE_STRUCT
4789        || type0->code () == TYPE_CODE_ENUM)
4790       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4791       && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4792     return 1;
4793
4794   return 0;
4795 }
4796
4797 /* True iff SYM0 represents the same entity as SYM1, or one that is
4798    no more defined than that of SYM1.  */
4799
4800 static int
4801 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4802 {
4803   if (sym0 == sym1)
4804     return 1;
4805   if (sym0->domain () != sym1->domain ()
4806       || sym0->aclass () != sym1->aclass ())
4807     return 0;
4808
4809   switch (sym0->aclass ())
4810     {
4811     case LOC_UNDEF:
4812       return 1;
4813     case LOC_TYPEDEF:
4814       {
4815         struct type *type0 = sym0->type ();
4816         struct type *type1 = sym1->type ();
4817         const char *name0 = sym0->linkage_name ();
4818         const char *name1 = sym1->linkage_name ();
4819         int len0 = strlen (name0);
4820
4821         return
4822           type0->code () == type1->code ()
4823           && (equiv_types (type0, type1)
4824               || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4825                   && startswith (name1 + len0, "___XV")));
4826       }
4827     case LOC_CONST:
4828       return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4829         && equiv_types (sym0->type (), sym1->type ());
4830
4831     case LOC_STATIC:
4832       {
4833         const char *name0 = sym0->linkage_name ();
4834         const char *name1 = sym1->linkage_name ();
4835         return (strcmp (name0, name1) == 0
4836                 && SYMBOL_VALUE_ADDRESS (sym0) == SYMBOL_VALUE_ADDRESS (sym1));
4837       }
4838
4839     default:
4840       return 0;
4841     }
4842 }
4843
4844 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4845    records in RESULT.  Do nothing if SYM is a duplicate.  */
4846
4847 static void
4848 add_defn_to_vec (std::vector<struct block_symbol> &result,
4849                  struct symbol *sym,
4850                  const struct block *block)
4851 {
4852   /* Do not try to complete stub types, as the debugger is probably
4853      already scanning all symbols matching a certain name at the
4854      time when this function is called.  Trying to replace the stub
4855      type by its associated full type will cause us to restart a scan
4856      which may lead to an infinite recursion.  Instead, the client
4857      collecting the matching symbols will end up collecting several
4858      matches, with at least one of them complete.  It can then filter
4859      out the stub ones if needed.  */
4860
4861   for (int i = result.size () - 1; i >= 0; i -= 1)
4862     {
4863       if (lesseq_defined_than (sym, result[i].symbol))
4864         return;
4865       else if (lesseq_defined_than (result[i].symbol, sym))
4866         {
4867           result[i].symbol = sym;
4868           result[i].block = block;
4869           return;
4870         }
4871     }
4872
4873   struct block_symbol info;
4874   info.symbol = sym;
4875   info.block = block;
4876   result.push_back (info);
4877 }
4878
4879 /* Return a bound minimal symbol matching NAME according to Ada
4880    decoding rules.  Returns an invalid symbol if there is no such
4881    minimal symbol.  Names prefixed with "standard__" are handled
4882    specially: "standard__" is first stripped off, and only static and
4883    global symbols are searched.  */
4884
4885 struct bound_minimal_symbol
4886 ada_lookup_simple_minsym (const char *name)
4887 {
4888   struct bound_minimal_symbol result;
4889
4890   symbol_name_match_type match_type = name_match_type_from_name (name);
4891   lookup_name_info lookup_name (name, match_type);
4892
4893   symbol_name_matcher_ftype *match_name
4894     = ada_get_symbol_name_matcher (lookup_name);
4895
4896   for (objfile *objfile : current_program_space->objfiles ())
4897     {
4898       for (minimal_symbol *msymbol : objfile->msymbols ())
4899         {
4900           if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4901               && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4902             {
4903               result.minsym = msymbol;
4904               result.objfile = objfile;
4905               break;
4906             }
4907         }
4908     }
4909
4910   return result;
4911 }
4912
4913 /* True if TYPE is definitely an artificial type supplied to a symbol
4914    for which no debugging information was given in the symbol file.  */
4915
4916 static int
4917 is_nondebugging_type (struct type *type)
4918 {
4919   const char *name = ada_type_name (type);
4920
4921   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4922 }
4923
4924 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4925    that are deemed "identical" for practical purposes.
4926
4927    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4928    types and that their number of enumerals is identical (in other
4929    words, type1->num_fields () == type2->num_fields ()).  */
4930
4931 static int
4932 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4933 {
4934   int i;
4935
4936   /* The heuristic we use here is fairly conservative.  We consider
4937      that 2 enumerate types are identical if they have the same
4938      number of enumerals and that all enumerals have the same
4939      underlying value and name.  */
4940
4941   /* All enums in the type should have an identical underlying value.  */
4942   for (i = 0; i < type1->num_fields (); i++)
4943     if (type1->field (i).loc_enumval () != type2->field (i).loc_enumval ())
4944       return 0;
4945
4946   /* All enumerals should also have the same name (modulo any numerical
4947      suffix).  */
4948   for (i = 0; i < type1->num_fields (); i++)
4949     {
4950       const char *name_1 = type1->field (i).name ();
4951       const char *name_2 = type2->field (i).name ();
4952       int len_1 = strlen (name_1);
4953       int len_2 = strlen (name_2);
4954
4955       ada_remove_trailing_digits (type1->field (i).name (), &len_1);
4956       ada_remove_trailing_digits (type2->field (i).name (), &len_2);
4957       if (len_1 != len_2
4958           || strncmp (type1->field (i).name (),
4959                       type2->field (i).name (),
4960                       len_1) != 0)
4961         return 0;
4962     }
4963
4964   return 1;
4965 }
4966
4967 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4968    that are deemed "identical" for practical purposes.  Sometimes,
4969    enumerals are not strictly identical, but their types are so similar
4970    that they can be considered identical.
4971
4972    For instance, consider the following code:
4973
4974       type Color is (Black, Red, Green, Blue, White);
4975       type RGB_Color is new Color range Red .. Blue;
4976
4977    Type RGB_Color is a subrange of an implicit type which is a copy
4978    of type Color. If we call that implicit type RGB_ColorB ("B" is
4979    for "Base Type"), then type RGB_ColorB is a copy of type Color.
4980    As a result, when an expression references any of the enumeral
4981    by name (Eg. "print green"), the expression is technically
4982    ambiguous and the user should be asked to disambiguate. But
4983    doing so would only hinder the user, since it wouldn't matter
4984    what choice he makes, the outcome would always be the same.
4985    So, for practical purposes, we consider them as the same.  */
4986
4987 static int
4988 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
4989 {
4990   int i;
4991
4992   /* Before performing a thorough comparison check of each type,
4993      we perform a series of inexpensive checks.  We expect that these
4994      checks will quickly fail in the vast majority of cases, and thus
4995      help prevent the unnecessary use of a more expensive comparison.
4996      Said comparison also expects us to make some of these checks
4997      (see ada_identical_enum_types_p).  */
4998
4999   /* Quick check: All symbols should have an enum type.  */
5000   for (i = 0; i < syms.size (); i++)
5001     if (syms[i].symbol->type ()->code () != TYPE_CODE_ENUM)
5002       return 0;
5003
5004   /* Quick check: They should all have the same value.  */
5005   for (i = 1; i < syms.size (); i++)
5006     if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
5007       return 0;
5008
5009   /* Quick check: They should all have the same number of enumerals.  */
5010   for (i = 1; i < syms.size (); i++)
5011     if (syms[i].symbol->type ()->num_fields ()
5012         != syms[0].symbol->type ()->num_fields ())
5013       return 0;
5014
5015   /* All the sanity checks passed, so we might have a set of
5016      identical enumeration types.  Perform a more complete
5017      comparison of the type of each symbol.  */
5018   for (i = 1; i < syms.size (); i++)
5019     if (!ada_identical_enum_types_p (syms[i].symbol->type (),
5020                                      syms[0].symbol->type ()))
5021       return 0;
5022
5023   return 1;
5024 }
5025
5026 /* Remove any non-debugging symbols in SYMS that definitely
5027    duplicate other symbols in the list (The only case I know of where
5028    this happens is when object files containing stabs-in-ecoff are
5029    linked with files containing ordinary ecoff debugging symbols (or no
5030    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.  */
5031
5032 static void
5033 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5034 {
5035   int i, j;
5036
5037   /* We should never be called with less than 2 symbols, as there
5038      cannot be any extra symbol in that case.  But it's easy to
5039      handle, since we have nothing to do in that case.  */
5040   if (syms->size () < 2)
5041     return;
5042
5043   i = 0;
5044   while (i < syms->size ())
5045     {
5046       int remove_p = 0;
5047
5048       /* If two symbols have the same name and one of them is a stub type,
5049          the get rid of the stub.  */
5050
5051       if ((*syms)[i].symbol->type ()->is_stub ()
5052           && (*syms)[i].symbol->linkage_name () != NULL)
5053         {
5054           for (j = 0; j < syms->size (); j++)
5055             {
5056               if (j != i
5057                   && !(*syms)[j].symbol->type ()->is_stub ()
5058                   && (*syms)[j].symbol->linkage_name () != NULL
5059                   && strcmp ((*syms)[i].symbol->linkage_name (),
5060                              (*syms)[j].symbol->linkage_name ()) == 0)
5061                 remove_p = 1;
5062             }
5063         }
5064
5065       /* Two symbols with the same name, same class and same address
5066          should be identical.  */
5067
5068       else if ((*syms)[i].symbol->linkage_name () != NULL
5069           && (*syms)[i].symbol->aclass () == LOC_STATIC
5070           && is_nondebugging_type ((*syms)[i].symbol->type ()))
5071         {
5072           for (j = 0; j < syms->size (); j += 1)
5073             {
5074               if (i != j
5075                   && (*syms)[j].symbol->linkage_name () != NULL
5076                   && strcmp ((*syms)[i].symbol->linkage_name (),
5077                              (*syms)[j].symbol->linkage_name ()) == 0
5078                   && ((*syms)[i].symbol->aclass ()
5079                       == (*syms)[j].symbol->aclass ())
5080                   && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
5081                   == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
5082                 remove_p = 1;
5083             }
5084         }
5085       
5086       if (remove_p)
5087         syms->erase (syms->begin () + i);
5088       else
5089         i += 1;
5090     }
5091
5092   /* If all the remaining symbols are identical enumerals, then
5093      just keep the first one and discard the rest.
5094
5095      Unlike what we did previously, we do not discard any entry
5096      unless they are ALL identical.  This is because the symbol
5097      comparison is not a strict comparison, but rather a practical
5098      comparison.  If all symbols are considered identical, then
5099      we can just go ahead and use the first one and discard the rest.
5100      But if we cannot reduce the list to a single element, we have
5101      to ask the user to disambiguate anyways.  And if we have to
5102      present a multiple-choice menu, it's less confusing if the list
5103      isn't missing some choices that were identical and yet distinct.  */
5104   if (symbols_are_identical_enums (*syms))
5105     syms->resize (1);
5106 }
5107
5108 /* Given a type that corresponds to a renaming entity, use the type name
5109    to extract the scope (package name or function name, fully qualified,
5110    and following the GNAT encoding convention) where this renaming has been
5111    defined.  */
5112
5113 static std::string
5114 xget_renaming_scope (struct type *renaming_type)
5115 {
5116   /* The renaming types adhere to the following convention:
5117      <scope>__<rename>___<XR extension>.
5118      So, to extract the scope, we search for the "___XR" extension,
5119      and then backtrack until we find the first "__".  */
5120
5121   const char *name = renaming_type->name ();
5122   const char *suffix = strstr (name, "___XR");
5123   const char *last;
5124
5125   /* Now, backtrack a bit until we find the first "__".  Start looking
5126      at suffix - 3, as the <rename> part is at least one character long.  */
5127
5128   for (last = suffix - 3; last > name; last--)
5129     if (last[0] == '_' && last[1] == '_')
5130       break;
5131
5132   /* Make a copy of scope and return it.  */
5133   return std::string (name, last);
5134 }
5135
5136 /* Return nonzero if NAME corresponds to a package name.  */
5137
5138 static int
5139 is_package_name (const char *name)
5140 {
5141   /* Here, We take advantage of the fact that no symbols are generated
5142      for packages, while symbols are generated for each function.
5143      So the condition for NAME represent a package becomes equivalent
5144      to NAME not existing in our list of symbols.  There is only one
5145      small complication with library-level functions (see below).  */
5146
5147   /* If it is a function that has not been defined at library level,
5148      then we should be able to look it up in the symbols.  */
5149   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5150     return 0;
5151
5152   /* Library-level function names start with "_ada_".  See if function
5153      "_ada_" followed by NAME can be found.  */
5154
5155   /* Do a quick check that NAME does not contain "__", since library-level
5156      functions names cannot contain "__" in them.  */
5157   if (strstr (name, "__") != NULL)
5158     return 0;
5159
5160   std::string fun_name = string_printf ("_ada_%s", name);
5161
5162   return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5163 }
5164
5165 /* Return nonzero if SYM corresponds to a renaming entity that is
5166    not visible from FUNCTION_NAME.  */
5167
5168 static int
5169 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5170 {
5171   if (sym->aclass () != LOC_TYPEDEF)
5172     return 0;
5173
5174   std::string scope = xget_renaming_scope (sym->type ());
5175
5176   /* If the rename has been defined in a package, then it is visible.  */
5177   if (is_package_name (scope.c_str ()))
5178     return 0;
5179
5180   /* Check that the rename is in the current function scope by checking
5181      that its name starts with SCOPE.  */
5182
5183   /* If the function name starts with "_ada_", it means that it is
5184      a library-level function.  Strip this prefix before doing the
5185      comparison, as the encoding for the renaming does not contain
5186      this prefix.  */
5187   if (startswith (function_name, "_ada_"))
5188     function_name += 5;
5189
5190   return !startswith (function_name, scope.c_str ());
5191 }
5192
5193 /* Remove entries from SYMS that corresponds to a renaming entity that
5194    is not visible from the function associated with CURRENT_BLOCK or
5195    that is superfluous due to the presence of more specific renaming
5196    information.  Places surviving symbols in the initial entries of
5197    SYMS.
5198
5199    Rationale:
5200    First, in cases where an object renaming is implemented as a
5201    reference variable, GNAT may produce both the actual reference
5202    variable and the renaming encoding.  In this case, we discard the
5203    latter.
5204
5205    Second, GNAT emits a type following a specified encoding for each renaming
5206    entity.  Unfortunately, STABS currently does not support the definition
5207    of types that are local to a given lexical block, so all renamings types
5208    are emitted at library level.  As a consequence, if an application
5209    contains two renaming entities using the same name, and a user tries to
5210    print the value of one of these entities, the result of the ada symbol
5211    lookup will also contain the wrong renaming type.
5212
5213    This function partially covers for this limitation by attempting to
5214    remove from the SYMS list renaming symbols that should be visible
5215    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
5216    method with the current information available.  The implementation
5217    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
5218    
5219       - When the user tries to print a rename in a function while there
5220         is another rename entity defined in a package:  Normally, the
5221         rename in the function has precedence over the rename in the
5222         package, so the latter should be removed from the list.  This is
5223         currently not the case.
5224         
5225       - This function will incorrectly remove valid renames if
5226         the CURRENT_BLOCK corresponds to a function which symbol name
5227         has been changed by an "Export" pragma.  As a consequence,
5228         the user will be unable to print such rename entities.  */
5229
5230 static void
5231 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5232                              const struct block *current_block)
5233 {
5234   struct symbol *current_function;
5235   const char *current_function_name;
5236   int i;
5237   int is_new_style_renaming;
5238
5239   /* If there is both a renaming foo___XR... encoded as a variable and
5240      a simple variable foo in the same block, discard the latter.
5241      First, zero out such symbols, then compress.  */
5242   is_new_style_renaming = 0;
5243   for (i = 0; i < syms->size (); i += 1)
5244     {
5245       struct symbol *sym = (*syms)[i].symbol;
5246       const struct block *block = (*syms)[i].block;
5247       const char *name;
5248       const char *suffix;
5249
5250       if (sym == NULL || sym->aclass () == LOC_TYPEDEF)
5251         continue;
5252       name = sym->linkage_name ();
5253       suffix = strstr (name, "___XR");
5254
5255       if (suffix != NULL)
5256         {
5257           int name_len = suffix - name;
5258           int j;
5259
5260           is_new_style_renaming = 1;
5261           for (j = 0; j < syms->size (); j += 1)
5262             if (i != j && (*syms)[j].symbol != NULL
5263                 && strncmp (name, (*syms)[j].symbol->linkage_name (),
5264                             name_len) == 0
5265                 && block == (*syms)[j].block)
5266               (*syms)[j].symbol = NULL;
5267         }
5268     }
5269   if (is_new_style_renaming)
5270     {
5271       int j, k;
5272
5273       for (j = k = 0; j < syms->size (); j += 1)
5274         if ((*syms)[j].symbol != NULL)
5275             {
5276               (*syms)[k] = (*syms)[j];
5277               k += 1;
5278             }
5279       syms->resize (k);
5280       return;
5281     }
5282
5283   /* Extract the function name associated to CURRENT_BLOCK.
5284      Abort if unable to do so.  */
5285
5286   if (current_block == NULL)
5287     return;
5288
5289   current_function = block_linkage_function (current_block);
5290   if (current_function == NULL)
5291     return;
5292
5293   current_function_name = current_function->linkage_name ();
5294   if (current_function_name == NULL)
5295     return;
5296
5297   /* Check each of the symbols, and remove it from the list if it is
5298      a type corresponding to a renaming that is out of the scope of
5299      the current block.  */
5300
5301   i = 0;
5302   while (i < syms->size ())
5303     {
5304       if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5305           == ADA_OBJECT_RENAMING
5306           && old_renaming_is_invisible ((*syms)[i].symbol,
5307                                         current_function_name))
5308         syms->erase (syms->begin () + i);
5309       else
5310         i += 1;
5311     }
5312 }
5313
5314 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5315    whose name and domain match LOOKUP_NAME and DOMAIN respectively.
5316
5317    Note: This function assumes that RESULT is empty.  */
5318
5319 static void
5320 ada_add_local_symbols (std::vector<struct block_symbol> &result,
5321                        const lookup_name_info &lookup_name,
5322                        const struct block *block, domain_enum domain)
5323 {
5324   while (block != NULL)
5325     {
5326       ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5327
5328       /* If we found a non-function match, assume that's the one.  We
5329          only check this when finding a function boundary, so that we
5330          can accumulate all results from intervening blocks first.  */
5331       if (BLOCK_FUNCTION (block) != nullptr && is_nonfunction (result))
5332         return;
5333
5334       block = BLOCK_SUPERBLOCK (block);
5335     }
5336 }
5337
5338 /* An object of this type is used as the callback argument when
5339    calling the map_matching_symbols method.  */
5340
5341 struct match_data
5342 {
5343   explicit match_data (std::vector<struct block_symbol> *rp)
5344     : resultp (rp)
5345   {
5346   }
5347   DISABLE_COPY_AND_ASSIGN (match_data);
5348
5349   bool operator() (struct block_symbol *bsym);
5350
5351   struct objfile *objfile = nullptr;
5352   std::vector<struct block_symbol> *resultp;
5353   struct symbol *arg_sym = nullptr;
5354   bool found_sym = false;
5355 };
5356
5357 /* A callback for add_nonlocal_symbols that adds symbol, found in
5358    BSYM, to a list of symbols.  */
5359
5360 bool
5361 match_data::operator() (struct block_symbol *bsym)
5362 {
5363   const struct block *block = bsym->block;
5364   struct symbol *sym = bsym->symbol;
5365
5366   if (sym == NULL)
5367     {
5368       if (!found_sym && arg_sym != NULL)
5369         add_defn_to_vec (*resultp,
5370                          fixup_symbol_section (arg_sym, objfile),
5371                          block);
5372       found_sym = false;
5373       arg_sym = NULL;
5374     }
5375   else 
5376     {
5377       if (sym->aclass () == LOC_UNRESOLVED)
5378         return true;
5379       else if (sym->is_argument ())
5380         arg_sym = sym;
5381       else
5382         {
5383           found_sym = true;
5384           add_defn_to_vec (*resultp,
5385                            fixup_symbol_section (sym, objfile),
5386                            block);
5387         }
5388     }
5389   return true;
5390 }
5391
5392 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5393    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5394    symbols to RESULT.  Return whether we found such symbols.  */
5395
5396 static int
5397 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5398                          const struct block *block,
5399                          const lookup_name_info &lookup_name,
5400                          domain_enum domain)
5401 {
5402   struct using_direct *renaming;
5403   int defns_mark = result.size ();
5404
5405   symbol_name_matcher_ftype *name_match
5406     = ada_get_symbol_name_matcher (lookup_name);
5407
5408   for (renaming = block_using (block);
5409        renaming != NULL;
5410        renaming = renaming->next)
5411     {
5412       const char *r_name;
5413
5414       /* Avoid infinite recursions: skip this renaming if we are actually
5415          already traversing it.
5416
5417          Currently, symbol lookup in Ada don't use the namespace machinery from
5418          C++/Fortran support: skip namespace imports that use them.  */
5419       if (renaming->searched
5420           || (renaming->import_src != NULL
5421               && renaming->import_src[0] != '\0')
5422           || (renaming->import_dest != NULL
5423               && renaming->import_dest[0] != '\0'))
5424         continue;
5425       renaming->searched = 1;
5426
5427       /* TODO: here, we perform another name-based symbol lookup, which can
5428          pull its own multiple overloads.  In theory, we should be able to do
5429          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5430          not a simple name.  But in order to do this, we would need to enhance
5431          the DWARF reader to associate a symbol to this renaming, instead of a
5432          name.  So, for now, we do something simpler: re-use the C++/Fortran
5433          namespace machinery.  */
5434       r_name = (renaming->alias != NULL
5435                 ? renaming->alias
5436                 : renaming->declaration);
5437       if (name_match (r_name, lookup_name, NULL))
5438         {
5439           lookup_name_info decl_lookup_name (renaming->declaration,
5440                                              lookup_name.match_type ());
5441           ada_add_all_symbols (result, block, decl_lookup_name, domain,
5442                                1, NULL);
5443         }
5444       renaming->searched = 0;
5445     }
5446   return result.size () != defns_mark;
5447 }
5448
5449 /* Implements compare_names, but only applying the comparision using
5450    the given CASING.  */
5451
5452 static int
5453 compare_names_with_case (const char *string1, const char *string2,
5454                          enum case_sensitivity casing)
5455 {
5456   while (*string1 != '\0' && *string2 != '\0')
5457     {
5458       char c1, c2;
5459
5460       if (isspace (*string1) || isspace (*string2))
5461         return strcmp_iw_ordered (string1, string2);
5462
5463       if (casing == case_sensitive_off)
5464         {
5465           c1 = tolower (*string1);
5466           c2 = tolower (*string2);
5467         }
5468       else
5469         {
5470           c1 = *string1;
5471           c2 = *string2;
5472         }
5473       if (c1 != c2)
5474         break;
5475
5476       string1 += 1;
5477       string2 += 1;
5478     }
5479
5480   switch (*string1)
5481     {
5482     case '(':
5483       return strcmp_iw_ordered (string1, string2);
5484     case '_':
5485       if (*string2 == '\0')
5486         {
5487           if (is_name_suffix (string1))
5488             return 0;
5489           else
5490             return 1;
5491         }
5492       /* FALLTHROUGH */
5493     default:
5494       if (*string2 == '(')
5495         return strcmp_iw_ordered (string1, string2);
5496       else
5497         {
5498           if (casing == case_sensitive_off)
5499             return tolower (*string1) - tolower (*string2);
5500           else
5501             return *string1 - *string2;
5502         }
5503     }
5504 }
5505
5506 /* Compare STRING1 to STRING2, with results as for strcmp.
5507    Compatible with strcmp_iw_ordered in that...
5508
5509        strcmp_iw_ordered (STRING1, STRING2) <= 0
5510
5511    ... implies...
5512
5513        compare_names (STRING1, STRING2) <= 0
5514
5515    (they may differ as to what symbols compare equal).  */
5516
5517 static int
5518 compare_names (const char *string1, const char *string2)
5519 {
5520   int result;
5521
5522   /* Similar to what strcmp_iw_ordered does, we need to perform
5523      a case-insensitive comparison first, and only resort to
5524      a second, case-sensitive, comparison if the first one was
5525      not sufficient to differentiate the two strings.  */
5526
5527   result = compare_names_with_case (string1, string2, case_sensitive_off);
5528   if (result == 0)
5529     result = compare_names_with_case (string1, string2, case_sensitive_on);
5530
5531   return result;
5532 }
5533
5534 /* Convenience function to get at the Ada encoded lookup name for
5535    LOOKUP_NAME, as a C string.  */
5536
5537 static const char *
5538 ada_lookup_name (const lookup_name_info &lookup_name)
5539 {
5540   return lookup_name.ada ().lookup_name ().c_str ();
5541 }
5542
5543 /* A helper for add_nonlocal_symbols.  Call expand_matching_symbols
5544    for OBJFILE, then walk the objfile's symtabs and update the
5545    results.  */
5546
5547 static void
5548 map_matching_symbols (struct objfile *objfile,
5549                       const lookup_name_info &lookup_name,
5550                       bool is_wild_match,
5551                       domain_enum domain,
5552                       int global,
5553                       match_data &data)
5554 {
5555   data.objfile = objfile;
5556   objfile->expand_matching_symbols (lookup_name, domain, global,
5557                                     is_wild_match ? nullptr : compare_names);
5558
5559   const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5560   for (compunit_symtab *symtab : objfile->compunits ())
5561     {
5562       const struct block *block
5563         = BLOCKVECTOR_BLOCK (symtab->blockvector (), block_kind);
5564       if (!iterate_over_symbols_terminated (block, lookup_name,
5565                                             domain, data))
5566         break;
5567     }
5568 }
5569
5570 /* Add to RESULT all non-local symbols whose name and domain match
5571    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5572    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5573    symbols otherwise.  */
5574
5575 static void
5576 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5577                       const lookup_name_info &lookup_name,
5578                       domain_enum domain, int global)
5579 {
5580   struct match_data data (&result);
5581
5582   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5583
5584   for (objfile *objfile : current_program_space->objfiles ())
5585     {
5586       map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5587                             global, data);
5588
5589       for (compunit_symtab *cu : objfile->compunits ())
5590         {
5591           const struct block *global_block
5592             = BLOCKVECTOR_BLOCK (cu->blockvector (), GLOBAL_BLOCK);
5593
5594           if (ada_add_block_renamings (result, global_block, lookup_name,
5595                                        domain))
5596             data.found_sym = true;
5597         }
5598     }
5599
5600   if (result.empty () && global && !is_wild_match)
5601     {
5602       const char *name = ada_lookup_name (lookup_name);
5603       std::string bracket_name = std::string ("<_ada_") + name + '>';
5604       lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5605
5606       for (objfile *objfile : current_program_space->objfiles ())
5607         map_matching_symbols (objfile, name1, false, domain, global, data);
5608     }
5609 }
5610
5611 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5612    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5613    returning the number of matches.  Add these to RESULT.
5614
5615    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5616    symbol match within the nest of blocks whose innermost member is BLOCK,
5617    is the one match returned (no other matches in that or
5618    enclosing blocks is returned).  If there are any matches in or
5619    surrounding BLOCK, then these alone are returned.
5620
5621    Names prefixed with "standard__" are handled specially:
5622    "standard__" is first stripped off (by the lookup_name
5623    constructor), and only static and global symbols are searched.
5624
5625    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5626    to lookup global symbols.  */
5627
5628 static void
5629 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5630                      const struct block *block,
5631                      const lookup_name_info &lookup_name,
5632                      domain_enum domain,
5633                      int full_search,
5634                      int *made_global_lookup_p)
5635 {
5636   struct symbol *sym;
5637
5638   if (made_global_lookup_p)
5639     *made_global_lookup_p = 0;
5640
5641   /* Special case: If the user specifies a symbol name inside package
5642      Standard, do a non-wild matching of the symbol name without
5643      the "standard__" prefix.  This was primarily introduced in order
5644      to allow the user to specifically access the standard exceptions
5645      using, for instance, Standard.Constraint_Error when Constraint_Error
5646      is ambiguous (due to the user defining its own Constraint_Error
5647      entity inside its program).  */
5648   if (lookup_name.ada ().standard_p ())
5649     block = NULL;
5650
5651   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5652
5653   if (block != NULL)
5654     {
5655       if (full_search)
5656         ada_add_local_symbols (result, lookup_name, block, domain);
5657       else
5658         {
5659           /* In the !full_search case we're are being called by
5660              iterate_over_symbols, and we don't want to search
5661              superblocks.  */
5662           ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5663         }
5664       if (!result.empty () || !full_search)
5665         return;
5666     }
5667
5668   /* No non-global symbols found.  Check our cache to see if we have
5669      already performed this search before.  If we have, then return
5670      the same result.  */
5671
5672   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5673                             domain, &sym, &block))
5674     {
5675       if (sym != NULL)
5676         add_defn_to_vec (result, sym, block);
5677       return;
5678     }
5679
5680   if (made_global_lookup_p)
5681     *made_global_lookup_p = 1;
5682
5683   /* Search symbols from all global blocks.  */
5684  
5685   add_nonlocal_symbols (result, lookup_name, domain, 1);
5686
5687   /* Now add symbols from all per-file blocks if we've gotten no hits
5688      (not strictly correct, but perhaps better than an error).  */
5689
5690   if (result.empty ())
5691     add_nonlocal_symbols (result, lookup_name, domain, 0);
5692 }
5693
5694 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5695    is non-zero, enclosing scope and in global scopes.
5696
5697    Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5698    blocks and symbol tables (if any) in which they were found.
5699
5700    When full_search is non-zero, any non-function/non-enumeral
5701    symbol match within the nest of blocks whose innermost member is BLOCK,
5702    is the one match returned (no other matches in that or
5703    enclosing blocks is returned).  If there are any matches in or
5704    surrounding BLOCK, then these alone are returned.
5705
5706    Names prefixed with "standard__" are handled specially: "standard__"
5707    is first stripped off, and only static and global symbols are searched.  */
5708
5709 static std::vector<struct block_symbol>
5710 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5711                                const struct block *block,
5712                                domain_enum domain,
5713                                int full_search)
5714 {
5715   int syms_from_global_search;
5716   std::vector<struct block_symbol> results;
5717
5718   ada_add_all_symbols (results, block, lookup_name,
5719                        domain, full_search, &syms_from_global_search);
5720
5721   remove_extra_symbols (&results);
5722
5723   if (results.empty () && full_search && syms_from_global_search)
5724     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5725
5726   if (results.size () == 1 && full_search && syms_from_global_search)
5727     cache_symbol (ada_lookup_name (lookup_name), domain,
5728                   results[0].symbol, results[0].block);
5729
5730   remove_irrelevant_renamings (&results, block);
5731   return results;
5732 }
5733
5734 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5735    in global scopes, returning (SYM,BLOCK) tuples.
5736
5737    See ada_lookup_symbol_list_worker for further details.  */
5738
5739 std::vector<struct block_symbol>
5740 ada_lookup_symbol_list (const char *name, const struct block *block,
5741                         domain_enum domain)
5742 {
5743   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5744   lookup_name_info lookup_name (name, name_match_type);
5745
5746   return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5747 }
5748
5749 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5750    to 1, but choosing the first symbol found if there are multiple
5751    choices.
5752
5753    The result is stored in *INFO, which must be non-NULL.
5754    If no match is found, INFO->SYM is set to NULL.  */
5755
5756 void
5757 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5758                            domain_enum domain,
5759                            struct block_symbol *info)
5760 {
5761   /* Since we already have an encoded name, wrap it in '<>' to force a
5762      verbatim match.  Otherwise, if the name happens to not look like
5763      an encoded name (because it doesn't include a "__"),
5764      ada_lookup_name_info would re-encode/fold it again, and that
5765      would e.g., incorrectly lowercase object renaming names like
5766      "R28b" -> "r28b".  */
5767   std::string verbatim = add_angle_brackets (name);
5768
5769   gdb_assert (info != NULL);
5770   *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5771 }
5772
5773 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5774    scope and in global scopes, or NULL if none.  NAME is folded and
5775    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5776    choosing the first symbol if there are multiple choices.  */
5777
5778 struct block_symbol
5779 ada_lookup_symbol (const char *name, const struct block *block0,
5780                    domain_enum domain)
5781 {
5782   std::vector<struct block_symbol> candidates
5783     = ada_lookup_symbol_list (name, block0, domain);
5784
5785   if (candidates.empty ())
5786     return {};
5787
5788   block_symbol info = candidates[0];
5789   info.symbol = fixup_symbol_section (info.symbol, NULL);
5790   return info;
5791 }
5792
5793
5794 /* True iff STR is a possible encoded suffix of a normal Ada name
5795    that is to be ignored for matching purposes.  Suffixes of parallel
5796    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5797    are given by any of the regular expressions:
5798
5799    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5800    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5801    TKB              [subprogram suffix for task bodies]
5802    _E[0-9]+[bs]$    [protected object entry suffixes]
5803    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5804
5805    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5806    match is performed.  This sequence is used to differentiate homonyms,
5807    is an optional part of a valid name suffix.  */
5808
5809 static int
5810 is_name_suffix (const char *str)
5811 {
5812   int k;
5813   const char *matching;
5814   const int len = strlen (str);
5815
5816   /* Skip optional leading __[0-9]+.  */
5817
5818   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5819     {
5820       str += 3;
5821       while (isdigit (str[0]))
5822         str += 1;
5823     }
5824   
5825   /* [.$][0-9]+ */
5826
5827   if (str[0] == '.' || str[0] == '$')
5828     {
5829       matching = str + 1;
5830       while (isdigit (matching[0]))
5831         matching += 1;
5832       if (matching[0] == '\0')
5833         return 1;
5834     }
5835
5836   /* ___[0-9]+ */
5837
5838   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5839     {
5840       matching = str + 3;
5841       while (isdigit (matching[0]))
5842         matching += 1;
5843       if (matching[0] == '\0')
5844         return 1;
5845     }
5846
5847   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
5848
5849   if (strcmp (str, "TKB") == 0)
5850     return 1;
5851
5852 #if 0
5853   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5854      with a N at the end.  Unfortunately, the compiler uses the same
5855      convention for other internal types it creates.  So treating
5856      all entity names that end with an "N" as a name suffix causes
5857      some regressions.  For instance, consider the case of an enumerated
5858      type.  To support the 'Image attribute, it creates an array whose
5859      name ends with N.
5860      Having a single character like this as a suffix carrying some
5861      information is a bit risky.  Perhaps we should change the encoding
5862      to be something like "_N" instead.  In the meantime, do not do
5863      the following check.  */
5864   /* Protected Object Subprograms */
5865   if (len == 1 && str [0] == 'N')
5866     return 1;
5867 #endif
5868
5869   /* _E[0-9]+[bs]$ */
5870   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5871     {
5872       matching = str + 3;
5873       while (isdigit (matching[0]))
5874         matching += 1;
5875       if ((matching[0] == 'b' || matching[0] == 's')
5876           && matching [1] == '\0')
5877         return 1;
5878     }
5879
5880   /* ??? We should not modify STR directly, as we are doing below.  This
5881      is fine in this case, but may become problematic later if we find
5882      that this alternative did not work, and want to try matching
5883      another one from the begining of STR.  Since we modified it, we
5884      won't be able to find the begining of the string anymore!  */
5885   if (str[0] == 'X')
5886     {
5887       str += 1;
5888       while (str[0] != '_' && str[0] != '\0')
5889         {
5890           if (str[0] != 'n' && str[0] != 'b')
5891             return 0;
5892           str += 1;
5893         }
5894     }
5895
5896   if (str[0] == '\000')
5897     return 1;
5898
5899   if (str[0] == '_')
5900     {
5901       if (str[1] != '_' || str[2] == '\000')
5902         return 0;
5903       if (str[2] == '_')
5904         {
5905           if (strcmp (str + 3, "JM") == 0)
5906             return 1;
5907           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5908              the LJM suffix in favor of the JM one.  But we will
5909              still accept LJM as a valid suffix for a reasonable
5910              amount of time, just to allow ourselves to debug programs
5911              compiled using an older version of GNAT.  */
5912           if (strcmp (str + 3, "LJM") == 0)
5913             return 1;
5914           if (str[3] != 'X')
5915             return 0;
5916           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5917               || str[4] == 'U' || str[4] == 'P')
5918             return 1;
5919           if (str[4] == 'R' && str[5] != 'T')
5920             return 1;
5921           return 0;
5922         }
5923       if (!isdigit (str[2]))
5924         return 0;
5925       for (k = 3; str[k] != '\0'; k += 1)
5926         if (!isdigit (str[k]) && str[k] != '_')
5927           return 0;
5928       return 1;
5929     }
5930   if (str[0] == '$' && isdigit (str[1]))
5931     {
5932       for (k = 2; str[k] != '\0'; k += 1)
5933         if (!isdigit (str[k]) && str[k] != '_')
5934           return 0;
5935       return 1;
5936     }
5937   return 0;
5938 }
5939
5940 /* Return non-zero if the string starting at NAME and ending before
5941    NAME_END contains no capital letters.  */
5942
5943 static int
5944 is_valid_name_for_wild_match (const char *name0)
5945 {
5946   std::string decoded_name = ada_decode (name0);
5947   int i;
5948
5949   /* If the decoded name starts with an angle bracket, it means that
5950      NAME0 does not follow the GNAT encoding format.  It should then
5951      not be allowed as a possible wild match.  */
5952   if (decoded_name[0] == '<')
5953     return 0;
5954
5955   for (i=0; decoded_name[i] != '\0'; i++)
5956     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5957       return 0;
5958
5959   return 1;
5960 }
5961
5962 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5963    character which could start a simple name.  Assumes that *NAMEP points
5964    somewhere inside the string beginning at NAME0.  */
5965
5966 static int
5967 advance_wild_match (const char **namep, const char *name0, char target0)
5968 {
5969   const char *name = *namep;
5970
5971   while (1)
5972     {
5973       char t0, t1;
5974
5975       t0 = *name;
5976       if (t0 == '_')
5977         {
5978           t1 = name[1];
5979           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5980             {
5981               name += 1;
5982               if (name == name0 + 5 && startswith (name0, "_ada"))
5983                 break;
5984               else
5985                 name += 1;
5986             }
5987           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5988                                  || name[2] == target0))
5989             {
5990               name += 2;
5991               break;
5992             }
5993           else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
5994             {
5995               /* Names like "pkg__B_N__name", where N is a number, are
5996                  block-local.  We can handle these by simply skipping
5997                  the "B_" here.  */
5998               name += 4;
5999             }
6000           else
6001             return 0;
6002         }
6003       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6004         name += 1;
6005       else
6006         return 0;
6007     }
6008
6009   *namep = name;
6010   return 1;
6011 }
6012
6013 /* Return true iff NAME encodes a name of the form prefix.PATN.
6014    Ignores any informational suffixes of NAME (i.e., for which
6015    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
6016    simple name.  */
6017
6018 static bool
6019 wild_match (const char *name, const char *patn)
6020 {
6021   const char *p;
6022   const char *name0 = name;
6023
6024   if (startswith (name, "___ghost_"))
6025     name += 9;
6026
6027   while (1)
6028     {
6029       const char *match = name;
6030
6031       if (*name == *patn)
6032         {
6033           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6034             if (*p != *name)
6035               break;
6036           if (*p == '\0' && is_name_suffix (name))
6037             return match == name0 || is_valid_name_for_wild_match (name0);
6038
6039           if (name[-1] == '_')
6040             name -= 1;
6041         }
6042       if (!advance_wild_match (&name, name0, *patn))
6043         return false;
6044     }
6045 }
6046
6047 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
6048    necessary).  OBJFILE is the section containing BLOCK.  */
6049
6050 static void
6051 ada_add_block_symbols (std::vector<struct block_symbol> &result,
6052                        const struct block *block,
6053                        const lookup_name_info &lookup_name,
6054                        domain_enum domain, struct objfile *objfile)
6055 {
6056   struct block_iterator iter;
6057   /* A matching argument symbol, if any.  */
6058   struct symbol *arg_sym;
6059   /* Set true when we find a matching non-argument symbol.  */
6060   bool found_sym;
6061   struct symbol *sym;
6062
6063   arg_sym = NULL;
6064   found_sym = false;
6065   for (sym = block_iter_match_first (block, lookup_name, &iter);
6066        sym != NULL;
6067        sym = block_iter_match_next (lookup_name, &iter))
6068     {
6069       if (symbol_matches_domain (sym->language (), sym->domain (), domain))
6070         {
6071           if (sym->aclass () != LOC_UNRESOLVED)
6072             {
6073               if (sym->is_argument ())
6074                 arg_sym = sym;
6075               else
6076                 {
6077                   found_sym = true;
6078                   add_defn_to_vec (result,
6079                                    fixup_symbol_section (sym, objfile),
6080                                    block);
6081                 }
6082             }
6083         }
6084     }
6085
6086   /* Handle renamings.  */
6087
6088   if (ada_add_block_renamings (result, block, lookup_name, domain))
6089     found_sym = true;
6090
6091   if (!found_sym && arg_sym != NULL)
6092     {
6093       add_defn_to_vec (result,
6094                        fixup_symbol_section (arg_sym, objfile),
6095                        block);
6096     }
6097
6098   if (!lookup_name.ada ().wild_match_p ())
6099     {
6100       arg_sym = NULL;
6101       found_sym = false;
6102       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6103       const char *name = ada_lookup_name.c_str ();
6104       size_t name_len = ada_lookup_name.size ();
6105
6106       ALL_BLOCK_SYMBOLS (block, iter, sym)
6107       {
6108         if (symbol_matches_domain (sym->language (),
6109                                    sym->domain (), domain))
6110           {
6111             int cmp;
6112
6113             cmp = (int) '_' - (int) sym->linkage_name ()[0];
6114             if (cmp == 0)
6115               {
6116                 cmp = !startswith (sym->linkage_name (), "_ada_");
6117                 if (cmp == 0)
6118                   cmp = strncmp (name, sym->linkage_name () + 5,
6119                                  name_len);
6120               }
6121
6122             if (cmp == 0
6123                 && is_name_suffix (sym->linkage_name () + name_len + 5))
6124               {
6125                 if (sym->aclass () != LOC_UNRESOLVED)
6126                   {
6127                     if (sym->is_argument ())
6128                       arg_sym = sym;
6129                     else
6130                       {
6131                         found_sym = true;
6132                         add_defn_to_vec (result,
6133                                          fixup_symbol_section (sym, objfile),
6134                                          block);
6135                       }
6136                   }
6137               }
6138           }
6139       }
6140
6141       /* NOTE: This really shouldn't be needed for _ada_ symbols.
6142          They aren't parameters, right?  */
6143       if (!found_sym && arg_sym != NULL)
6144         {
6145           add_defn_to_vec (result,
6146                            fixup_symbol_section (arg_sym, objfile),
6147                            block);
6148         }
6149     }
6150 }
6151 \f
6152
6153                                 /* Symbol Completion */
6154
6155 /* See symtab.h.  */
6156
6157 bool
6158 ada_lookup_name_info::matches
6159   (const char *sym_name,
6160    symbol_name_match_type match_type,
6161    completion_match_result *comp_match_res) const
6162 {
6163   bool match = false;
6164   const char *text = m_encoded_name.c_str ();
6165   size_t text_len = m_encoded_name.size ();
6166
6167   /* First, test against the fully qualified name of the symbol.  */
6168
6169   if (strncmp (sym_name, text, text_len) == 0)
6170     match = true;
6171
6172   std::string decoded_name = ada_decode (sym_name);
6173   if (match && !m_encoded_p)
6174     {
6175       /* One needed check before declaring a positive match is to verify
6176          that iff we are doing a verbatim match, the decoded version
6177          of the symbol name starts with '<'.  Otherwise, this symbol name
6178          is not a suitable completion.  */
6179
6180       bool has_angle_bracket = (decoded_name[0] == '<');
6181       match = (has_angle_bracket == m_verbatim_p);
6182     }
6183
6184   if (match && !m_verbatim_p)
6185     {
6186       /* When doing non-verbatim match, another check that needs to
6187          be done is to verify that the potentially matching symbol name
6188          does not include capital letters, because the ada-mode would
6189          not be able to understand these symbol names without the
6190          angle bracket notation.  */
6191       const char *tmp;
6192
6193       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6194       if (*tmp != '\0')
6195         match = false;
6196     }
6197
6198   /* Second: Try wild matching...  */
6199
6200   if (!match && m_wild_match_p)
6201     {
6202       /* Since we are doing wild matching, this means that TEXT
6203          may represent an unqualified symbol name.  We therefore must
6204          also compare TEXT against the unqualified name of the symbol.  */
6205       sym_name = ada_unqualified_name (decoded_name.c_str ());
6206
6207       if (strncmp (sym_name, text, text_len) == 0)
6208         match = true;
6209     }
6210
6211   /* Finally: If we found a match, prepare the result to return.  */
6212
6213   if (!match)
6214     return false;
6215
6216   if (comp_match_res != NULL)
6217     {
6218       std::string &match_str = comp_match_res->match.storage ();
6219
6220       if (!m_encoded_p)
6221         match_str = ada_decode (sym_name);
6222       else
6223         {
6224           if (m_verbatim_p)
6225             match_str = add_angle_brackets (sym_name);
6226           else
6227             match_str = sym_name;
6228
6229         }
6230
6231       comp_match_res->set_match (match_str.c_str ());
6232     }
6233
6234   return true;
6235 }
6236
6237                                 /* Field Access */
6238
6239 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6240    for tagged types.  */
6241
6242 static int
6243 ada_is_dispatch_table_ptr_type (struct type *type)
6244 {
6245   const char *name;
6246
6247   if (type->code () != TYPE_CODE_PTR)
6248     return 0;
6249
6250   name = TYPE_TARGET_TYPE (type)->name ();
6251   if (name == NULL)
6252     return 0;
6253
6254   return (strcmp (name, "ada__tags__dispatch_table") == 0);
6255 }
6256
6257 /* Return non-zero if TYPE is an interface tag.  */
6258
6259 static int
6260 ada_is_interface_tag (struct type *type)
6261 {
6262   const char *name = type->name ();
6263
6264   if (name == NULL)
6265     return 0;
6266
6267   return (strcmp (name, "ada__tags__interface_tag") == 0);
6268 }
6269
6270 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6271    to be invisible to users.  */
6272
6273 int
6274 ada_is_ignored_field (struct type *type, int field_num)
6275 {
6276   if (field_num < 0 || field_num > type->num_fields ())
6277     return 1;
6278
6279   /* Check the name of that field.  */
6280   {
6281     const char *name = type->field (field_num).name ();
6282
6283     /* Anonymous field names should not be printed.
6284        brobecker/2007-02-20: I don't think this can actually happen
6285        but we don't want to print the value of anonymous fields anyway.  */
6286     if (name == NULL)
6287       return 1;
6288
6289     /* Normally, fields whose name start with an underscore ("_")
6290        are fields that have been internally generated by the compiler,
6291        and thus should not be printed.  The "_parent" field is special,
6292        however: This is a field internally generated by the compiler
6293        for tagged types, and it contains the components inherited from
6294        the parent type.  This field should not be printed as is, but
6295        should not be ignored either.  */
6296     if (name[0] == '_' && !startswith (name, "_parent"))
6297       return 1;
6298
6299     /* The compiler doesn't document this, but sometimes it emits
6300        a field whose name starts with a capital letter, like 'V148s'.
6301        These aren't marked as artificial in any way, but we know they
6302        should be ignored.  However, wrapper fields should not be
6303        ignored.  */
6304     if (name[0] == 'S' || name[0] == 'R' || name[0] == 'O')
6305       {
6306         /* Wrapper field.  */
6307       }
6308     else if (isupper (name[0]))
6309       return 1;
6310   }
6311
6312   /* If this is the dispatch table of a tagged type or an interface tag,
6313      then ignore.  */
6314   if (ada_is_tagged_type (type, 1)
6315       && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
6316           || ada_is_interface_tag (type->field (field_num).type ())))
6317     return 1;
6318
6319   /* Not a special field, so it should not be ignored.  */
6320   return 0;
6321 }
6322
6323 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
6324    pointer or reference type whose ultimate target has a tag field.  */
6325
6326 int
6327 ada_is_tagged_type (struct type *type, int refok)
6328 {
6329   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6330 }
6331
6332 /* True iff TYPE represents the type of X'Tag */
6333
6334 int
6335 ada_is_tag_type (struct type *type)
6336 {
6337   type = ada_check_typedef (type);
6338
6339   if (type == NULL || type->code () != TYPE_CODE_PTR)
6340     return 0;
6341   else
6342     {
6343       const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6344
6345       return (name != NULL
6346               && strcmp (name, "ada__tags__dispatch_table") == 0);
6347     }
6348 }
6349
6350 /* The type of the tag on VAL.  */
6351
6352 static struct type *
6353 ada_tag_type (struct value *val)
6354 {
6355   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6356 }
6357
6358 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6359    retired at Ada 05).  */
6360
6361 static int
6362 is_ada95_tag (struct value *tag)
6363 {
6364   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6365 }
6366
6367 /* The value of the tag on VAL.  */
6368
6369 static struct value *
6370 ada_value_tag (struct value *val)
6371 {
6372   return ada_value_struct_elt (val, "_tag", 0);
6373 }
6374
6375 /* The value of the tag on the object of type TYPE whose contents are
6376    saved at VALADDR, if it is non-null, or is at memory address
6377    ADDRESS.  */
6378
6379 static struct value *
6380 value_tag_from_contents_and_address (struct type *type,
6381                                      const gdb_byte *valaddr,
6382                                      CORE_ADDR address)
6383 {
6384   int tag_byte_offset;
6385   struct type *tag_type;
6386
6387   gdb::array_view<const gdb_byte> contents;
6388   if (valaddr != nullptr)
6389     contents = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
6390   struct type *resolved_type = resolve_dynamic_type (type, contents, address);
6391   if (find_struct_field ("_tag", resolved_type, 0, &tag_type, &tag_byte_offset,
6392                          NULL, NULL, NULL))
6393     {
6394       const gdb_byte *valaddr1 = ((valaddr == NULL)
6395                                   ? NULL
6396                                   : valaddr + tag_byte_offset);
6397       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6398
6399       return value_from_contents_and_address (tag_type, valaddr1, address1);
6400     }
6401   return NULL;
6402 }
6403
6404 static struct type *
6405 type_from_tag (struct value *tag)
6406 {
6407   gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6408
6409   if (type_name != NULL)
6410     return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6411   return NULL;
6412 }
6413
6414 /* Given a value OBJ of a tagged type, return a value of this
6415    type at the base address of the object.  The base address, as
6416    defined in Ada.Tags, it is the address of the primary tag of
6417    the object, and therefore where the field values of its full
6418    view can be fetched.  */
6419
6420 struct value *
6421 ada_tag_value_at_base_address (struct value *obj)
6422 {
6423   struct value *val;
6424   LONGEST offset_to_top = 0;
6425   struct type *ptr_type, *obj_type;
6426   struct value *tag;
6427   CORE_ADDR base_address;
6428
6429   obj_type = value_type (obj);
6430
6431   /* It is the responsability of the caller to deref pointers.  */
6432
6433   if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6434     return obj;
6435
6436   tag = ada_value_tag (obj);
6437   if (!tag)
6438     return obj;
6439
6440   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6441
6442   if (is_ada95_tag (tag))
6443     return obj;
6444
6445   struct type *offset_type
6446     = language_lookup_primitive_type (language_def (language_ada),
6447                                       target_gdbarch(), "storage_offset");
6448   ptr_type = lookup_pointer_type (offset_type);
6449   val = value_cast (ptr_type, tag);
6450   if (!val)
6451     return obj;
6452
6453   /* It is perfectly possible that an exception be raised while
6454      trying to determine the base address, just like for the tag;
6455      see ada_tag_name for more details.  We do not print the error
6456      message for the same reason.  */
6457
6458   try
6459     {
6460       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6461     }
6462
6463   catch (const gdb_exception_error &e)
6464     {
6465       return obj;
6466     }
6467
6468   /* If offset is null, nothing to do.  */
6469
6470   if (offset_to_top == 0)
6471     return obj;
6472
6473   /* -1 is a special case in Ada.Tags; however, what should be done
6474      is not quite clear from the documentation.  So do nothing for
6475      now.  */
6476
6477   if (offset_to_top == -1)
6478     return obj;
6479
6480   /* Storage_Offset'Last is used to indicate that a dynamic offset to
6481      top is used.  In this situation the offset is stored just after
6482      the tag, in the object itself.  */
6483   ULONGEST last = (((ULONGEST) 1) << (8 * TYPE_LENGTH (offset_type) - 1)) - 1;
6484   if (offset_to_top == last)
6485     {
6486       struct value *tem = value_addr (tag);
6487       tem = value_ptradd (tem, 1);
6488       tem = value_cast (ptr_type, tem);
6489       offset_to_top = value_as_long (value_ind (tem));
6490     }
6491   else if (offset_to_top > 0)
6492     {
6493       /* OFFSET_TO_TOP used to be a positive value to be subtracted
6494          from the base address.  This was however incompatible with
6495          C++ dispatch table: C++ uses a *negative* value to *add*
6496          to the base address.  Ada's convention has therefore been
6497          changed in GNAT 19.0w 20171023: since then, C++ and Ada
6498          use the same convention.  Here, we support both cases by
6499          checking the sign of OFFSET_TO_TOP.  */
6500       offset_to_top = -offset_to_top;
6501     }
6502
6503   base_address = value_address (obj) + offset_to_top;
6504   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6505
6506   /* Make sure that we have a proper tag at the new address.
6507      Otherwise, offset_to_top is bogus (which can happen when
6508      the object is not initialized yet).  */
6509
6510   if (!tag)
6511     return obj;
6512
6513   obj_type = type_from_tag (tag);
6514
6515   if (!obj_type)
6516     return obj;
6517
6518   return value_from_contents_and_address (obj_type, NULL, base_address);
6519 }
6520
6521 /* Return the "ada__tags__type_specific_data" type.  */
6522
6523 static struct type *
6524 ada_get_tsd_type (struct inferior *inf)
6525 {
6526   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6527
6528   if (data->tsd_type == 0)
6529     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6530   return data->tsd_type;
6531 }
6532
6533 /* Return the TSD (type-specific data) associated to the given TAG.
6534    TAG is assumed to be the tag of a tagged-type entity.
6535
6536    May return NULL if we are unable to get the TSD.  */
6537
6538 static struct value *
6539 ada_get_tsd_from_tag (struct value *tag)
6540 {
6541   struct value *val;
6542   struct type *type;
6543
6544   /* First option: The TSD is simply stored as a field of our TAG.
6545      Only older versions of GNAT would use this format, but we have
6546      to test it first, because there are no visible markers for
6547      the current approach except the absence of that field.  */
6548
6549   val = ada_value_struct_elt (tag, "tsd", 1);
6550   if (val)
6551     return val;
6552
6553   /* Try the second representation for the dispatch table (in which
6554      there is no explicit 'tsd' field in the referent of the tag pointer,
6555      and instead the tsd pointer is stored just before the dispatch
6556      table.  */
6557
6558   type = ada_get_tsd_type (current_inferior());
6559   if (type == NULL)
6560     return NULL;
6561   type = lookup_pointer_type (lookup_pointer_type (type));
6562   val = value_cast (type, tag);
6563   if (val == NULL)
6564     return NULL;
6565   return value_ind (value_ptradd (val, -1));
6566 }
6567
6568 /* Given the TSD of a tag (type-specific data), return a string
6569    containing the name of the associated type.
6570
6571    May return NULL if we are unable to determine the tag name.  */
6572
6573 static gdb::unique_xmalloc_ptr<char>
6574 ada_tag_name_from_tsd (struct value *tsd)
6575 {
6576   struct value *val;
6577
6578   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6579   if (val == NULL)
6580     return NULL;
6581   gdb::unique_xmalloc_ptr<char> buffer
6582     = target_read_string (value_as_address (val), INT_MAX);
6583   if (buffer == nullptr)
6584     return nullptr;
6585
6586   try
6587     {
6588       /* Let this throw an exception on error.  If the data is
6589          uninitialized, we'd rather not have the user see a
6590          warning.  */
6591       const char *folded = ada_fold_name (buffer.get (), true);
6592       return make_unique_xstrdup (folded);
6593     }
6594   catch (const gdb_exception &)
6595     {
6596       return nullptr;
6597     }
6598 }
6599
6600 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6601    a C string.
6602
6603    Return NULL if the TAG is not an Ada tag, or if we were unable to
6604    determine the name of that tag.  */
6605
6606 gdb::unique_xmalloc_ptr<char>
6607 ada_tag_name (struct value *tag)
6608 {
6609   gdb::unique_xmalloc_ptr<char> name;
6610
6611   if (!ada_is_tag_type (value_type (tag)))
6612     return NULL;
6613
6614   /* It is perfectly possible that an exception be raised while trying
6615      to determine the TAG's name, even under normal circumstances:
6616      The associated variable may be uninitialized or corrupted, for
6617      instance. We do not let any exception propagate past this point.
6618      instead we return NULL.
6619
6620      We also do not print the error message either (which often is very
6621      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6622      the caller print a more meaningful message if necessary.  */
6623   try
6624     {
6625       struct value *tsd = ada_get_tsd_from_tag (tag);
6626
6627       if (tsd != NULL)
6628         name = ada_tag_name_from_tsd (tsd);
6629     }
6630   catch (const gdb_exception_error &e)
6631     {
6632     }
6633
6634   return name;
6635 }
6636
6637 /* The parent type of TYPE, or NULL if none.  */
6638
6639 struct type *
6640 ada_parent_type (struct type *type)
6641 {
6642   int i;
6643
6644   type = ada_check_typedef (type);
6645
6646   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6647     return NULL;
6648
6649   for (i = 0; i < type->num_fields (); i += 1)
6650     if (ada_is_parent_field (type, i))
6651       {
6652         struct type *parent_type = type->field (i).type ();
6653
6654         /* If the _parent field is a pointer, then dereference it.  */
6655         if (parent_type->code () == TYPE_CODE_PTR)
6656           parent_type = TYPE_TARGET_TYPE (parent_type);
6657         /* If there is a parallel XVS type, get the actual base type.  */
6658         parent_type = ada_get_base_type (parent_type);
6659
6660         return ada_check_typedef (parent_type);
6661       }
6662
6663   return NULL;
6664 }
6665
6666 /* True iff field number FIELD_NUM of structure type TYPE contains the
6667    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6668    a structure type with at least FIELD_NUM+1 fields.  */
6669
6670 int
6671 ada_is_parent_field (struct type *type, int field_num)
6672 {
6673   const char *name = ada_check_typedef (type)->field (field_num).name ();
6674
6675   return (name != NULL
6676           && (startswith (name, "PARENT")
6677               || startswith (name, "_parent")));
6678 }
6679
6680 /* True iff field number FIELD_NUM of structure type TYPE is a
6681    transparent wrapper field (which should be silently traversed when doing
6682    field selection and flattened when printing).  Assumes TYPE is a
6683    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6684    structures.  */
6685
6686 int
6687 ada_is_wrapper_field (struct type *type, int field_num)
6688 {
6689   const char *name = type->field (field_num).name ();
6690
6691   if (name != NULL && strcmp (name, "RETVAL") == 0)
6692     {
6693       /* This happens in functions with "out" or "in out" parameters
6694          which are passed by copy.  For such functions, GNAT describes
6695          the function's return type as being a struct where the return
6696          value is in a field called RETVAL, and where the other "out"
6697          or "in out" parameters are fields of that struct.  This is not
6698          a wrapper.  */
6699       return 0;
6700     }
6701
6702   return (name != NULL
6703           && (startswith (name, "PARENT")
6704               || strcmp (name, "REP") == 0
6705               || startswith (name, "_parent")
6706               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6707 }
6708
6709 /* True iff field number FIELD_NUM of structure or union type TYPE
6710    is a variant wrapper.  Assumes TYPE is a structure type with at least
6711    FIELD_NUM+1 fields.  */
6712
6713 int
6714 ada_is_variant_part (struct type *type, int field_num)
6715 {
6716   /* Only Ada types are eligible.  */
6717   if (!ADA_TYPE_P (type))
6718     return 0;
6719
6720   struct type *field_type = type->field (field_num).type ();
6721
6722   return (field_type->code () == TYPE_CODE_UNION
6723           || (is_dynamic_field (type, field_num)
6724               && (TYPE_TARGET_TYPE (field_type)->code ()
6725                   == TYPE_CODE_UNION)));
6726 }
6727
6728 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6729    whose discriminants are contained in the record type OUTER_TYPE,
6730    returns the type of the controlling discriminant for the variant.
6731    May return NULL if the type could not be found.  */
6732
6733 struct type *
6734 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6735 {
6736   const char *name = ada_variant_discrim_name (var_type);
6737
6738   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6739 }
6740
6741 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6742    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6743    represents a 'when others' clause; otherwise 0.  */
6744
6745 static int
6746 ada_is_others_clause (struct type *type, int field_num)
6747 {
6748   const char *name = type->field (field_num).name ();
6749
6750   return (name != NULL && name[0] == 'O');
6751 }
6752
6753 /* Assuming that TYPE0 is the type of the variant part of a record,
6754    returns the name of the discriminant controlling the variant.
6755    The value is valid until the next call to ada_variant_discrim_name.  */
6756
6757 const char *
6758 ada_variant_discrim_name (struct type *type0)
6759 {
6760   static std::string result;
6761   struct type *type;
6762   const char *name;
6763   const char *discrim_end;
6764   const char *discrim_start;
6765
6766   if (type0->code () == TYPE_CODE_PTR)
6767     type = TYPE_TARGET_TYPE (type0);
6768   else
6769     type = type0;
6770
6771   name = ada_type_name (type);
6772
6773   if (name == NULL || name[0] == '\000')
6774     return "";
6775
6776   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6777        discrim_end -= 1)
6778     {
6779       if (startswith (discrim_end, "___XVN"))
6780         break;
6781     }
6782   if (discrim_end == name)
6783     return "";
6784
6785   for (discrim_start = discrim_end; discrim_start != name + 3;
6786        discrim_start -= 1)
6787     {
6788       if (discrim_start == name + 1)
6789         return "";
6790       if ((discrim_start > name + 3
6791            && startswith (discrim_start - 3, "___"))
6792           || discrim_start[-1] == '.')
6793         break;
6794     }
6795
6796   result = std::string (discrim_start, discrim_end - discrim_start);
6797   return result.c_str ();
6798 }
6799
6800 /* Scan STR for a subtype-encoded number, beginning at position K.
6801    Put the position of the character just past the number scanned in
6802    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
6803    Return 1 if there was a valid number at the given position, and 0
6804    otherwise.  A "subtype-encoded" number consists of the absolute value
6805    in decimal, followed by the letter 'm' to indicate a negative number.
6806    Assumes 0m does not occur.  */
6807
6808 int
6809 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6810 {
6811   ULONGEST RU;
6812
6813   if (!isdigit (str[k]))
6814     return 0;
6815
6816   /* Do it the hard way so as not to make any assumption about
6817      the relationship of unsigned long (%lu scan format code) and
6818      LONGEST.  */
6819   RU = 0;
6820   while (isdigit (str[k]))
6821     {
6822       RU = RU * 10 + (str[k] - '0');
6823       k += 1;
6824     }
6825
6826   if (str[k] == 'm')
6827     {
6828       if (R != NULL)
6829         *R = (-(LONGEST) (RU - 1)) - 1;
6830       k += 1;
6831     }
6832   else if (R != NULL)
6833     *R = (LONGEST) RU;
6834
6835   /* NOTE on the above: Technically, C does not say what the results of
6836      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6837      number representable as a LONGEST (although either would probably work
6838      in most implementations).  When RU>0, the locution in the then branch
6839      above is always equivalent to the negative of RU.  */
6840
6841   if (new_k != NULL)
6842     *new_k = k;
6843   return 1;
6844 }
6845
6846 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6847    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6848    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
6849
6850 static int
6851 ada_in_variant (LONGEST val, struct type *type, int field_num)
6852 {
6853   const char *name = type->field (field_num).name ();
6854   int p;
6855
6856   p = 0;
6857   while (1)
6858     {
6859       switch (name[p])
6860         {
6861         case '\0':
6862           return 0;
6863         case 'S':
6864           {
6865             LONGEST W;
6866
6867             if (!ada_scan_number (name, p + 1, &W, &p))
6868               return 0;
6869             if (val == W)
6870               return 1;
6871             break;
6872           }
6873         case 'R':
6874           {
6875             LONGEST L, U;
6876
6877             if (!ada_scan_number (name, p + 1, &L, &p)
6878                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6879               return 0;
6880             if (val >= L && val <= U)
6881               return 1;
6882             break;
6883           }
6884         case 'O':
6885           return 1;
6886         default:
6887           return 0;
6888         }
6889     }
6890 }
6891
6892 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
6893
6894 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6895    ARG_TYPE, extract and return the value of one of its (non-static)
6896    fields.  FIELDNO says which field.   Differs from value_primitive_field
6897    only in that it can handle packed values of arbitrary type.  */
6898
6899 struct value *
6900 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6901                            struct type *arg_type)
6902 {
6903   struct type *type;
6904
6905   arg_type = ada_check_typedef (arg_type);
6906   type = arg_type->field (fieldno).type ();
6907
6908   /* Handle packed fields.  It might be that the field is not packed
6909      relative to its containing structure, but the structure itself is
6910      packed; in this case we must take the bit-field path.  */
6911   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6912     {
6913       int bit_pos = arg_type->field (fieldno).loc_bitpos ();
6914       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6915
6916       return ada_value_primitive_packed_val (arg1,
6917                                              value_contents (arg1).data (),
6918                                              offset + bit_pos / 8,
6919                                              bit_pos % 8, bit_size, type);
6920     }
6921   else
6922     return value_primitive_field (arg1, offset, fieldno, arg_type);
6923 }
6924
6925 /* Find field with name NAME in object of type TYPE.  If found, 
6926    set the following for each argument that is non-null:
6927     - *FIELD_TYPE_P to the field's type; 
6928     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
6929       an object of that type;
6930     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
6931     - *BIT_SIZE_P to its size in bits if the field is packed, and 
6932       0 otherwise;
6933    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6934    fields up to but not including the desired field, or by the total
6935    number of fields if not found.   A NULL value of NAME never
6936    matches; the function just counts visible fields in this case.
6937    
6938    Notice that we need to handle when a tagged record hierarchy
6939    has some components with the same name, like in this scenario:
6940
6941       type Top_T is tagged record
6942          N : Integer := 1;
6943          U : Integer := 974;
6944          A : Integer := 48;
6945       end record;
6946
6947       type Middle_T is new Top.Top_T with record
6948          N : Character := 'a';
6949          C : Integer := 3;
6950       end record;
6951
6952      type Bottom_T is new Middle.Middle_T with record
6953         N : Float := 4.0;
6954         C : Character := '5';
6955         X : Integer := 6;
6956         A : Character := 'J';
6957      end record;
6958
6959    Let's say we now have a variable declared and initialized as follow:
6960
6961      TC : Top_A := new Bottom_T;
6962
6963    And then we use this variable to call this function
6964
6965      procedure Assign (Obj: in out Top_T; TV : Integer);
6966
6967    as follow:
6968
6969       Assign (Top_T (B), 12);
6970
6971    Now, we're in the debugger, and we're inside that procedure
6972    then and we want to print the value of obj.c:
6973
6974    Usually, the tagged record or one of the parent type owns the
6975    component to print and there's no issue but in this particular
6976    case, what does it mean to ask for Obj.C? Since the actual
6977    type for object is type Bottom_T, it could mean two things: type
6978    component C from the Middle_T view, but also component C from
6979    Bottom_T.  So in that "undefined" case, when the component is
6980    not found in the non-resolved type (which includes all the
6981    components of the parent type), then resolve it and see if we
6982    get better luck once expanded.
6983
6984    In the case of homonyms in the derived tagged type, we don't
6985    guaranty anything, and pick the one that's easiest for us
6986    to program.
6987
6988    Returns 1 if found, 0 otherwise.  */
6989
6990 static int
6991 find_struct_field (const char *name, struct type *type, int offset,
6992                    struct type **field_type_p,
6993                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6994                    int *index_p)
6995 {
6996   int i;
6997   int parent_offset = -1;
6998
6999   type = ada_check_typedef (type);
7000
7001   if (field_type_p != NULL)
7002     *field_type_p = NULL;
7003   if (byte_offset_p != NULL)
7004     *byte_offset_p = 0;
7005   if (bit_offset_p != NULL)
7006     *bit_offset_p = 0;
7007   if (bit_size_p != NULL)
7008     *bit_size_p = 0;
7009
7010   for (i = 0; i < type->num_fields (); i += 1)
7011     {
7012       /* These can't be computed using TYPE_FIELD_BITPOS for a dynamic
7013          type.  However, we only need the values to be correct when
7014          the caller asks for them.  */
7015       int bit_pos = 0, fld_offset = 0;
7016       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7017         {
7018           bit_pos = type->field (i).loc_bitpos ();
7019           fld_offset = offset + bit_pos / 8;
7020         }
7021
7022       const char *t_field_name = type->field (i).name ();
7023
7024       if (t_field_name == NULL)
7025         continue;
7026
7027       else if (ada_is_parent_field (type, i))
7028         {
7029           /* This is a field pointing us to the parent type of a tagged
7030              type.  As hinted in this function's documentation, we give
7031              preference to fields in the current record first, so what
7032              we do here is just record the index of this field before
7033              we skip it.  If it turns out we couldn't find our field
7034              in the current record, then we'll get back to it and search
7035              inside it whether the field might exist in the parent.  */
7036
7037           parent_offset = i;
7038           continue;
7039         }
7040
7041       else if (name != NULL && field_name_match (t_field_name, name))
7042         {
7043           int bit_size = TYPE_FIELD_BITSIZE (type, i);
7044
7045           if (field_type_p != NULL)
7046             *field_type_p = type->field (i).type ();
7047           if (byte_offset_p != NULL)
7048             *byte_offset_p = fld_offset;
7049           if (bit_offset_p != NULL)
7050             *bit_offset_p = bit_pos % 8;
7051           if (bit_size_p != NULL)
7052             *bit_size_p = bit_size;
7053           return 1;
7054         }
7055       else if (ada_is_wrapper_field (type, i))
7056         {
7057           if (find_struct_field (name, type->field (i).type (), fld_offset,
7058                                  field_type_p, byte_offset_p, bit_offset_p,
7059                                  bit_size_p, index_p))
7060             return 1;
7061         }
7062       else if (ada_is_variant_part (type, i))
7063         {
7064           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
7065              fixed type?? */
7066           int j;
7067           struct type *field_type
7068             = ada_check_typedef (type->field (i).type ());
7069
7070           for (j = 0; j < field_type->num_fields (); j += 1)
7071             {
7072               if (find_struct_field (name, field_type->field (j).type (),
7073                                      fld_offset
7074                                      + field_type->field (j).loc_bitpos () / 8,
7075                                      field_type_p, byte_offset_p,
7076                                      bit_offset_p, bit_size_p, index_p))
7077                 return 1;
7078             }
7079         }
7080       else if (index_p != NULL)
7081         *index_p += 1;
7082     }
7083
7084   /* Field not found so far.  If this is a tagged type which
7085      has a parent, try finding that field in the parent now.  */
7086
7087   if (parent_offset != -1)
7088     {
7089       /* As above, only compute the offset when truly needed.  */
7090       int fld_offset = offset;
7091       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7092         {
7093           int bit_pos = type->field (parent_offset).loc_bitpos ();
7094           fld_offset += bit_pos / 8;
7095         }
7096
7097       if (find_struct_field (name, type->field (parent_offset).type (),
7098                              fld_offset, field_type_p, byte_offset_p,
7099                              bit_offset_p, bit_size_p, index_p))
7100         return 1;
7101     }
7102
7103   return 0;
7104 }
7105
7106 /* Number of user-visible fields in record type TYPE.  */
7107
7108 static int
7109 num_visible_fields (struct type *type)
7110 {
7111   int n;
7112
7113   n = 0;
7114   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7115   return n;
7116 }
7117
7118 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
7119    and search in it assuming it has (class) type TYPE.
7120    If found, return value, else return NULL.
7121
7122    Searches recursively through wrapper fields (e.g., '_parent').
7123
7124    In the case of homonyms in the tagged types, please refer to the
7125    long explanation in find_struct_field's function documentation.  */
7126
7127 static struct value *
7128 ada_search_struct_field (const char *name, struct value *arg, int offset,
7129                          struct type *type)
7130 {
7131   int i;
7132   int parent_offset = -1;
7133
7134   type = ada_check_typedef (type);
7135   for (i = 0; i < type->num_fields (); i += 1)
7136     {
7137       const char *t_field_name = type->field (i).name ();
7138
7139       if (t_field_name == NULL)
7140         continue;
7141
7142       else if (ada_is_parent_field (type, i))
7143         {
7144           /* This is a field pointing us to the parent type of a tagged
7145              type.  As hinted in this function's documentation, we give
7146              preference to fields in the current record first, so what
7147              we do here is just record the index of this field before
7148              we skip it.  If it turns out we couldn't find our field
7149              in the current record, then we'll get back to it and search
7150              inside it whether the field might exist in the parent.  */
7151
7152           parent_offset = i;
7153           continue;
7154         }
7155
7156       else if (field_name_match (t_field_name, name))
7157         return ada_value_primitive_field (arg, offset, i, type);
7158
7159       else if (ada_is_wrapper_field (type, i))
7160         {
7161           struct value *v =     /* Do not let indent join lines here.  */
7162             ada_search_struct_field (name, arg,
7163                                      offset + type->field (i).loc_bitpos () / 8,
7164                                      type->field (i).type ());
7165
7166           if (v != NULL)
7167             return v;
7168         }
7169
7170       else if (ada_is_variant_part (type, i))
7171         {
7172           /* PNH: Do we ever get here?  See find_struct_field.  */
7173           int j;
7174           struct type *field_type = ada_check_typedef (type->field (i).type ());
7175           int var_offset = offset + type->field (i).loc_bitpos () / 8;
7176
7177           for (j = 0; j < field_type->num_fields (); j += 1)
7178             {
7179               struct value *v = ada_search_struct_field /* Force line
7180                                                            break.  */
7181                 (name, arg,
7182                  var_offset + field_type->field (j).loc_bitpos () / 8,
7183                  field_type->field (j).type ());
7184
7185               if (v != NULL)
7186                 return v;
7187             }
7188         }
7189     }
7190
7191   /* Field not found so far.  If this is a tagged type which
7192      has a parent, try finding that field in the parent now.  */
7193
7194   if (parent_offset != -1)
7195     {
7196       struct value *v = ada_search_struct_field (
7197         name, arg, offset + type->field (parent_offset).loc_bitpos () / 8,
7198         type->field (parent_offset).type ());
7199
7200       if (v != NULL)
7201         return v;
7202     }
7203
7204   return NULL;
7205 }
7206
7207 static struct value *ada_index_struct_field_1 (int *, struct value *,
7208                                                int, struct type *);
7209
7210
7211 /* Return field #INDEX in ARG, where the index is that returned by
7212  * find_struct_field through its INDEX_P argument.  Adjust the address
7213  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7214  * If found, return value, else return NULL.  */
7215
7216 static struct value *
7217 ada_index_struct_field (int index, struct value *arg, int offset,
7218                         struct type *type)
7219 {
7220   return ada_index_struct_field_1 (&index, arg, offset, type);
7221 }
7222
7223
7224 /* Auxiliary function for ada_index_struct_field.  Like
7225  * ada_index_struct_field, but takes index from *INDEX_P and modifies
7226  * *INDEX_P.  */
7227
7228 static struct value *
7229 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7230                           struct type *type)
7231 {
7232   int i;
7233   type = ada_check_typedef (type);
7234
7235   for (i = 0; i < type->num_fields (); i += 1)
7236     {
7237       if (type->field (i).name () == NULL)
7238         continue;
7239       else if (ada_is_wrapper_field (type, i))
7240         {
7241           struct value *v =     /* Do not let indent join lines here.  */
7242             ada_index_struct_field_1 (index_p, arg,
7243                                       offset + type->field (i).loc_bitpos () / 8,
7244                                       type->field (i).type ());
7245
7246           if (v != NULL)
7247             return v;
7248         }
7249
7250       else if (ada_is_variant_part (type, i))
7251         {
7252           /* PNH: Do we ever get here?  See ada_search_struct_field,
7253              find_struct_field.  */
7254           error (_("Cannot assign this kind of variant record"));
7255         }
7256       else if (*index_p == 0)
7257         return ada_value_primitive_field (arg, offset, i, type);
7258       else
7259         *index_p -= 1;
7260     }
7261   return NULL;
7262 }
7263
7264 /* Return a string representation of type TYPE.  */
7265
7266 static std::string
7267 type_as_string (struct type *type)
7268 {
7269   string_file tmp_stream;
7270
7271   type_print (type, "", &tmp_stream, -1);
7272
7273   return tmp_stream.release ();
7274 }
7275
7276 /* Given a type TYPE, look up the type of the component of type named NAME.
7277    If DISPP is non-null, add its byte displacement from the beginning of a
7278    structure (pointed to by a value) of type TYPE to *DISPP (does not
7279    work for packed fields).
7280
7281    Matches any field whose name has NAME as a prefix, possibly
7282    followed by "___".
7283
7284    TYPE can be either a struct or union.  If REFOK, TYPE may also 
7285    be a (pointer or reference)+ to a struct or union, and the
7286    ultimate target type will be searched.
7287
7288    Looks recursively into variant clauses and parent types.
7289
7290    In the case of homonyms in the tagged types, please refer to the
7291    long explanation in find_struct_field's function documentation.
7292
7293    If NOERR is nonzero, return NULL if NAME is not suitably defined or
7294    TYPE is not a type of the right kind.  */
7295
7296 static struct type *
7297 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7298                             int noerr)
7299 {
7300   int i;
7301   int parent_offset = -1;
7302
7303   if (name == NULL)
7304     goto BadName;
7305
7306   if (refok && type != NULL)
7307     while (1)
7308       {
7309         type = ada_check_typedef (type);
7310         if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
7311           break;
7312         type = TYPE_TARGET_TYPE (type);
7313       }
7314
7315   if (type == NULL
7316       || (type->code () != TYPE_CODE_STRUCT
7317           && type->code () != TYPE_CODE_UNION))
7318     {
7319       if (noerr)
7320         return NULL;
7321
7322       error (_("Type %s is not a structure or union type"),
7323              type != NULL ? type_as_string (type).c_str () : _("(null)"));
7324     }
7325
7326   type = to_static_fixed_type (type);
7327
7328   for (i = 0; i < type->num_fields (); i += 1)
7329     {
7330       const char *t_field_name = type->field (i).name ();
7331       struct type *t;
7332
7333       if (t_field_name == NULL)
7334         continue;
7335
7336       else if (ada_is_parent_field (type, i))
7337         {
7338           /* This is a field pointing us to the parent type of a tagged
7339              type.  As hinted in this function's documentation, we give
7340              preference to fields in the current record first, so what
7341              we do here is just record the index of this field before
7342              we skip it.  If it turns out we couldn't find our field
7343              in the current record, then we'll get back to it and search
7344              inside it whether the field might exist in the parent.  */
7345
7346           parent_offset = i;
7347           continue;
7348         }
7349
7350       else if (field_name_match (t_field_name, name))
7351         return type->field (i).type ();
7352
7353       else if (ada_is_wrapper_field (type, i))
7354         {
7355           t = ada_lookup_struct_elt_type (type->field (i).type (), name,
7356                                           0, 1);
7357           if (t != NULL)
7358             return t;
7359         }
7360
7361       else if (ada_is_variant_part (type, i))
7362         {
7363           int j;
7364           struct type *field_type = ada_check_typedef (type->field (i).type ());
7365
7366           for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
7367             {
7368               /* FIXME pnh 2008/01/26: We check for a field that is
7369                  NOT wrapped in a struct, since the compiler sometimes
7370                  generates these for unchecked variant types.  Revisit
7371                  if the compiler changes this practice.  */
7372               const char *v_field_name = field_type->field (j).name ();
7373
7374               if (v_field_name != NULL 
7375                   && field_name_match (v_field_name, name))
7376                 t = field_type->field (j).type ();
7377               else
7378                 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
7379                                                 name, 0, 1);
7380
7381               if (t != NULL)
7382                 return t;
7383             }
7384         }
7385
7386     }
7387
7388     /* Field not found so far.  If this is a tagged type which
7389        has a parent, try finding that field in the parent now.  */
7390
7391     if (parent_offset != -1)
7392       {
7393         struct type *t;
7394
7395         t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
7396                                         name, 0, 1);
7397         if (t != NULL)
7398           return t;
7399       }
7400
7401 BadName:
7402   if (!noerr)
7403     {
7404       const char *name_str = name != NULL ? name : _("<null>");
7405
7406       error (_("Type %s has no component named %s"),
7407              type_as_string (type).c_str (), name_str);
7408     }
7409
7410   return NULL;
7411 }
7412
7413 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7414    within a value of type OUTER_TYPE, return true iff VAR_TYPE
7415    represents an unchecked union (that is, the variant part of a
7416    record that is named in an Unchecked_Union pragma).  */
7417
7418 static int
7419 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7420 {
7421   const char *discrim_name = ada_variant_discrim_name (var_type);
7422
7423   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7424 }
7425
7426
7427 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7428    within OUTER, determine which variant clause (field number in VAR_TYPE,
7429    numbering from 0) is applicable.  Returns -1 if none are.  */
7430
7431 int
7432 ada_which_variant_applies (struct type *var_type, struct value *outer)
7433 {
7434   int others_clause;
7435   int i;
7436   const char *discrim_name = ada_variant_discrim_name (var_type);
7437   struct value *discrim;
7438   LONGEST discrim_val;
7439
7440   /* Using plain value_from_contents_and_address here causes problems
7441      because we will end up trying to resolve a type that is currently
7442      being constructed.  */
7443   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7444   if (discrim == NULL)
7445     return -1;
7446   discrim_val = value_as_long (discrim);
7447
7448   others_clause = -1;
7449   for (i = 0; i < var_type->num_fields (); i += 1)
7450     {
7451       if (ada_is_others_clause (var_type, i))
7452         others_clause = i;
7453       else if (ada_in_variant (discrim_val, var_type, i))
7454         return i;
7455     }
7456
7457   return others_clause;
7458 }
7459 \f
7460
7461
7462                                 /* Dynamic-Sized Records */
7463
7464 /* Strategy: The type ostensibly attached to a value with dynamic size
7465    (i.e., a size that is not statically recorded in the debugging
7466    data) does not accurately reflect the size or layout of the value.
7467    Our strategy is to convert these values to values with accurate,
7468    conventional types that are constructed on the fly.  */
7469
7470 /* There is a subtle and tricky problem here.  In general, we cannot
7471    determine the size of dynamic records without its data.  However,
7472    the 'struct value' data structure, which GDB uses to represent
7473    quantities in the inferior process (the target), requires the size
7474    of the type at the time of its allocation in order to reserve space
7475    for GDB's internal copy of the data.  That's why the
7476    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7477    rather than struct value*s.
7478
7479    However, GDB's internal history variables ($1, $2, etc.) are
7480    struct value*s containing internal copies of the data that are not, in
7481    general, the same as the data at their corresponding addresses in
7482    the target.  Fortunately, the types we give to these values are all
7483    conventional, fixed-size types (as per the strategy described
7484    above), so that we don't usually have to perform the
7485    'to_fixed_xxx_type' conversions to look at their values.
7486    Unfortunately, there is one exception: if one of the internal
7487    history variables is an array whose elements are unconstrained
7488    records, then we will need to create distinct fixed types for each
7489    element selected.  */
7490
7491 /* The upshot of all of this is that many routines take a (type, host
7492    address, target address) triple as arguments to represent a value.
7493    The host address, if non-null, is supposed to contain an internal
7494    copy of the relevant data; otherwise, the program is to consult the
7495    target at the target address.  */
7496
7497 /* Assuming that VAL0 represents a pointer value, the result of
7498    dereferencing it.  Differs from value_ind in its treatment of
7499    dynamic-sized types.  */
7500
7501 struct value *
7502 ada_value_ind (struct value *val0)
7503 {
7504   struct value *val = value_ind (val0);
7505
7506   if (ada_is_tagged_type (value_type (val), 0))
7507     val = ada_tag_value_at_base_address (val);
7508
7509   return ada_to_fixed_value (val);
7510 }
7511
7512 /* The value resulting from dereferencing any "reference to"
7513    qualifiers on VAL0.  */
7514
7515 static struct value *
7516 ada_coerce_ref (struct value *val0)
7517 {
7518   if (value_type (val0)->code () == TYPE_CODE_REF)
7519     {
7520       struct value *val = val0;
7521
7522       val = coerce_ref (val);
7523
7524       if (ada_is_tagged_type (value_type (val), 0))
7525         val = ada_tag_value_at_base_address (val);
7526
7527       return ada_to_fixed_value (val);
7528     }
7529   else
7530     return val0;
7531 }
7532
7533 /* Return the bit alignment required for field #F of template type TYPE.  */
7534
7535 static unsigned int
7536 field_alignment (struct type *type, int f)
7537 {
7538   const char *name = type->field (f).name ();
7539   int len;
7540   int align_offset;
7541
7542   /* The field name should never be null, unless the debugging information
7543      is somehow malformed.  In this case, we assume the field does not
7544      require any alignment.  */
7545   if (name == NULL)
7546     return 1;
7547
7548   len = strlen (name);
7549
7550   if (!isdigit (name[len - 1]))
7551     return 1;
7552
7553   if (isdigit (name[len - 2]))
7554     align_offset = len - 2;
7555   else
7556     align_offset = len - 1;
7557
7558   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7559     return TARGET_CHAR_BIT;
7560
7561   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7562 }
7563
7564 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7565
7566 static struct symbol *
7567 ada_find_any_type_symbol (const char *name)
7568 {
7569   struct symbol *sym;
7570
7571   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7572   if (sym != NULL && sym->aclass () == LOC_TYPEDEF)
7573     return sym;
7574
7575   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7576   return sym;
7577 }
7578
7579 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7580    solely for types defined by debug info, it will not search the GDB
7581    primitive types.  */
7582
7583 static struct type *
7584 ada_find_any_type (const char *name)
7585 {
7586   struct symbol *sym = ada_find_any_type_symbol (name);
7587
7588   if (sym != NULL)
7589     return sym->type ();
7590
7591   return NULL;
7592 }
7593
7594 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7595    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
7596    symbol, in which case it is returned.  Otherwise, this looks for
7597    symbols whose name is that of NAME_SYM suffixed with  "___XR".
7598    Return symbol if found, and NULL otherwise.  */
7599
7600 static bool
7601 ada_is_renaming_symbol (struct symbol *name_sym)
7602 {
7603   const char *name = name_sym->linkage_name ();
7604   return strstr (name, "___XR") != NULL;
7605 }
7606
7607 /* Because of GNAT encoding conventions, several GDB symbols may match a
7608    given type name.  If the type denoted by TYPE0 is to be preferred to
7609    that of TYPE1 for purposes of type printing, return non-zero;
7610    otherwise return 0.  */
7611
7612 int
7613 ada_prefer_type (struct type *type0, struct type *type1)
7614 {
7615   if (type1 == NULL)
7616     return 1;
7617   else if (type0 == NULL)
7618     return 0;
7619   else if (type1->code () == TYPE_CODE_VOID)
7620     return 1;
7621   else if (type0->code () == TYPE_CODE_VOID)
7622     return 0;
7623   else if (type1->name () == NULL && type0->name () != NULL)
7624     return 1;
7625   else if (ada_is_constrained_packed_array_type (type0))
7626     return 1;
7627   else if (ada_is_array_descriptor_type (type0)
7628            && !ada_is_array_descriptor_type (type1))
7629     return 1;
7630   else
7631     {
7632       const char *type0_name = type0->name ();
7633       const char *type1_name = type1->name ();
7634
7635       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7636           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7637         return 1;
7638     }
7639   return 0;
7640 }
7641
7642 /* The name of TYPE, which is its TYPE_NAME.  Null if TYPE is
7643    null.  */
7644
7645 const char *
7646 ada_type_name (struct type *type)
7647 {
7648   if (type == NULL)
7649     return NULL;
7650   return type->name ();
7651 }
7652
7653 /* Search the list of "descriptive" types associated to TYPE for a type
7654    whose name is NAME.  */
7655
7656 static struct type *
7657 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7658 {
7659   struct type *result, *tmp;
7660
7661   if (ada_ignore_descriptive_types_p)
7662     return NULL;
7663
7664   /* If there no descriptive-type info, then there is no parallel type
7665      to be found.  */
7666   if (!HAVE_GNAT_AUX_INFO (type))
7667     return NULL;
7668
7669   result = TYPE_DESCRIPTIVE_TYPE (type);
7670   while (result != NULL)
7671     {
7672       const char *result_name = ada_type_name (result);
7673
7674       if (result_name == NULL)
7675         {
7676           warning (_("unexpected null name on descriptive type"));
7677           return NULL;
7678         }
7679
7680       /* If the names match, stop.  */
7681       if (strcmp (result_name, name) == 0)
7682         break;
7683
7684       /* Otherwise, look at the next item on the list, if any.  */
7685       if (HAVE_GNAT_AUX_INFO (result))
7686         tmp = TYPE_DESCRIPTIVE_TYPE (result);
7687       else
7688         tmp = NULL;
7689
7690       /* If not found either, try after having resolved the typedef.  */
7691       if (tmp != NULL)
7692         result = tmp;
7693       else
7694         {
7695           result = check_typedef (result);
7696           if (HAVE_GNAT_AUX_INFO (result))
7697             result = TYPE_DESCRIPTIVE_TYPE (result);
7698           else
7699             result = NULL;
7700         }
7701     }
7702
7703   /* If we didn't find a match, see whether this is a packed array.  With
7704      older compilers, the descriptive type information is either absent or
7705      irrelevant when it comes to packed arrays so the above lookup fails.
7706      Fall back to using a parallel lookup by name in this case.  */
7707   if (result == NULL && ada_is_constrained_packed_array_type (type))
7708     return ada_find_any_type (name);
7709
7710   return result;
7711 }
7712
7713 /* Find a parallel type to TYPE with the specified NAME, using the
7714    descriptive type taken from the debugging information, if available,
7715    and otherwise using the (slower) name-based method.  */
7716
7717 static struct type *
7718 ada_find_parallel_type_with_name (struct type *type, const char *name)
7719 {
7720   struct type *result = NULL;
7721
7722   if (HAVE_GNAT_AUX_INFO (type))
7723     result = find_parallel_type_by_descriptive_type (type, name);
7724   else
7725     result = ada_find_any_type (name);
7726
7727   return result;
7728 }
7729
7730 /* Same as above, but specify the name of the parallel type by appending
7731    SUFFIX to the name of TYPE.  */
7732
7733 struct type *
7734 ada_find_parallel_type (struct type *type, const char *suffix)
7735 {
7736   char *name;
7737   const char *type_name = ada_type_name (type);
7738   int len;
7739
7740   if (type_name == NULL)
7741     return NULL;
7742
7743   len = strlen (type_name);
7744
7745   name = (char *) alloca (len + strlen (suffix) + 1);
7746
7747   strcpy (name, type_name);
7748   strcpy (name + len, suffix);
7749
7750   return ada_find_parallel_type_with_name (type, name);
7751 }
7752
7753 /* If TYPE is a variable-size record type, return the corresponding template
7754    type describing its fields.  Otherwise, return NULL.  */
7755
7756 static struct type *
7757 dynamic_template_type (struct type *type)
7758 {
7759   type = ada_check_typedef (type);
7760
7761   if (type == NULL || type->code () != TYPE_CODE_STRUCT
7762       || ada_type_name (type) == NULL)
7763     return NULL;
7764   else
7765     {
7766       int len = strlen (ada_type_name (type));
7767
7768       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7769         return type;
7770       else
7771         return ada_find_parallel_type (type, "___XVE");
7772     }
7773 }
7774
7775 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7776    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
7777
7778 static int
7779 is_dynamic_field (struct type *templ_type, int field_num)
7780 {
7781   const char *name = templ_type->field (field_num).name ();
7782
7783   return name != NULL
7784     && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7785     && strstr (name, "___XVL") != NULL;
7786 }
7787
7788 /* The index of the variant field of TYPE, or -1 if TYPE does not
7789    represent a variant record type.  */
7790
7791 static int
7792 variant_field_index (struct type *type)
7793 {
7794   int f;
7795
7796   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7797     return -1;
7798
7799   for (f = 0; f < type->num_fields (); f += 1)
7800     {
7801       if (ada_is_variant_part (type, f))
7802         return f;
7803     }
7804   return -1;
7805 }
7806
7807 /* A record type with no fields.  */
7808
7809 static struct type *
7810 empty_record (struct type *templ)
7811 {
7812   struct type *type = alloc_type_copy (templ);
7813
7814   type->set_code (TYPE_CODE_STRUCT);
7815   INIT_NONE_SPECIFIC (type);
7816   type->set_name ("<empty>");
7817   TYPE_LENGTH (type) = 0;
7818   return type;
7819 }
7820
7821 /* An ordinary record type (with fixed-length fields) that describes
7822    the value of type TYPE at VALADDR or ADDRESS (see comments at
7823    the beginning of this section) VAL according to GNAT conventions.
7824    DVAL0 should describe the (portion of a) record that contains any
7825    necessary discriminants.  It should be NULL if value_type (VAL) is
7826    an outer-level type (i.e., as opposed to a branch of a variant.)  A
7827    variant field (unless unchecked) is replaced by a particular branch
7828    of the variant.
7829
7830    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7831    length are not statically known are discarded.  As a consequence,
7832    VALADDR, ADDRESS and DVAL0 are ignored.
7833
7834    NOTE: Limitations: For now, we assume that dynamic fields and
7835    variants occupy whole numbers of bytes.  However, they need not be
7836    byte-aligned.  */
7837
7838 struct type *
7839 ada_template_to_fixed_record_type_1 (struct type *type,
7840                                      const gdb_byte *valaddr,
7841                                      CORE_ADDR address, struct value *dval0,
7842                                      int keep_dynamic_fields)
7843 {
7844   struct value *mark = value_mark ();
7845   struct value *dval;
7846   struct type *rtype;
7847   int nfields, bit_len;
7848   int variant_field;
7849   long off;
7850   int fld_bit_len;
7851   int f;
7852
7853   /* Compute the number of fields in this record type that are going
7854      to be processed: unless keep_dynamic_fields, this includes only
7855      fields whose position and length are static will be processed.  */
7856   if (keep_dynamic_fields)
7857     nfields = type->num_fields ();
7858   else
7859     {
7860       nfields = 0;
7861       while (nfields < type->num_fields ()
7862              && !ada_is_variant_part (type, nfields)
7863              && !is_dynamic_field (type, nfields))
7864         nfields++;
7865     }
7866
7867   rtype = alloc_type_copy (type);
7868   rtype->set_code (TYPE_CODE_STRUCT);
7869   INIT_NONE_SPECIFIC (rtype);
7870   rtype->set_num_fields (nfields);
7871   rtype->set_fields
7872    ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7873   rtype->set_name (ada_type_name (type));
7874   rtype->set_is_fixed_instance (true);
7875
7876   off = 0;
7877   bit_len = 0;
7878   variant_field = -1;
7879
7880   for (f = 0; f < nfields; f += 1)
7881     {
7882       off = align_up (off, field_alignment (type, f))
7883         + type->field (f).loc_bitpos ();
7884       rtype->field (f).set_loc_bitpos (off);
7885       TYPE_FIELD_BITSIZE (rtype, f) = 0;
7886
7887       if (ada_is_variant_part (type, f))
7888         {
7889           variant_field = f;
7890           fld_bit_len = 0;
7891         }
7892       else if (is_dynamic_field (type, f))
7893         {
7894           const gdb_byte *field_valaddr = valaddr;
7895           CORE_ADDR field_address = address;
7896           struct type *field_type =
7897             TYPE_TARGET_TYPE (type->field (f).type ());
7898
7899           if (dval0 == NULL)
7900             {
7901               /* Using plain value_from_contents_and_address here
7902                  causes problems because we will end up trying to
7903                  resolve a type that is currently being
7904                  constructed.  */
7905               dval = value_from_contents_and_address_unresolved (rtype,
7906                                                                  valaddr,
7907                                                                  address);
7908               rtype = value_type (dval);
7909             }
7910           else
7911             dval = dval0;
7912
7913           /* If the type referenced by this field is an aligner type, we need
7914              to unwrap that aligner type, because its size might not be set.
7915              Keeping the aligner type would cause us to compute the wrong
7916              size for this field, impacting the offset of the all the fields
7917              that follow this one.  */
7918           if (ada_is_aligner_type (field_type))
7919             {
7920               long field_offset = type->field (f).loc_bitpos ();
7921
7922               field_valaddr = cond_offset_host (field_valaddr, field_offset);
7923               field_address = cond_offset_target (field_address, field_offset);
7924               field_type = ada_aligned_type (field_type);
7925             }
7926
7927           field_valaddr = cond_offset_host (field_valaddr,
7928                                             off / TARGET_CHAR_BIT);
7929           field_address = cond_offset_target (field_address,
7930                                               off / TARGET_CHAR_BIT);
7931
7932           /* Get the fixed type of the field.  Note that, in this case,
7933              we do not want to get the real type out of the tag: if
7934              the current field is the parent part of a tagged record,
7935              we will get the tag of the object.  Clearly wrong: the real
7936              type of the parent is not the real type of the child.  We
7937              would end up in an infinite loop.  */
7938           field_type = ada_get_base_type (field_type);
7939           field_type = ada_to_fixed_type (field_type, field_valaddr,
7940                                           field_address, dval, 0);
7941
7942           rtype->field (f).set_type (field_type);
7943           rtype->field (f).set_name (type->field (f).name ());
7944           /* The multiplication can potentially overflow.  But because
7945              the field length has been size-checked just above, and
7946              assuming that the maximum size is a reasonable value,
7947              an overflow should not happen in practice.  So rather than
7948              adding overflow recovery code to this already complex code,
7949              we just assume that it's not going to happen.  */
7950           fld_bit_len =
7951             TYPE_LENGTH (rtype->field (f).type ()) * TARGET_CHAR_BIT;
7952         }
7953       else
7954         {
7955           /* Note: If this field's type is a typedef, it is important
7956              to preserve the typedef layer.
7957
7958              Otherwise, we might be transforming a typedef to a fat
7959              pointer (encoding a pointer to an unconstrained array),
7960              into a basic fat pointer (encoding an unconstrained
7961              array).  As both types are implemented using the same
7962              structure, the typedef is the only clue which allows us
7963              to distinguish between the two options.  Stripping it
7964              would prevent us from printing this field appropriately.  */
7965           rtype->field (f).set_type (type->field (f).type ());
7966           rtype->field (f).set_name (type->field (f).name ());
7967           if (TYPE_FIELD_BITSIZE (type, f) > 0)
7968             fld_bit_len =
7969               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7970           else
7971             {
7972               struct type *field_type = type->field (f).type ();
7973
7974               /* We need to be careful of typedefs when computing
7975                  the length of our field.  If this is a typedef,
7976                  get the length of the target type, not the length
7977                  of the typedef.  */
7978               if (field_type->code () == TYPE_CODE_TYPEDEF)
7979                 field_type = ada_typedef_target_type (field_type);
7980
7981               fld_bit_len =
7982                 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7983             }
7984         }
7985       if (off + fld_bit_len > bit_len)
7986         bit_len = off + fld_bit_len;
7987       off += fld_bit_len;
7988       TYPE_LENGTH (rtype) =
7989         align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7990     }
7991
7992   /* We handle the variant part, if any, at the end because of certain
7993      odd cases in which it is re-ordered so as NOT to be the last field of
7994      the record.  This can happen in the presence of representation
7995      clauses.  */
7996   if (variant_field >= 0)
7997     {
7998       struct type *branch_type;
7999
8000       off = rtype->field (variant_field).loc_bitpos ();
8001
8002       if (dval0 == NULL)
8003         {
8004           /* Using plain value_from_contents_and_address here causes
8005              problems because we will end up trying to resolve a type
8006              that is currently being constructed.  */
8007           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8008                                                              address);
8009           rtype = value_type (dval);
8010         }
8011       else
8012         dval = dval0;
8013
8014       branch_type =
8015         to_fixed_variant_branch_type
8016         (type->field (variant_field).type (),
8017          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8018          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8019       if (branch_type == NULL)
8020         {
8021           for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
8022             rtype->field (f - 1) = rtype->field (f);
8023           rtype->set_num_fields (rtype->num_fields () - 1);
8024         }
8025       else
8026         {
8027           rtype->field (variant_field).set_type (branch_type);
8028           rtype->field (variant_field).set_name ("S");
8029           fld_bit_len =
8030             TYPE_LENGTH (rtype->field (variant_field).type ()) *
8031             TARGET_CHAR_BIT;
8032           if (off + fld_bit_len > bit_len)
8033             bit_len = off + fld_bit_len;
8034           TYPE_LENGTH (rtype) =
8035             align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8036         }
8037     }
8038
8039   /* According to exp_dbug.ads, the size of TYPE for variable-size records
8040      should contain the alignment of that record, which should be a strictly
8041      positive value.  If null or negative, then something is wrong, most
8042      probably in the debug info.  In that case, we don't round up the size
8043      of the resulting type.  If this record is not part of another structure,
8044      the current RTYPE length might be good enough for our purposes.  */
8045   if (TYPE_LENGTH (type) <= 0)
8046     {
8047       if (rtype->name ())
8048         warning (_("Invalid type size for `%s' detected: %s."),
8049                  rtype->name (), pulongest (TYPE_LENGTH (type)));
8050       else
8051         warning (_("Invalid type size for <unnamed> detected: %s."),
8052                  pulongest (TYPE_LENGTH (type)));
8053     }
8054   else
8055     {
8056       TYPE_LENGTH (rtype) = align_up (TYPE_LENGTH (rtype),
8057                                       TYPE_LENGTH (type));
8058     }
8059
8060   value_free_to_mark (mark);
8061   return rtype;
8062 }
8063
8064 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8065    of 1.  */
8066
8067 static struct type *
8068 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8069                                CORE_ADDR address, struct value *dval0)
8070 {
8071   return ada_template_to_fixed_record_type_1 (type, valaddr,
8072                                               address, dval0, 1);
8073 }
8074
8075 /* An ordinary record type in which ___XVL-convention fields and
8076    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8077    static approximations, containing all possible fields.  Uses
8078    no runtime values.  Useless for use in values, but that's OK,
8079    since the results are used only for type determinations.   Works on both
8080    structs and unions.  Representation note: to save space, we memorize
8081    the result of this function in the TYPE_TARGET_TYPE of the
8082    template type.  */
8083
8084 static struct type *
8085 template_to_static_fixed_type (struct type *type0)
8086 {
8087   struct type *type;
8088   int nfields;
8089   int f;
8090
8091   /* No need no do anything if the input type is already fixed.  */
8092   if (type0->is_fixed_instance ())
8093     return type0;
8094
8095   /* Likewise if we already have computed the static approximation.  */
8096   if (TYPE_TARGET_TYPE (type0) != NULL)
8097     return TYPE_TARGET_TYPE (type0);
8098
8099   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
8100   type = type0;
8101   nfields = type0->num_fields ();
8102
8103   /* Whether or not we cloned TYPE0, cache the result so that we don't do
8104      recompute all over next time.  */
8105   TYPE_TARGET_TYPE (type0) = type;
8106
8107   for (f = 0; f < nfields; f += 1)
8108     {
8109       struct type *field_type = type0->field (f).type ();
8110       struct type *new_type;
8111
8112       if (is_dynamic_field (type0, f))
8113         {
8114           field_type = ada_check_typedef (field_type);
8115           new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8116         }
8117       else
8118         new_type = static_unwrap_type (field_type);
8119
8120       if (new_type != field_type)
8121         {
8122           /* Clone TYPE0 only the first time we get a new field type.  */
8123           if (type == type0)
8124             {
8125               TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8126               type->set_code (type0->code ());
8127               INIT_NONE_SPECIFIC (type);
8128               type->set_num_fields (nfields);
8129
8130               field *fields =
8131                 ((struct field *)
8132                  TYPE_ALLOC (type, nfields * sizeof (struct field)));
8133               memcpy (fields, type0->fields (),
8134                       sizeof (struct field) * nfields);
8135               type->set_fields (fields);
8136
8137               type->set_name (ada_type_name (type0));
8138               type->set_is_fixed_instance (true);
8139               TYPE_LENGTH (type) = 0;
8140             }
8141           type->field (f).set_type (new_type);
8142           type->field (f).set_name (type0->field (f).name ());
8143         }
8144     }
8145
8146   return type;
8147 }
8148
8149 /* Given an object of type TYPE whose contents are at VALADDR and
8150    whose address in memory is ADDRESS, returns a revision of TYPE,
8151    which should be a non-dynamic-sized record, in which the variant
8152    part, if any, is replaced with the appropriate branch.  Looks
8153    for discriminant values in DVAL0, which can be NULL if the record
8154    contains the necessary discriminant values.  */
8155
8156 static struct type *
8157 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8158                                    CORE_ADDR address, struct value *dval0)
8159 {
8160   struct value *mark = value_mark ();
8161   struct value *dval;
8162   struct type *rtype;
8163   struct type *branch_type;
8164   int nfields = type->num_fields ();
8165   int variant_field = variant_field_index (type);
8166
8167   if (variant_field == -1)
8168     return type;
8169
8170   if (dval0 == NULL)
8171     {
8172       dval = value_from_contents_and_address (type, valaddr, address);
8173       type = value_type (dval);
8174     }
8175   else
8176     dval = dval0;
8177
8178   rtype = alloc_type_copy (type);
8179   rtype->set_code (TYPE_CODE_STRUCT);
8180   INIT_NONE_SPECIFIC (rtype);
8181   rtype->set_num_fields (nfields);
8182
8183   field *fields =
8184     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8185   memcpy (fields, type->fields (), sizeof (struct field) * nfields);
8186   rtype->set_fields (fields);
8187
8188   rtype->set_name (ada_type_name (type));
8189   rtype->set_is_fixed_instance (true);
8190   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8191
8192   branch_type = to_fixed_variant_branch_type
8193     (type->field (variant_field).type (),
8194      cond_offset_host (valaddr,
8195                        type->field (variant_field).loc_bitpos ()
8196                        / TARGET_CHAR_BIT),
8197      cond_offset_target (address,
8198                          type->field (variant_field).loc_bitpos ()
8199                          / TARGET_CHAR_BIT), dval);
8200   if (branch_type == NULL)
8201     {
8202       int f;
8203
8204       for (f = variant_field + 1; f < nfields; f += 1)
8205         rtype->field (f - 1) = rtype->field (f);
8206       rtype->set_num_fields (rtype->num_fields () - 1);
8207     }
8208   else
8209     {
8210       rtype->field (variant_field).set_type (branch_type);
8211       rtype->field (variant_field).set_name ("S");
8212       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8213       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8214     }
8215   TYPE_LENGTH (rtype) -= TYPE_LENGTH (type->field (variant_field).type ());
8216
8217   value_free_to_mark (mark);
8218   return rtype;
8219 }
8220
8221 /* An ordinary record type (with fixed-length fields) that describes
8222    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8223    beginning of this section].   Any necessary discriminants' values
8224    should be in DVAL, a record value; it may be NULL if the object
8225    at ADDR itself contains any necessary discriminant values.
8226    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8227    values from the record are needed.  Except in the case that DVAL,
8228    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8229    unchecked) is replaced by a particular branch of the variant.
8230
8231    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8232    is questionable and may be removed.  It can arise during the
8233    processing of an unconstrained-array-of-record type where all the
8234    variant branches have exactly the same size.  This is because in
8235    such cases, the compiler does not bother to use the XVS convention
8236    when encoding the record.  I am currently dubious of this
8237    shortcut and suspect the compiler should be altered.  FIXME.  */
8238
8239 static struct type *
8240 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8241                       CORE_ADDR address, struct value *dval)
8242 {
8243   struct type *templ_type;
8244
8245   if (type0->is_fixed_instance ())
8246     return type0;
8247
8248   templ_type = dynamic_template_type (type0);
8249
8250   if (templ_type != NULL)
8251     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8252   else if (variant_field_index (type0) >= 0)
8253     {
8254       if (dval == NULL && valaddr == NULL && address == 0)
8255         return type0;
8256       return to_record_with_fixed_variant_part (type0, valaddr, address,
8257                                                 dval);
8258     }
8259   else
8260     {
8261       type0->set_is_fixed_instance (true);
8262       return type0;
8263     }
8264
8265 }
8266
8267 /* An ordinary record type (with fixed-length fields) that describes
8268    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8269    union type.  Any necessary discriminants' values should be in DVAL,
8270    a record value.  That is, this routine selects the appropriate
8271    branch of the union at ADDR according to the discriminant value
8272    indicated in the union's type name.  Returns VAR_TYPE0 itself if
8273    it represents a variant subject to a pragma Unchecked_Union.  */
8274
8275 static struct type *
8276 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8277                               CORE_ADDR address, struct value *dval)
8278 {
8279   int which;
8280   struct type *templ_type;
8281   struct type *var_type;
8282
8283   if (var_type0->code () == TYPE_CODE_PTR)
8284     var_type = TYPE_TARGET_TYPE (var_type0);
8285   else
8286     var_type = var_type0;
8287
8288   templ_type = ada_find_parallel_type (var_type, "___XVU");
8289
8290   if (templ_type != NULL)
8291     var_type = templ_type;
8292
8293   if (is_unchecked_variant (var_type, value_type (dval)))
8294       return var_type0;
8295   which = ada_which_variant_applies (var_type, dval);
8296
8297   if (which < 0)
8298     return empty_record (var_type);
8299   else if (is_dynamic_field (var_type, which))
8300     return to_fixed_record_type
8301       (TYPE_TARGET_TYPE (var_type->field (which).type ()),
8302        valaddr, address, dval);
8303   else if (variant_field_index (var_type->field (which).type ()) >= 0)
8304     return
8305       to_fixed_record_type
8306       (var_type->field (which).type (), valaddr, address, dval);
8307   else
8308     return var_type->field (which).type ();
8309 }
8310
8311 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8312    ENCODING_TYPE, a type following the GNAT conventions for discrete
8313    type encodings, only carries redundant information.  */
8314
8315 static int
8316 ada_is_redundant_range_encoding (struct type *range_type,
8317                                  struct type *encoding_type)
8318 {
8319   const char *bounds_str;
8320   int n;
8321   LONGEST lo, hi;
8322
8323   gdb_assert (range_type->code () == TYPE_CODE_RANGE);
8324
8325   if (get_base_type (range_type)->code ()
8326       != get_base_type (encoding_type)->code ())
8327     {
8328       /* The compiler probably used a simple base type to describe
8329          the range type instead of the range's actual base type,
8330          expecting us to get the real base type from the encoding
8331          anyway.  In this situation, the encoding cannot be ignored
8332          as redundant.  */
8333       return 0;
8334     }
8335
8336   if (is_dynamic_type (range_type))
8337     return 0;
8338
8339   if (encoding_type->name () == NULL)
8340     return 0;
8341
8342   bounds_str = strstr (encoding_type->name (), "___XDLU_");
8343   if (bounds_str == NULL)
8344     return 0;
8345
8346   n = 8; /* Skip "___XDLU_".  */
8347   if (!ada_scan_number (bounds_str, n, &lo, &n))
8348     return 0;
8349   if (range_type->bounds ()->low.const_val () != lo)
8350     return 0;
8351
8352   n += 2; /* Skip the "__" separator between the two bounds.  */
8353   if (!ada_scan_number (bounds_str, n, &hi, &n))
8354     return 0;
8355   if (range_type->bounds ()->high.const_val () != hi)
8356     return 0;
8357
8358   return 1;
8359 }
8360
8361 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8362    a type following the GNAT encoding for describing array type
8363    indices, only carries redundant information.  */
8364
8365 static int
8366 ada_is_redundant_index_type_desc (struct type *array_type,
8367                                   struct type *desc_type)
8368 {
8369   struct type *this_layer = check_typedef (array_type);
8370   int i;
8371
8372   for (i = 0; i < desc_type->num_fields (); i++)
8373     {
8374       if (!ada_is_redundant_range_encoding (this_layer->index_type (),
8375                                             desc_type->field (i).type ()))
8376         return 0;
8377       this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8378     }
8379
8380   return 1;
8381 }
8382
8383 /* Assuming that TYPE0 is an array type describing the type of a value
8384    at ADDR, and that DVAL describes a record containing any
8385    discriminants used in TYPE0, returns a type for the value that
8386    contains no dynamic components (that is, no components whose sizes
8387    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
8388    true, gives an error message if the resulting type's size is over
8389    varsize_limit.  */
8390
8391 static struct type *
8392 to_fixed_array_type (struct type *type0, struct value *dval,
8393                      int ignore_too_big)
8394 {
8395   struct type *index_type_desc;
8396   struct type *result;
8397   int constrained_packed_array_p;
8398   static const char *xa_suffix = "___XA";
8399
8400   type0 = ada_check_typedef (type0);
8401   if (type0->is_fixed_instance ())
8402     return type0;
8403
8404   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8405   if (constrained_packed_array_p)
8406     {
8407       type0 = decode_constrained_packed_array_type (type0);
8408       if (type0 == nullptr)
8409         error (_("could not decode constrained packed array type"));
8410     }
8411
8412   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8413
8414   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8415      encoding suffixed with 'P' may still be generated.  If so,
8416      it should be used to find the XA type.  */
8417
8418   if (index_type_desc == NULL)
8419     {
8420       const char *type_name = ada_type_name (type0);
8421
8422       if (type_name != NULL)
8423         {
8424           const int len = strlen (type_name);
8425           char *name = (char *) alloca (len + strlen (xa_suffix));
8426
8427           if (type_name[len - 1] == 'P')
8428             {
8429               strcpy (name, type_name);
8430               strcpy (name + len - 1, xa_suffix);
8431               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8432             }
8433         }
8434     }
8435
8436   ada_fixup_array_indexes_type (index_type_desc);
8437   if (index_type_desc != NULL
8438       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8439     {
8440       /* Ignore this ___XA parallel type, as it does not bring any
8441          useful information.  This allows us to avoid creating fixed
8442          versions of the array's index types, which would be identical
8443          to the original ones.  This, in turn, can also help avoid
8444          the creation of fixed versions of the array itself.  */
8445       index_type_desc = NULL;
8446     }
8447
8448   if (index_type_desc == NULL)
8449     {
8450       struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8451
8452       /* NOTE: elt_type---the fixed version of elt_type0---should never
8453          depend on the contents of the array in properly constructed
8454          debugging data.  */
8455       /* Create a fixed version of the array element type.
8456          We're not providing the address of an element here,
8457          and thus the actual object value cannot be inspected to do
8458          the conversion.  This should not be a problem, since arrays of
8459          unconstrained objects are not allowed.  In particular, all
8460          the elements of an array of a tagged type should all be of
8461          the same type specified in the debugging info.  No need to
8462          consult the object tag.  */
8463       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8464
8465       /* Make sure we always create a new array type when dealing with
8466          packed array types, since we're going to fix-up the array
8467          type length and element bitsize a little further down.  */
8468       if (elt_type0 == elt_type && !constrained_packed_array_p)
8469         result = type0;
8470       else
8471         result = create_array_type (alloc_type_copy (type0),
8472                                     elt_type, type0->index_type ());
8473     }
8474   else
8475     {
8476       int i;
8477       struct type *elt_type0;
8478
8479       elt_type0 = type0;
8480       for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8481         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8482
8483       /* NOTE: result---the fixed version of elt_type0---should never
8484          depend on the contents of the array in properly constructed
8485          debugging data.  */
8486       /* Create a fixed version of the array element type.
8487          We're not providing the address of an element here,
8488          and thus the actual object value cannot be inspected to do
8489          the conversion.  This should not be a problem, since arrays of
8490          unconstrained objects are not allowed.  In particular, all
8491          the elements of an array of a tagged type should all be of
8492          the same type specified in the debugging info.  No need to
8493          consult the object tag.  */
8494       result =
8495         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8496
8497       elt_type0 = type0;
8498       for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8499         {
8500           struct type *range_type =
8501             to_fixed_range_type (index_type_desc->field (i).type (), dval);
8502
8503           result = create_array_type (alloc_type_copy (elt_type0),
8504                                       result, range_type);
8505           elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8506         }
8507     }
8508
8509   /* We want to preserve the type name.  This can be useful when
8510      trying to get the type name of a value that has already been
8511      printed (for instance, if the user did "print VAR; whatis $".  */
8512   result->set_name (type0->name ());
8513
8514   if (constrained_packed_array_p)
8515     {
8516       /* So far, the resulting type has been created as if the original
8517          type was a regular (non-packed) array type.  As a result, the
8518          bitsize of the array elements needs to be set again, and the array
8519          length needs to be recomputed based on that bitsize.  */
8520       int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8521       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8522
8523       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8524       TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8525       if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8526         TYPE_LENGTH (result)++;
8527     }
8528
8529   result->set_is_fixed_instance (true);
8530   return result;
8531 }
8532
8533
8534 /* A standard type (containing no dynamically sized components)
8535    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8536    DVAL describes a record containing any discriminants used in TYPE0,
8537    and may be NULL if there are none, or if the object of type TYPE at
8538    ADDRESS or in VALADDR contains these discriminants.
8539    
8540    If CHECK_TAG is not null, in the case of tagged types, this function
8541    attempts to locate the object's tag and use it to compute the actual
8542    type.  However, when ADDRESS is null, we cannot use it to determine the
8543    location of the tag, and therefore compute the tagged type's actual type.
8544    So we return the tagged type without consulting the tag.  */
8545    
8546 static struct type *
8547 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8548                    CORE_ADDR address, struct value *dval, int check_tag)
8549 {
8550   type = ada_check_typedef (type);
8551
8552   /* Only un-fixed types need to be handled here.  */
8553   if (!HAVE_GNAT_AUX_INFO (type))
8554     return type;
8555
8556   switch (type->code ())
8557     {
8558     default:
8559       return type;
8560     case TYPE_CODE_STRUCT:
8561       {
8562         struct type *static_type = to_static_fixed_type (type);
8563         struct type *fixed_record_type =
8564           to_fixed_record_type (type, valaddr, address, NULL);
8565
8566         /* If STATIC_TYPE is a tagged type and we know the object's address,
8567            then we can determine its tag, and compute the object's actual
8568            type from there.  Note that we have to use the fixed record
8569            type (the parent part of the record may have dynamic fields
8570            and the way the location of _tag is expressed may depend on
8571            them).  */
8572
8573         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8574           {
8575             struct value *tag =
8576               value_tag_from_contents_and_address
8577               (fixed_record_type,
8578                valaddr,
8579                address);
8580             struct type *real_type = type_from_tag (tag);
8581             struct value *obj =
8582               value_from_contents_and_address (fixed_record_type,
8583                                                valaddr,
8584                                                address);
8585             fixed_record_type = value_type (obj);
8586             if (real_type != NULL)
8587               return to_fixed_record_type
8588                 (real_type, NULL,
8589                  value_address (ada_tag_value_at_base_address (obj)), NULL);
8590           }
8591
8592         /* Check to see if there is a parallel ___XVZ variable.
8593            If there is, then it provides the actual size of our type.  */
8594         else if (ada_type_name (fixed_record_type) != NULL)
8595           {
8596             const char *name = ada_type_name (fixed_record_type);
8597             char *xvz_name
8598               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8599             bool xvz_found = false;
8600             LONGEST size;
8601
8602             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8603             try
8604               {
8605                 xvz_found = get_int_var_value (xvz_name, size);
8606               }
8607             catch (const gdb_exception_error &except)
8608               {
8609                 /* We found the variable, but somehow failed to read
8610                    its value.  Rethrow the same error, but with a little
8611                    bit more information, to help the user understand
8612                    what went wrong (Eg: the variable might have been
8613                    optimized out).  */
8614                 throw_error (except.error,
8615                              _("unable to read value of %s (%s)"),
8616                              xvz_name, except.what ());
8617               }
8618
8619             if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8620               {
8621                 fixed_record_type = copy_type (fixed_record_type);
8622                 TYPE_LENGTH (fixed_record_type) = size;
8623
8624                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
8625                    observed this when the debugging info is STABS, and
8626                    apparently it is something that is hard to fix.
8627
8628                    In practice, we don't need the actual type definition
8629                    at all, because the presence of the XVZ variable allows us
8630                    to assume that there must be a XVS type as well, which we
8631                    should be able to use later, when we need the actual type
8632                    definition.
8633
8634                    In the meantime, pretend that the "fixed" type we are
8635                    returning is NOT a stub, because this can cause trouble
8636                    when using this type to create new types targeting it.
8637                    Indeed, the associated creation routines often check
8638                    whether the target type is a stub and will try to replace
8639                    it, thus using a type with the wrong size.  This, in turn,
8640                    might cause the new type to have the wrong size too.
8641                    Consider the case of an array, for instance, where the size
8642                    of the array is computed from the number of elements in
8643                    our array multiplied by the size of its element.  */
8644                 fixed_record_type->set_is_stub (false);
8645               }
8646           }
8647         return fixed_record_type;
8648       }
8649     case TYPE_CODE_ARRAY:
8650       return to_fixed_array_type (type, dval, 1);
8651     case TYPE_CODE_UNION:
8652       if (dval == NULL)
8653         return type;
8654       else
8655         return to_fixed_variant_branch_type (type, valaddr, address, dval);
8656     }
8657 }
8658
8659 /* The same as ada_to_fixed_type_1, except that it preserves the type
8660    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8661
8662    The typedef layer needs be preserved in order to differentiate between
8663    arrays and array pointers when both types are implemented using the same
8664    fat pointer.  In the array pointer case, the pointer is encoded as
8665    a typedef of the pointer type.  For instance, considering:
8666
8667           type String_Access is access String;
8668           S1 : String_Access := null;
8669
8670    To the debugger, S1 is defined as a typedef of type String.  But
8671    to the user, it is a pointer.  So if the user tries to print S1,
8672    we should not dereference the array, but print the array address
8673    instead.
8674
8675    If we didn't preserve the typedef layer, we would lose the fact that
8676    the type is to be presented as a pointer (needs de-reference before
8677    being printed).  And we would also use the source-level type name.  */
8678
8679 struct type *
8680 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8681                    CORE_ADDR address, struct value *dval, int check_tag)
8682
8683 {
8684   struct type *fixed_type =
8685     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8686
8687   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8688       then preserve the typedef layer.
8689
8690       Implementation note: We can only check the main-type portion of
8691       the TYPE and FIXED_TYPE, because eliminating the typedef layer
8692       from TYPE now returns a type that has the same instance flags
8693       as TYPE.  For instance, if TYPE is a "typedef const", and its
8694       target type is a "struct", then the typedef elimination will return
8695       a "const" version of the target type.  See check_typedef for more
8696       details about how the typedef layer elimination is done.
8697
8698       brobecker/2010-11-19: It seems to me that the only case where it is
8699       useful to preserve the typedef layer is when dealing with fat pointers.
8700       Perhaps, we could add a check for that and preserve the typedef layer
8701       only in that situation.  But this seems unnecessary so far, probably
8702       because we call check_typedef/ada_check_typedef pretty much everywhere.
8703       */
8704   if (type->code () == TYPE_CODE_TYPEDEF
8705       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8706           == TYPE_MAIN_TYPE (fixed_type)))
8707     return type;
8708
8709   return fixed_type;
8710 }
8711
8712 /* A standard (static-sized) type corresponding as well as possible to
8713    TYPE0, but based on no runtime data.  */
8714
8715 static struct type *
8716 to_static_fixed_type (struct type *type0)
8717 {
8718   struct type *type;
8719
8720   if (type0 == NULL)
8721     return NULL;
8722
8723   if (type0->is_fixed_instance ())
8724     return type0;
8725
8726   type0 = ada_check_typedef (type0);
8727
8728   switch (type0->code ())
8729     {
8730     default:
8731       return type0;
8732     case TYPE_CODE_STRUCT:
8733       type = dynamic_template_type (type0);
8734       if (type != NULL)
8735         return template_to_static_fixed_type (type);
8736       else
8737         return template_to_static_fixed_type (type0);
8738     case TYPE_CODE_UNION:
8739       type = ada_find_parallel_type (type0, "___XVU");
8740       if (type != NULL)
8741         return template_to_static_fixed_type (type);
8742       else
8743         return template_to_static_fixed_type (type0);
8744     }
8745 }
8746
8747 /* A static approximation of TYPE with all type wrappers removed.  */
8748
8749 static struct type *
8750 static_unwrap_type (struct type *type)
8751 {
8752   if (ada_is_aligner_type (type))
8753     {
8754       struct type *type1 = ada_check_typedef (type)->field (0).type ();
8755       if (ada_type_name (type1) == NULL)
8756         type1->set_name (ada_type_name (type));
8757
8758       return static_unwrap_type (type1);
8759     }
8760   else
8761     {
8762       struct type *raw_real_type = ada_get_base_type (type);
8763
8764       if (raw_real_type == type)
8765         return type;
8766       else
8767         return to_static_fixed_type (raw_real_type);
8768     }
8769 }
8770
8771 /* In some cases, incomplete and private types require
8772    cross-references that are not resolved as records (for example,
8773       type Foo;
8774       type FooP is access Foo;
8775       V: FooP;
8776       type Foo is array ...;
8777    ).  In these cases, since there is no mechanism for producing
8778    cross-references to such types, we instead substitute for FooP a
8779    stub enumeration type that is nowhere resolved, and whose tag is
8780    the name of the actual type.  Call these types "non-record stubs".  */
8781
8782 /* A type equivalent to TYPE that is not a non-record stub, if one
8783    exists, otherwise TYPE.  */
8784
8785 struct type *
8786 ada_check_typedef (struct type *type)
8787 {
8788   if (type == NULL)
8789     return NULL;
8790
8791   /* If our type is an access to an unconstrained array, which is encoded
8792      as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8793      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8794      what allows us to distinguish between fat pointers that represent
8795      array types, and fat pointers that represent array access types
8796      (in both cases, the compiler implements them as fat pointers).  */
8797   if (ada_is_access_to_unconstrained_array (type))
8798     return type;
8799
8800   type = check_typedef (type);
8801   if (type == NULL || type->code () != TYPE_CODE_ENUM
8802       || !type->is_stub ()
8803       || type->name () == NULL)
8804     return type;
8805   else
8806     {
8807       const char *name = type->name ();
8808       struct type *type1 = ada_find_any_type (name);
8809
8810       if (type1 == NULL)
8811         return type;
8812
8813       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8814          stubs pointing to arrays, as we don't create symbols for array
8815          types, only for the typedef-to-array types).  If that's the case,
8816          strip the typedef layer.  */
8817       if (type1->code () == TYPE_CODE_TYPEDEF)
8818         type1 = ada_check_typedef (type1);
8819
8820       return type1;
8821     }
8822 }
8823
8824 /* A value representing the data at VALADDR/ADDRESS as described by
8825    type TYPE0, but with a standard (static-sized) type that correctly
8826    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
8827    type, then return VAL0 [this feature is simply to avoid redundant
8828    creation of struct values].  */
8829
8830 static struct value *
8831 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8832                            struct value *val0)
8833 {
8834   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8835
8836   if (type == type0 && val0 != NULL)
8837     return val0;
8838
8839   if (VALUE_LVAL (val0) != lval_memory)
8840     {
8841       /* Our value does not live in memory; it could be a convenience
8842          variable, for instance.  Create a not_lval value using val0's
8843          contents.  */
8844       return value_from_contents (type, value_contents (val0).data ());
8845     }
8846
8847   return value_from_contents_and_address (type, 0, address);
8848 }
8849
8850 /* A value representing VAL, but with a standard (static-sized) type
8851    that correctly describes it.  Does not necessarily create a new
8852    value.  */
8853
8854 struct value *
8855 ada_to_fixed_value (struct value *val)
8856 {
8857   val = unwrap_value (val);
8858   val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8859   return val;
8860 }
8861 \f
8862
8863 /* Attributes */
8864
8865 /* Table mapping attribute numbers to names.
8866    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
8867
8868 static const char * const attribute_names[] = {
8869   "<?>",
8870
8871   "first",
8872   "last",
8873   "length",
8874   "image",
8875   "max",
8876   "min",
8877   "modulus",
8878   "pos",
8879   "size",
8880   "tag",
8881   "val",
8882   0
8883 };
8884
8885 static const char *
8886 ada_attribute_name (enum exp_opcode n)
8887 {
8888   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8889     return attribute_names[n - OP_ATR_FIRST + 1];
8890   else
8891     return attribute_names[0];
8892 }
8893
8894 /* Evaluate the 'POS attribute applied to ARG.  */
8895
8896 static LONGEST
8897 pos_atr (struct value *arg)
8898 {
8899   struct value *val = coerce_ref (arg);
8900   struct type *type = value_type (val);
8901
8902   if (!discrete_type_p (type))
8903     error (_("'POS only defined on discrete types"));
8904
8905   gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8906   if (!result.has_value ())
8907     error (_("enumeration value is invalid: can't find 'POS"));
8908
8909   return *result;
8910 }
8911
8912 struct value *
8913 ada_pos_atr (struct type *expect_type,
8914              struct expression *exp,
8915              enum noside noside, enum exp_opcode op,
8916              struct value *arg)
8917 {
8918   struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8919   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8920     return value_zero (type, not_lval);
8921   return value_from_longest (type, pos_atr (arg));
8922 }
8923
8924 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
8925
8926 static struct value *
8927 val_atr (struct type *type, LONGEST val)
8928 {
8929   gdb_assert (discrete_type_p (type));
8930   if (type->code () == TYPE_CODE_RANGE)
8931     type = TYPE_TARGET_TYPE (type);
8932   if (type->code () == TYPE_CODE_ENUM)
8933     {
8934       if (val < 0 || val >= type->num_fields ())
8935         error (_("argument to 'VAL out of range"));
8936       val = type->field (val).loc_enumval ();
8937     }
8938   return value_from_longest (type, val);
8939 }
8940
8941 struct value *
8942 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8943 {
8944   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8945     return value_zero (type, not_lval);
8946
8947   if (!discrete_type_p (type))
8948     error (_("'VAL only defined on discrete types"));
8949   if (!integer_type_p (value_type (arg)))
8950     error (_("'VAL requires integral argument"));
8951
8952   return val_atr (type, value_as_long (arg));
8953 }
8954 \f
8955
8956                                 /* Evaluation */
8957
8958 /* True if TYPE appears to be an Ada character type.
8959    [At the moment, this is true only for Character and Wide_Character;
8960    It is a heuristic test that could stand improvement].  */
8961
8962 bool
8963 ada_is_character_type (struct type *type)
8964 {
8965   const char *name;
8966
8967   /* If the type code says it's a character, then assume it really is,
8968      and don't check any further.  */
8969   if (type->code () == TYPE_CODE_CHAR)
8970     return true;
8971   
8972   /* Otherwise, assume it's a character type iff it is a discrete type
8973      with a known character type name.  */
8974   name = ada_type_name (type);
8975   return (name != NULL
8976           && (type->code () == TYPE_CODE_INT
8977               || type->code () == TYPE_CODE_RANGE)
8978           && (strcmp (name, "character") == 0
8979               || strcmp (name, "wide_character") == 0
8980               || strcmp (name, "wide_wide_character") == 0
8981               || strcmp (name, "unsigned char") == 0));
8982 }
8983
8984 /* True if TYPE appears to be an Ada string type.  */
8985
8986 bool
8987 ada_is_string_type (struct type *type)
8988 {
8989   type = ada_check_typedef (type);
8990   if (type != NULL
8991       && type->code () != TYPE_CODE_PTR
8992       && (ada_is_simple_array_type (type)
8993           || ada_is_array_descriptor_type (type))
8994       && ada_array_arity (type) == 1)
8995     {
8996       struct type *elttype = ada_array_element_type (type, 1);
8997
8998       return ada_is_character_type (elttype);
8999     }
9000   else
9001     return false;
9002 }
9003
9004 /* The compiler sometimes provides a parallel XVS type for a given
9005    PAD type.  Normally, it is safe to follow the PAD type directly,
9006    but older versions of the compiler have a bug that causes the offset
9007    of its "F" field to be wrong.  Following that field in that case
9008    would lead to incorrect results, but this can be worked around
9009    by ignoring the PAD type and using the associated XVS type instead.
9010
9011    Set to True if the debugger should trust the contents of PAD types.
9012    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
9013 static bool trust_pad_over_xvs = true;
9014
9015 /* True if TYPE is a struct type introduced by the compiler to force the
9016    alignment of a value.  Such types have a single field with a
9017    distinctive name.  */
9018
9019 int
9020 ada_is_aligner_type (struct type *type)
9021 {
9022   type = ada_check_typedef (type);
9023
9024   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9025     return 0;
9026
9027   return (type->code () == TYPE_CODE_STRUCT
9028           && type->num_fields () == 1
9029           && strcmp (type->field (0).name (), "F") == 0);
9030 }
9031
9032 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9033    the parallel type.  */
9034
9035 struct type *
9036 ada_get_base_type (struct type *raw_type)
9037 {
9038   struct type *real_type_namer;
9039   struct type *raw_real_type;
9040
9041   if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
9042     return raw_type;
9043
9044   if (ada_is_aligner_type (raw_type))
9045     /* The encoding specifies that we should always use the aligner type.
9046        So, even if this aligner type has an associated XVS type, we should
9047        simply ignore it.
9048
9049        According to the compiler gurus, an XVS type parallel to an aligner
9050        type may exist because of a stabs limitation.  In stabs, aligner
9051        types are empty because the field has a variable-sized type, and
9052        thus cannot actually be used as an aligner type.  As a result,
9053        we need the associated parallel XVS type to decode the type.
9054        Since the policy in the compiler is to not change the internal
9055        representation based on the debugging info format, we sometimes
9056        end up having a redundant XVS type parallel to the aligner type.  */
9057     return raw_type;
9058
9059   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9060   if (real_type_namer == NULL
9061       || real_type_namer->code () != TYPE_CODE_STRUCT
9062       || real_type_namer->num_fields () != 1)
9063     return raw_type;
9064
9065   if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
9066     {
9067       /* This is an older encoding form where the base type needs to be
9068          looked up by name.  We prefer the newer encoding because it is
9069          more efficient.  */
9070       raw_real_type = ada_find_any_type (real_type_namer->field (0).name ());
9071       if (raw_real_type == NULL)
9072         return raw_type;
9073       else
9074         return raw_real_type;
9075     }
9076
9077   /* The field in our XVS type is a reference to the base type.  */
9078   return TYPE_TARGET_TYPE (real_type_namer->field (0).type ());
9079 }
9080
9081 /* The type of value designated by TYPE, with all aligners removed.  */
9082
9083 struct type *
9084 ada_aligned_type (struct type *type)
9085 {
9086   if (ada_is_aligner_type (type))
9087     return ada_aligned_type (type->field (0).type ());
9088   else
9089     return ada_get_base_type (type);
9090 }
9091
9092
9093 /* The address of the aligned value in an object at address VALADDR
9094    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
9095
9096 const gdb_byte *
9097 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9098 {
9099   if (ada_is_aligner_type (type))
9100     return ada_aligned_value_addr
9101       (type->field (0).type (),
9102        valaddr + type->field (0).loc_bitpos () / TARGET_CHAR_BIT);
9103   else
9104     return valaddr;
9105 }
9106
9107
9108
9109 /* The printed representation of an enumeration literal with encoded
9110    name NAME.  The value is good to the next call of ada_enum_name.  */
9111 const char *
9112 ada_enum_name (const char *name)
9113 {
9114   static std::string storage;
9115   const char *tmp;
9116
9117   /* First, unqualify the enumeration name:
9118      1. Search for the last '.' character.  If we find one, then skip
9119      all the preceding characters, the unqualified name starts
9120      right after that dot.
9121      2. Otherwise, we may be debugging on a target where the compiler
9122      translates dots into "__".  Search forward for double underscores,
9123      but stop searching when we hit an overloading suffix, which is
9124      of the form "__" followed by digits.  */
9125
9126   tmp = strrchr (name, '.');
9127   if (tmp != NULL)
9128     name = tmp + 1;
9129   else
9130     {
9131       while ((tmp = strstr (name, "__")) != NULL)
9132         {
9133           if (isdigit (tmp[2]))
9134             break;
9135           else
9136             name = tmp + 2;
9137         }
9138     }
9139
9140   if (name[0] == 'Q')
9141     {
9142       int v;
9143
9144       if (name[1] == 'U' || name[1] == 'W')
9145         {
9146           int offset = 2;
9147           if (name[1] == 'W' && name[2] == 'W')
9148             {
9149               /* Also handle the QWW case.  */
9150               ++offset;
9151             }
9152           if (sscanf (name + offset, "%x", &v) != 1)
9153             return name;
9154         }
9155       else if (((name[1] >= '0' && name[1] <= '9')
9156                 || (name[1] >= 'a' && name[1] <= 'z'))
9157                && name[2] == '\0')
9158         {
9159           storage = string_printf ("'%c'", name[1]);
9160           return storage.c_str ();
9161         }
9162       else
9163         return name;
9164
9165       if (isascii (v) && isprint (v))
9166         storage = string_printf ("'%c'", v);
9167       else if (name[1] == 'U')
9168         storage = string_printf ("'[\"%02x\"]'", v);
9169       else if (name[2] != 'W')
9170         storage = string_printf ("'[\"%04x\"]'", v);
9171       else
9172         storage = string_printf ("'[\"%06x\"]'", v);
9173
9174       return storage.c_str ();
9175     }
9176   else
9177     {
9178       tmp = strstr (name, "__");
9179       if (tmp == NULL)
9180         tmp = strstr (name, "$");
9181       if (tmp != NULL)
9182         {
9183           storage = std::string (name, tmp - name);
9184           return storage.c_str ();
9185         }
9186
9187       return name;
9188     }
9189 }
9190
9191 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9192    value it wraps.  */
9193
9194 static struct value *
9195 unwrap_value (struct value *val)
9196 {
9197   struct type *type = ada_check_typedef (value_type (val));
9198
9199   if (ada_is_aligner_type (type))
9200     {
9201       struct value *v = ada_value_struct_elt (val, "F", 0);
9202       struct type *val_type = ada_check_typedef (value_type (v));
9203
9204       if (ada_type_name (val_type) == NULL)
9205         val_type->set_name (ada_type_name (type));
9206
9207       return unwrap_value (v);
9208     }
9209   else
9210     {
9211       struct type *raw_real_type =
9212         ada_check_typedef (ada_get_base_type (type));
9213
9214       /* If there is no parallel XVS or XVE type, then the value is
9215          already unwrapped.  Return it without further modification.  */
9216       if ((type == raw_real_type)
9217           && ada_find_parallel_type (type, "___XVE") == NULL)
9218         return val;
9219
9220       return
9221         coerce_unspec_val_to_type
9222         (val, ada_to_fixed_type (raw_real_type, 0,
9223                                  value_address (val),
9224                                  NULL, 1));
9225     }
9226 }
9227
9228 /* Given two array types T1 and T2, return nonzero iff both arrays
9229    contain the same number of elements.  */
9230
9231 static int
9232 ada_same_array_size_p (struct type *t1, struct type *t2)
9233 {
9234   LONGEST lo1, hi1, lo2, hi2;
9235
9236   /* Get the array bounds in order to verify that the size of
9237      the two arrays match.  */
9238   if (!get_array_bounds (t1, &lo1, &hi1)
9239       || !get_array_bounds (t2, &lo2, &hi2))
9240     error (_("unable to determine array bounds"));
9241
9242   /* To make things easier for size comparison, normalize a bit
9243      the case of empty arrays by making sure that the difference
9244      between upper bound and lower bound is always -1.  */
9245   if (lo1 > hi1)
9246     hi1 = lo1 - 1;
9247   if (lo2 > hi2)
9248     hi2 = lo2 - 1;
9249
9250   return (hi1 - lo1 == hi2 - lo2);
9251 }
9252
9253 /* Assuming that VAL is an array of integrals, and TYPE represents
9254    an array with the same number of elements, but with wider integral
9255    elements, return an array "casted" to TYPE.  In practice, this
9256    means that the returned array is built by casting each element
9257    of the original array into TYPE's (wider) element type.  */
9258
9259 static struct value *
9260 ada_promote_array_of_integrals (struct type *type, struct value *val)
9261 {
9262   struct type *elt_type = TYPE_TARGET_TYPE (type);
9263   LONGEST lo, hi;
9264   LONGEST i;
9265
9266   /* Verify that both val and type are arrays of scalars, and
9267      that the size of val's elements is smaller than the size
9268      of type's element.  */
9269   gdb_assert (type->code () == TYPE_CODE_ARRAY);
9270   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9271   gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
9272   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9273   gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9274               > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9275
9276   if (!get_array_bounds (type, &lo, &hi))
9277     error (_("unable to determine array bounds"));
9278
9279   value *res = allocate_value (type);
9280   gdb::array_view<gdb_byte> res_contents = value_contents_writeable (res);
9281
9282   /* Promote each array element.  */
9283   for (i = 0; i < hi - lo + 1; i++)
9284     {
9285       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9286       int elt_len = TYPE_LENGTH (elt_type);
9287
9288       copy (value_contents_all (elt), res_contents.slice (elt_len * i, elt_len));
9289     }
9290
9291   return res;
9292 }
9293
9294 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9295    return the converted value.  */
9296
9297 static struct value *
9298 coerce_for_assign (struct type *type, struct value *val)
9299 {
9300   struct type *type2 = value_type (val);
9301
9302   if (type == type2)
9303     return val;
9304
9305   type2 = ada_check_typedef (type2);
9306   type = ada_check_typedef (type);
9307
9308   if (type2->code () == TYPE_CODE_PTR
9309       && type->code () == TYPE_CODE_ARRAY)
9310     {
9311       val = ada_value_ind (val);
9312       type2 = value_type (val);
9313     }
9314
9315   if (type2->code () == TYPE_CODE_ARRAY
9316       && type->code () == TYPE_CODE_ARRAY)
9317     {
9318       if (!ada_same_array_size_p (type, type2))
9319         error (_("cannot assign arrays of different length"));
9320
9321       if (is_integral_type (TYPE_TARGET_TYPE (type))
9322           && is_integral_type (TYPE_TARGET_TYPE (type2))
9323           && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9324                < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9325         {
9326           /* Allow implicit promotion of the array elements to
9327              a wider type.  */
9328           return ada_promote_array_of_integrals (type, val);
9329         }
9330
9331       if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9332           != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9333         error (_("Incompatible types in assignment"));
9334       deprecated_set_value_type (val, type);
9335     }
9336   return val;
9337 }
9338
9339 static struct value *
9340 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9341 {
9342   struct value *val;
9343   struct type *type1, *type2;
9344   LONGEST v, v1, v2;
9345
9346   arg1 = coerce_ref (arg1);
9347   arg2 = coerce_ref (arg2);
9348   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9349   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9350
9351   if (type1->code () != TYPE_CODE_INT
9352       || type2->code () != TYPE_CODE_INT)
9353     return value_binop (arg1, arg2, op);
9354
9355   switch (op)
9356     {
9357     case BINOP_MOD:
9358     case BINOP_DIV:
9359     case BINOP_REM:
9360       break;
9361     default:
9362       return value_binop (arg1, arg2, op);
9363     }
9364
9365   v2 = value_as_long (arg2);
9366   if (v2 == 0)
9367     {
9368       const char *name;
9369       if (op == BINOP_MOD)
9370         name = "mod";
9371       else if (op == BINOP_DIV)
9372         name = "/";
9373       else
9374         {
9375           gdb_assert (op == BINOP_REM);
9376           name = "rem";
9377         }
9378
9379       error (_("second operand of %s must not be zero."), name);
9380     }
9381
9382   if (type1->is_unsigned () || op == BINOP_MOD)
9383     return value_binop (arg1, arg2, op);
9384
9385   v1 = value_as_long (arg1);
9386   switch (op)
9387     {
9388     case BINOP_DIV:
9389       v = v1 / v2;
9390       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9391         v += v > 0 ? -1 : 1;
9392       break;
9393     case BINOP_REM:
9394       v = v1 % v2;
9395       if (v * v1 < 0)
9396         v -= v2;
9397       break;
9398     default:
9399       /* Should not reach this point.  */
9400       v = 0;
9401     }
9402
9403   val = allocate_value (type1);
9404   store_unsigned_integer (value_contents_raw (val).data (),
9405                           TYPE_LENGTH (value_type (val)),
9406                           type_byte_order (type1), v);
9407   return val;
9408 }
9409
9410 static int
9411 ada_value_equal (struct value *arg1, struct value *arg2)
9412 {
9413   if (ada_is_direct_array_type (value_type (arg1))
9414       || ada_is_direct_array_type (value_type (arg2)))
9415     {
9416       struct type *arg1_type, *arg2_type;
9417
9418       /* Automatically dereference any array reference before
9419          we attempt to perform the comparison.  */
9420       arg1 = ada_coerce_ref (arg1);
9421       arg2 = ada_coerce_ref (arg2);
9422
9423       arg1 = ada_coerce_to_simple_array (arg1);
9424       arg2 = ada_coerce_to_simple_array (arg2);
9425
9426       arg1_type = ada_check_typedef (value_type (arg1));
9427       arg2_type = ada_check_typedef (value_type (arg2));
9428
9429       if (arg1_type->code () != TYPE_CODE_ARRAY
9430           || arg2_type->code () != TYPE_CODE_ARRAY)
9431         error (_("Attempt to compare array with non-array"));
9432       /* FIXME: The following works only for types whose
9433          representations use all bits (no padding or undefined bits)
9434          and do not have user-defined equality.  */
9435       return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9436               && memcmp (value_contents (arg1).data (),
9437                          value_contents (arg2).data (),
9438                          TYPE_LENGTH (arg1_type)) == 0);
9439     }
9440   return value_equal (arg1, arg2);
9441 }
9442
9443 namespace expr
9444 {
9445
9446 bool
9447 check_objfile (const std::unique_ptr<ada_component> &comp,
9448                struct objfile *objfile)
9449 {
9450   return comp->uses_objfile (objfile);
9451 }
9452
9453 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9454    component of LHS (a simple array or a record).  Does not modify the
9455    inferior's memory, nor does it modify LHS (unless LHS ==
9456    CONTAINER).  */
9457
9458 static void
9459 assign_component (struct value *container, struct value *lhs, LONGEST index,
9460                   struct expression *exp, operation_up &arg)
9461 {
9462   scoped_value_mark mark;
9463
9464   struct value *elt;
9465   struct type *lhs_type = check_typedef (value_type (lhs));
9466
9467   if (lhs_type->code () == TYPE_CODE_ARRAY)
9468     {
9469       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9470       struct value *index_val = value_from_longest (index_type, index);
9471
9472       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9473     }
9474   else
9475     {
9476       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9477       elt = ada_to_fixed_value (elt);
9478     }
9479
9480   ada_aggregate_operation *ag_op
9481     = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9482   if (ag_op != nullptr)
9483     ag_op->assign_aggregate (container, elt, exp);
9484   else
9485     value_assign_to_component (container, elt,
9486                                arg->evaluate (nullptr, exp,
9487                                               EVAL_NORMAL));
9488 }
9489
9490 bool
9491 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9492 {
9493   for (const auto &item : m_components)
9494     if (item->uses_objfile (objfile))
9495       return true;
9496   return false;
9497 }
9498
9499 void
9500 ada_aggregate_component::dump (ui_file *stream, int depth)
9501 {
9502   gdb_printf (stream, _("%*sAggregate\n"), depth, "");
9503   for (const auto &item : m_components)
9504     item->dump (stream, depth + 1);
9505 }
9506
9507 void
9508 ada_aggregate_component::assign (struct value *container,
9509                                  struct value *lhs, struct expression *exp,
9510                                  std::vector<LONGEST> &indices,
9511                                  LONGEST low, LONGEST high)
9512 {
9513   for (auto &item : m_components)
9514     item->assign (container, lhs, exp, indices, low, high);
9515 }
9516
9517 /* See ada-exp.h.  */
9518
9519 value *
9520 ada_aggregate_operation::assign_aggregate (struct value *container,
9521                                            struct value *lhs,
9522                                            struct expression *exp)
9523 {
9524   struct type *lhs_type;
9525   LONGEST low_index, high_index;
9526
9527   container = ada_coerce_ref (container);
9528   if (ada_is_direct_array_type (value_type (container)))
9529     container = ada_coerce_to_simple_array (container);
9530   lhs = ada_coerce_ref (lhs);
9531   if (!deprecated_value_modifiable (lhs))
9532     error (_("Left operand of assignment is not a modifiable lvalue."));
9533
9534   lhs_type = check_typedef (value_type (lhs));
9535   if (ada_is_direct_array_type (lhs_type))
9536     {
9537       lhs = ada_coerce_to_simple_array (lhs);
9538       lhs_type = check_typedef (value_type (lhs));
9539       low_index = lhs_type->bounds ()->low.const_val ();
9540       high_index = lhs_type->bounds ()->high.const_val ();
9541     }
9542   else if (lhs_type->code () == TYPE_CODE_STRUCT)
9543     {
9544       low_index = 0;
9545       high_index = num_visible_fields (lhs_type) - 1;
9546     }
9547   else
9548     error (_("Left-hand side must be array or record."));
9549
9550   std::vector<LONGEST> indices (4);
9551   indices[0] = indices[1] = low_index - 1;
9552   indices[2] = indices[3] = high_index + 1;
9553
9554   std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9555                                    low_index, high_index);
9556
9557   return container;
9558 }
9559
9560 bool
9561 ada_positional_component::uses_objfile (struct objfile *objfile)
9562 {
9563   return m_op->uses_objfile (objfile);
9564 }
9565
9566 void
9567 ada_positional_component::dump (ui_file *stream, int depth)
9568 {
9569   gdb_printf (stream, _("%*sPositional, index = %d\n"),
9570               depth, "", m_index);
9571   m_op->dump (stream, depth + 1);
9572 }
9573
9574 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9575    construct, given that the positions are relative to lower bound
9576    LOW, where HIGH is the upper bound.  Record the position in
9577    INDICES.  CONTAINER is as for assign_aggregate.  */
9578 void
9579 ada_positional_component::assign (struct value *container,
9580                                   struct value *lhs, struct expression *exp,
9581                                   std::vector<LONGEST> &indices,
9582                                   LONGEST low, LONGEST high)
9583 {
9584   LONGEST ind = m_index + low;
9585
9586   if (ind - 1 == high)
9587     warning (_("Extra components in aggregate ignored."));
9588   if (ind <= high)
9589     {
9590       add_component_interval (ind, ind, indices);
9591       assign_component (container, lhs, ind, exp, m_op);
9592     }
9593 }
9594
9595 bool
9596 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9597 {
9598   return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9599 }
9600
9601 void
9602 ada_discrete_range_association::dump (ui_file *stream, int depth)
9603 {
9604   gdb_printf (stream, _("%*sDiscrete range:\n"), depth, "");
9605   m_low->dump (stream, depth + 1);
9606   m_high->dump (stream, depth + 1);
9607 }
9608
9609 void
9610 ada_discrete_range_association::assign (struct value *container,
9611                                         struct value *lhs,
9612                                         struct expression *exp,
9613                                         std::vector<LONGEST> &indices,
9614                                         LONGEST low, LONGEST high,
9615                                         operation_up &op)
9616 {
9617   LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9618   LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9619
9620   if (lower <= upper && (lower < low || upper > high))
9621     error (_("Index in component association out of bounds."));
9622
9623   add_component_interval (lower, upper, indices);
9624   while (lower <= upper)
9625     {
9626       assign_component (container, lhs, lower, exp, op);
9627       lower += 1;
9628     }
9629 }
9630
9631 bool
9632 ada_name_association::uses_objfile (struct objfile *objfile)
9633 {
9634   return m_val->uses_objfile (objfile);
9635 }
9636
9637 void
9638 ada_name_association::dump (ui_file *stream, int depth)
9639 {
9640   gdb_printf (stream, _("%*sName:\n"), depth, "");
9641   m_val->dump (stream, depth + 1);
9642 }
9643
9644 void
9645 ada_name_association::assign (struct value *container,
9646                               struct value *lhs,
9647                               struct expression *exp,
9648                               std::vector<LONGEST> &indices,
9649                               LONGEST low, LONGEST high,
9650                               operation_up &op)
9651 {
9652   int index;
9653
9654   if (ada_is_direct_array_type (value_type (lhs)))
9655     index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9656                                                             EVAL_NORMAL)));
9657   else
9658     {
9659       ada_string_operation *strop
9660         = dynamic_cast<ada_string_operation *> (m_val.get ());
9661
9662       const char *name;
9663       if (strop != nullptr)
9664         name = strop->get_name ();
9665       else
9666         {
9667           ada_var_value_operation *vvo
9668             = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9669           if (vvo != nullptr)
9670             error (_("Invalid record component association."));
9671           name = vvo->get_symbol ()->natural_name ();
9672         }
9673
9674       index = 0;
9675       if (! find_struct_field (name, value_type (lhs), 0,
9676                                NULL, NULL, NULL, NULL, &index))
9677         error (_("Unknown component name: %s."), name);
9678     }
9679
9680   add_component_interval (index, index, indices);
9681   assign_component (container, lhs, index, exp, op);
9682 }
9683
9684 bool
9685 ada_choices_component::uses_objfile (struct objfile *objfile)
9686 {
9687   if (m_op->uses_objfile (objfile))
9688     return true;
9689   for (const auto &item : m_assocs)
9690     if (item->uses_objfile (objfile))
9691       return true;
9692   return false;
9693 }
9694
9695 void
9696 ada_choices_component::dump (ui_file *stream, int depth)
9697 {
9698   gdb_printf (stream, _("%*sChoices:\n"), depth, "");
9699   m_op->dump (stream, depth + 1);
9700   for (const auto &item : m_assocs)
9701     item->dump (stream, depth + 1);
9702 }
9703
9704 /* Assign into the components of LHS indexed by the OP_CHOICES
9705    construct at *POS, updating *POS past the construct, given that
9706    the allowable indices are LOW..HIGH.  Record the indices assigned
9707    to in INDICES.  CONTAINER is as for assign_aggregate.  */
9708 void
9709 ada_choices_component::assign (struct value *container,
9710                                struct value *lhs, struct expression *exp,
9711                                std::vector<LONGEST> &indices,
9712                                LONGEST low, LONGEST high)
9713 {
9714   for (auto &item : m_assocs)
9715     item->assign (container, lhs, exp, indices, low, high, m_op);
9716 }
9717
9718 bool
9719 ada_others_component::uses_objfile (struct objfile *objfile)
9720 {
9721   return m_op->uses_objfile (objfile);
9722 }
9723
9724 void
9725 ada_others_component::dump (ui_file *stream, int depth)
9726 {
9727   gdb_printf (stream, _("%*sOthers:\n"), depth, "");
9728   m_op->dump (stream, depth + 1);
9729 }
9730
9731 /* Assign the value of the expression in the OP_OTHERS construct in
9732    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9733    have not been previously assigned.  The index intervals already assigned
9734    are in INDICES.  CONTAINER is as for assign_aggregate.  */
9735 void
9736 ada_others_component::assign (struct value *container,
9737                               struct value *lhs, struct expression *exp,
9738                               std::vector<LONGEST> &indices,
9739                               LONGEST low, LONGEST high)
9740 {
9741   int num_indices = indices.size ();
9742   for (int i = 0; i < num_indices - 2; i += 2)
9743     {
9744       for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9745         assign_component (container, lhs, ind, exp, m_op);
9746     }
9747 }
9748
9749 struct value *
9750 ada_assign_operation::evaluate (struct type *expect_type,
9751                                 struct expression *exp,
9752                                 enum noside noside)
9753 {
9754   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9755
9756   ada_aggregate_operation *ag_op
9757     = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9758   if (ag_op != nullptr)
9759     {
9760       if (noside != EVAL_NORMAL)
9761         return arg1;
9762
9763       arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9764       return ada_value_assign (arg1, arg1);
9765     }
9766   /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9767      except if the lhs of our assignment is a convenience variable.
9768      In the case of assigning to a convenience variable, the lhs
9769      should be exactly the result of the evaluation of the rhs.  */
9770   struct type *type = value_type (arg1);
9771   if (VALUE_LVAL (arg1) == lval_internalvar)
9772     type = NULL;
9773   value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9774   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9775     return arg1;
9776   if (VALUE_LVAL (arg1) == lval_internalvar)
9777     {
9778       /* Nothing.  */
9779     }
9780   else
9781     arg2 = coerce_for_assign (value_type (arg1), arg2);
9782   return ada_value_assign (arg1, arg2);
9783 }
9784
9785 } /* namespace expr */
9786
9787 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9788    [ INDICES[0] .. INDICES[1] ],...  The resulting intervals do not
9789    overlap.  */
9790 static void
9791 add_component_interval (LONGEST low, LONGEST high, 
9792                         std::vector<LONGEST> &indices)
9793 {
9794   int i, j;
9795
9796   int size = indices.size ();
9797   for (i = 0; i < size; i += 2) {
9798     if (high >= indices[i] && low <= indices[i + 1])
9799       {
9800         int kh;
9801
9802         for (kh = i + 2; kh < size; kh += 2)
9803           if (high < indices[kh])
9804             break;
9805         if (low < indices[i])
9806           indices[i] = low;
9807         indices[i + 1] = indices[kh - 1];
9808         if (high > indices[i + 1])
9809           indices[i + 1] = high;
9810         memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9811         indices.resize (kh - i - 2);
9812         return;
9813       }
9814     else if (high < indices[i])
9815       break;
9816   }
9817         
9818   indices.resize (indices.size () + 2);
9819   for (j = indices.size () - 1; j >= i + 2; j -= 1)
9820     indices[j] = indices[j - 2];
9821   indices[i] = low;
9822   indices[i + 1] = high;
9823 }
9824
9825 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9826    is different.  */
9827
9828 static struct value *
9829 ada_value_cast (struct type *type, struct value *arg2)
9830 {
9831   if (type == ada_check_typedef (value_type (arg2)))
9832     return arg2;
9833
9834   return value_cast (type, arg2);
9835 }
9836
9837 /*  Evaluating Ada expressions, and printing their result.
9838     ------------------------------------------------------
9839
9840     1. Introduction:
9841     ----------------
9842
9843     We usually evaluate an Ada expression in order to print its value.
9844     We also evaluate an expression in order to print its type, which
9845     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9846     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
9847     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9848     the evaluation compared to the EVAL_NORMAL, but is otherwise very
9849     similar.
9850
9851     Evaluating expressions is a little more complicated for Ada entities
9852     than it is for entities in languages such as C.  The main reason for
9853     this is that Ada provides types whose definition might be dynamic.
9854     One example of such types is variant records.  Or another example
9855     would be an array whose bounds can only be known at run time.
9856
9857     The following description is a general guide as to what should be
9858     done (and what should NOT be done) in order to evaluate an expression
9859     involving such types, and when.  This does not cover how the semantic
9860     information is encoded by GNAT as this is covered separatly.  For the
9861     document used as the reference for the GNAT encoding, see exp_dbug.ads
9862     in the GNAT sources.
9863
9864     Ideally, we should embed each part of this description next to its
9865     associated code.  Unfortunately, the amount of code is so vast right
9866     now that it's hard to see whether the code handling a particular
9867     situation might be duplicated or not.  One day, when the code is
9868     cleaned up, this guide might become redundant with the comments
9869     inserted in the code, and we might want to remove it.
9870
9871     2. ``Fixing'' an Entity, the Simple Case:
9872     -----------------------------------------
9873
9874     When evaluating Ada expressions, the tricky issue is that they may
9875     reference entities whose type contents and size are not statically
9876     known.  Consider for instance a variant record:
9877
9878        type Rec (Empty : Boolean := True) is record
9879           case Empty is
9880              when True => null;
9881              when False => Value : Integer;
9882           end case;
9883        end record;
9884        Yes : Rec := (Empty => False, Value => 1);
9885        No  : Rec := (empty => True);
9886
9887     The size and contents of that record depends on the value of the
9888     descriminant (Rec.Empty).  At this point, neither the debugging
9889     information nor the associated type structure in GDB are able to
9890     express such dynamic types.  So what the debugger does is to create
9891     "fixed" versions of the type that applies to the specific object.
9892     We also informally refer to this operation as "fixing" an object,
9893     which means creating its associated fixed type.
9894
9895     Example: when printing the value of variable "Yes" above, its fixed
9896     type would look like this:
9897
9898        type Rec is record
9899           Empty : Boolean;
9900           Value : Integer;
9901        end record;
9902
9903     On the other hand, if we printed the value of "No", its fixed type
9904     would become:
9905
9906        type Rec is record
9907           Empty : Boolean;
9908        end record;
9909
9910     Things become a little more complicated when trying to fix an entity
9911     with a dynamic type that directly contains another dynamic type,
9912     such as an array of variant records, for instance.  There are
9913     two possible cases: Arrays, and records.
9914
9915     3. ``Fixing'' Arrays:
9916     ---------------------
9917
9918     The type structure in GDB describes an array in terms of its bounds,
9919     and the type of its elements.  By design, all elements in the array
9920     have the same type and we cannot represent an array of variant elements
9921     using the current type structure in GDB.  When fixing an array,
9922     we cannot fix the array element, as we would potentially need one
9923     fixed type per element of the array.  As a result, the best we can do
9924     when fixing an array is to produce an array whose bounds and size
9925     are correct (allowing us to read it from memory), but without having
9926     touched its element type.  Fixing each element will be done later,
9927     when (if) necessary.
9928
9929     Arrays are a little simpler to handle than records, because the same
9930     amount of memory is allocated for each element of the array, even if
9931     the amount of space actually used by each element differs from element
9932     to element.  Consider for instance the following array of type Rec:
9933
9934        type Rec_Array is array (1 .. 2) of Rec;
9935
9936     The actual amount of memory occupied by each element might be different
9937     from element to element, depending on the value of their discriminant.
9938     But the amount of space reserved for each element in the array remains
9939     fixed regardless.  So we simply need to compute that size using
9940     the debugging information available, from which we can then determine
9941     the array size (we multiply the number of elements of the array by
9942     the size of each element).
9943
9944     The simplest case is when we have an array of a constrained element
9945     type. For instance, consider the following type declarations:
9946
9947         type Bounded_String (Max_Size : Integer) is
9948            Length : Integer;
9949            Buffer : String (1 .. Max_Size);
9950         end record;
9951         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9952
9953     In this case, the compiler describes the array as an array of
9954     variable-size elements (identified by its XVS suffix) for which
9955     the size can be read in the parallel XVZ variable.
9956
9957     In the case of an array of an unconstrained element type, the compiler
9958     wraps the array element inside a private PAD type.  This type should not
9959     be shown to the user, and must be "unwrap"'ed before printing.  Note
9960     that we also use the adjective "aligner" in our code to designate
9961     these wrapper types.
9962
9963     In some cases, the size allocated for each element is statically
9964     known.  In that case, the PAD type already has the correct size,
9965     and the array element should remain unfixed.
9966
9967     But there are cases when this size is not statically known.
9968     For instance, assuming that "Five" is an integer variable:
9969
9970         type Dynamic is array (1 .. Five) of Integer;
9971         type Wrapper (Has_Length : Boolean := False) is record
9972            Data : Dynamic;
9973            case Has_Length is
9974               when True => Length : Integer;
9975               when False => null;
9976            end case;
9977         end record;
9978         type Wrapper_Array is array (1 .. 2) of Wrapper;
9979
9980         Hello : Wrapper_Array := (others => (Has_Length => True,
9981                                              Data => (others => 17),
9982                                              Length => 1));
9983
9984
9985     The debugging info would describe variable Hello as being an
9986     array of a PAD type.  The size of that PAD type is not statically
9987     known, but can be determined using a parallel XVZ variable.
9988     In that case, a copy of the PAD type with the correct size should
9989     be used for the fixed array.
9990
9991     3. ``Fixing'' record type objects:
9992     ----------------------------------
9993
9994     Things are slightly different from arrays in the case of dynamic
9995     record types.  In this case, in order to compute the associated
9996     fixed type, we need to determine the size and offset of each of
9997     its components.  This, in turn, requires us to compute the fixed
9998     type of each of these components.
9999
10000     Consider for instance the example:
10001
10002         type Bounded_String (Max_Size : Natural) is record
10003            Str : String (1 .. Max_Size);
10004            Length : Natural;
10005         end record;
10006         My_String : Bounded_String (Max_Size => 10);
10007
10008     In that case, the position of field "Length" depends on the size
10009     of field Str, which itself depends on the value of the Max_Size
10010     discriminant.  In order to fix the type of variable My_String,
10011     we need to fix the type of field Str.  Therefore, fixing a variant
10012     record requires us to fix each of its components.
10013
10014     However, if a component does not have a dynamic size, the component
10015     should not be fixed.  In particular, fields that use a PAD type
10016     should not fixed.  Here is an example where this might happen
10017     (assuming type Rec above):
10018
10019        type Container (Big : Boolean) is record
10020           First : Rec;
10021           After : Integer;
10022           case Big is
10023              when True => Another : Integer;
10024              when False => null;
10025           end case;
10026        end record;
10027        My_Container : Container := (Big => False,
10028                                     First => (Empty => True),
10029                                     After => 42);
10030
10031     In that example, the compiler creates a PAD type for component First,
10032     whose size is constant, and then positions the component After just
10033     right after it.  The offset of component After is therefore constant
10034     in this case.
10035
10036     The debugger computes the position of each field based on an algorithm
10037     that uses, among other things, the actual position and size of the field
10038     preceding it.  Let's now imagine that the user is trying to print
10039     the value of My_Container.  If the type fixing was recursive, we would
10040     end up computing the offset of field After based on the size of the
10041     fixed version of field First.  And since in our example First has
10042     only one actual field, the size of the fixed type is actually smaller
10043     than the amount of space allocated to that field, and thus we would
10044     compute the wrong offset of field After.
10045
10046     To make things more complicated, we need to watch out for dynamic
10047     components of variant records (identified by the ___XVL suffix in
10048     the component name).  Even if the target type is a PAD type, the size
10049     of that type might not be statically known.  So the PAD type needs
10050     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
10051     we might end up with the wrong size for our component.  This can be
10052     observed with the following type declarations:
10053
10054         type Octal is new Integer range 0 .. 7;
10055         type Octal_Array is array (Positive range <>) of Octal;
10056         pragma Pack (Octal_Array);
10057
10058         type Octal_Buffer (Size : Positive) is record
10059            Buffer : Octal_Array (1 .. Size);
10060            Length : Integer;
10061         end record;
10062
10063     In that case, Buffer is a PAD type whose size is unset and needs
10064     to be computed by fixing the unwrapped type.
10065
10066     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10067     ----------------------------------------------------------
10068
10069     Lastly, when should the sub-elements of an entity that remained unfixed
10070     thus far, be actually fixed?
10071
10072     The answer is: Only when referencing that element.  For instance
10073     when selecting one component of a record, this specific component
10074     should be fixed at that point in time.  Or when printing the value
10075     of a record, each component should be fixed before its value gets
10076     printed.  Similarly for arrays, the element of the array should be
10077     fixed when printing each element of the array, or when extracting
10078     one element out of that array.  On the other hand, fixing should
10079     not be performed on the elements when taking a slice of an array!
10080
10081     Note that one of the side effects of miscomputing the offset and
10082     size of each field is that we end up also miscomputing the size
10083     of the containing type.  This can have adverse results when computing
10084     the value of an entity.  GDB fetches the value of an entity based
10085     on the size of its type, and thus a wrong size causes GDB to fetch
10086     the wrong amount of memory.  In the case where the computed size is
10087     too small, GDB fetches too little data to print the value of our
10088     entity.  Results in this case are unpredictable, as we usually read
10089     past the buffer containing the data =:-o.  */
10090
10091 /* A helper function for TERNOP_IN_RANGE.  */
10092
10093 static value *
10094 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
10095                       enum noside noside,
10096                       value *arg1, value *arg2, value *arg3)
10097 {
10098   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10099   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10100   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10101   return
10102     value_from_longest (type,
10103                         (value_less (arg1, arg3)
10104                          || value_equal (arg1, arg3))
10105                         && (value_less (arg2, arg1)
10106                             || value_equal (arg2, arg1)));
10107 }
10108
10109 /* A helper function for UNOP_NEG.  */
10110
10111 value *
10112 ada_unop_neg (struct type *expect_type,
10113               struct expression *exp,
10114               enum noside noside, enum exp_opcode op,
10115               struct value *arg1)
10116 {
10117   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10118   return value_neg (arg1);
10119 }
10120
10121 /* A helper function for UNOP_IN_RANGE.  */
10122
10123 value *
10124 ada_unop_in_range (struct type *expect_type,
10125                    struct expression *exp,
10126                    enum noside noside, enum exp_opcode op,
10127                    struct value *arg1, struct type *type)
10128 {
10129   struct value *arg2, *arg3;
10130   switch (type->code ())
10131     {
10132     default:
10133       lim_warning (_("Membership test incompletely implemented; "
10134                      "always returns true"));
10135       type = language_bool_type (exp->language_defn, exp->gdbarch);
10136       return value_from_longest (type, (LONGEST) 1);
10137
10138     case TYPE_CODE_RANGE:
10139       arg2 = value_from_longest (type,
10140                                  type->bounds ()->low.const_val ());
10141       arg3 = value_from_longest (type,
10142                                  type->bounds ()->high.const_val ());
10143       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10144       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10145       type = language_bool_type (exp->language_defn, exp->gdbarch);
10146       return
10147         value_from_longest (type,
10148                             (value_less (arg1, arg3)
10149                              || value_equal (arg1, arg3))
10150                             && (value_less (arg2, arg1)
10151                                 || value_equal (arg2, arg1)));
10152     }
10153 }
10154
10155 /* A helper function for OP_ATR_TAG.  */
10156
10157 value *
10158 ada_atr_tag (struct type *expect_type,
10159              struct expression *exp,
10160              enum noside noside, enum exp_opcode op,
10161              struct value *arg1)
10162 {
10163   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10164     return value_zero (ada_tag_type (arg1), not_lval);
10165
10166   return ada_value_tag (arg1);
10167 }
10168
10169 /* A helper function for OP_ATR_SIZE.  */
10170
10171 value *
10172 ada_atr_size (struct type *expect_type,
10173               struct expression *exp,
10174               enum noside noside, enum exp_opcode op,
10175               struct value *arg1)
10176 {
10177   struct type *type = value_type (arg1);
10178
10179   /* If the argument is a reference, then dereference its type, since
10180      the user is really asking for the size of the actual object,
10181      not the size of the pointer.  */
10182   if (type->code () == TYPE_CODE_REF)
10183     type = TYPE_TARGET_TYPE (type);
10184
10185   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10186     return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
10187   else
10188     return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
10189                                TARGET_CHAR_BIT * TYPE_LENGTH (type));
10190 }
10191
10192 /* A helper function for UNOP_ABS.  */
10193
10194 value *
10195 ada_abs (struct type *expect_type,
10196          struct expression *exp,
10197          enum noside noside, enum exp_opcode op,
10198          struct value *arg1)
10199 {
10200   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10201   if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
10202     return value_neg (arg1);
10203   else
10204     return arg1;
10205 }
10206
10207 /* A helper function for BINOP_MUL.  */
10208
10209 value *
10210 ada_mult_binop (struct type *expect_type,
10211                 struct expression *exp,
10212                 enum noside noside, enum exp_opcode op,
10213                 struct value *arg1, struct value *arg2)
10214 {
10215   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10216     {
10217       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10218       return value_zero (value_type (arg1), not_lval);
10219     }
10220   else
10221     {
10222       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10223       return ada_value_binop (arg1, arg2, op);
10224     }
10225 }
10226
10227 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL.  */
10228
10229 value *
10230 ada_equal_binop (struct type *expect_type,
10231                  struct expression *exp,
10232                  enum noside noside, enum exp_opcode op,
10233                  struct value *arg1, struct value *arg2)
10234 {
10235   int tem;
10236   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10237     tem = 0;
10238   else
10239     {
10240       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10241       tem = ada_value_equal (arg1, arg2);
10242     }
10243   if (op == BINOP_NOTEQUAL)
10244     tem = !tem;
10245   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10246   return value_from_longest (type, (LONGEST) tem);
10247 }
10248
10249 /* A helper function for TERNOP_SLICE.  */
10250
10251 value *
10252 ada_ternop_slice (struct expression *exp,
10253                   enum noside noside,
10254                   struct value *array, struct value *low_bound_val,
10255                   struct value *high_bound_val)
10256 {
10257   LONGEST low_bound;
10258   LONGEST high_bound;
10259
10260   low_bound_val = coerce_ref (low_bound_val);
10261   high_bound_val = coerce_ref (high_bound_val);
10262   low_bound = value_as_long (low_bound_val);
10263   high_bound = value_as_long (high_bound_val);
10264
10265   /* If this is a reference to an aligner type, then remove all
10266      the aligners.  */
10267   if (value_type (array)->code () == TYPE_CODE_REF
10268       && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10269     TYPE_TARGET_TYPE (value_type (array)) =
10270       ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
10271
10272   if (ada_is_any_packed_array_type (value_type (array)))
10273     error (_("cannot slice a packed array"));
10274
10275   /* If this is a reference to an array or an array lvalue,
10276      convert to a pointer.  */
10277   if (value_type (array)->code () == TYPE_CODE_REF
10278       || (value_type (array)->code () == TYPE_CODE_ARRAY
10279           && VALUE_LVAL (array) == lval_memory))
10280     array = value_addr (array);
10281
10282   if (noside == EVAL_AVOID_SIDE_EFFECTS
10283       && ada_is_array_descriptor_type (ada_check_typedef
10284                                        (value_type (array))))
10285     return empty_array (ada_type_of_array (array, 0), low_bound,
10286                         high_bound);
10287
10288   array = ada_coerce_to_simple_array_ptr (array);
10289
10290   /* If we have more than one level of pointer indirection,
10291      dereference the value until we get only one level.  */
10292   while (value_type (array)->code () == TYPE_CODE_PTR
10293          && (TYPE_TARGET_TYPE (value_type (array))->code ()
10294              == TYPE_CODE_PTR))
10295     array = value_ind (array);
10296
10297   /* Make sure we really do have an array type before going further,
10298      to avoid a SEGV when trying to get the index type or the target
10299      type later down the road if the debug info generated by
10300      the compiler is incorrect or incomplete.  */
10301   if (!ada_is_simple_array_type (value_type (array)))
10302     error (_("cannot take slice of non-array"));
10303
10304   if (ada_check_typedef (value_type (array))->code ()
10305       == TYPE_CODE_PTR)
10306     {
10307       struct type *type0 = ada_check_typedef (value_type (array));
10308
10309       if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10310         return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
10311       else
10312         {
10313           struct type *arr_type0 =
10314             to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
10315
10316           return ada_value_slice_from_ptr (array, arr_type0,
10317                                            longest_to_int (low_bound),
10318                                            longest_to_int (high_bound));
10319         }
10320     }
10321   else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10322     return array;
10323   else if (high_bound < low_bound)
10324     return empty_array (value_type (array), low_bound, high_bound);
10325   else
10326     return ada_value_slice (array, longest_to_int (low_bound),
10327                             longest_to_int (high_bound));
10328 }
10329
10330 /* A helper function for BINOP_IN_BOUNDS.  */
10331
10332 value *
10333 ada_binop_in_bounds (struct expression *exp, enum noside noside,
10334                      struct value *arg1, struct value *arg2, int n)
10335 {
10336   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10337     {
10338       struct type *type = language_bool_type (exp->language_defn,
10339                                               exp->gdbarch);
10340       return value_zero (type, not_lval);
10341     }
10342
10343   struct type *type = ada_index_type (value_type (arg2), n, "range");
10344   if (!type)
10345     type = value_type (arg1);
10346
10347   value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
10348   arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
10349
10350   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10351   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10352   type = language_bool_type (exp->language_defn, exp->gdbarch);
10353   return value_from_longest (type,
10354                              (value_less (arg1, arg3)
10355                               || value_equal (arg1, arg3))
10356                              && (value_less (arg2, arg1)
10357                                  || value_equal (arg2, arg1)));
10358 }
10359
10360 /* A helper function for some attribute operations.  */
10361
10362 static value *
10363 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
10364               struct value *arg1, struct type *type_arg, int tem)
10365 {
10366   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10367     {
10368       if (type_arg == NULL)
10369         type_arg = value_type (arg1);
10370
10371       if (ada_is_constrained_packed_array_type (type_arg))
10372         type_arg = decode_constrained_packed_array_type (type_arg);
10373
10374       if (!discrete_type_p (type_arg))
10375         {
10376           switch (op)
10377             {
10378             default:          /* Should never happen.  */
10379               error (_("unexpected attribute encountered"));
10380             case OP_ATR_FIRST:
10381             case OP_ATR_LAST:
10382               type_arg = ada_index_type (type_arg, tem,
10383                                          ada_attribute_name (op));
10384               break;
10385             case OP_ATR_LENGTH:
10386               type_arg = builtin_type (exp->gdbarch)->builtin_int;
10387               break;
10388             }
10389         }
10390
10391       return value_zero (type_arg, not_lval);
10392     }
10393   else if (type_arg == NULL)
10394     {
10395       arg1 = ada_coerce_ref (arg1);
10396
10397       if (ada_is_constrained_packed_array_type (value_type (arg1)))
10398         arg1 = ada_coerce_to_simple_array (arg1);
10399
10400       struct type *type;
10401       if (op == OP_ATR_LENGTH)
10402         type = builtin_type (exp->gdbarch)->builtin_int;
10403       else
10404         {
10405           type = ada_index_type (value_type (arg1), tem,
10406                                  ada_attribute_name (op));
10407           if (type == NULL)
10408             type = builtin_type (exp->gdbarch)->builtin_int;
10409         }
10410
10411       switch (op)
10412         {
10413         default:          /* Should never happen.  */
10414           error (_("unexpected attribute encountered"));
10415         case OP_ATR_FIRST:
10416           return value_from_longest
10417             (type, ada_array_bound (arg1, tem, 0));
10418         case OP_ATR_LAST:
10419           return value_from_longest
10420             (type, ada_array_bound (arg1, tem, 1));
10421         case OP_ATR_LENGTH:
10422           return value_from_longest
10423             (type, ada_array_length (arg1, tem));
10424         }
10425     }
10426   else if (discrete_type_p (type_arg))
10427     {
10428       struct type *range_type;
10429       const char *name = ada_type_name (type_arg);
10430
10431       range_type = NULL;
10432       if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10433         range_type = to_fixed_range_type (type_arg, NULL);
10434       if (range_type == NULL)
10435         range_type = type_arg;
10436       switch (op)
10437         {
10438         default:
10439           error (_("unexpected attribute encountered"));
10440         case OP_ATR_FIRST:
10441           return value_from_longest 
10442             (range_type, ada_discrete_type_low_bound (range_type));
10443         case OP_ATR_LAST:
10444           return value_from_longest
10445             (range_type, ada_discrete_type_high_bound (range_type));
10446         case OP_ATR_LENGTH:
10447           error (_("the 'length attribute applies only to array types"));
10448         }
10449     }
10450   else if (type_arg->code () == TYPE_CODE_FLT)
10451     error (_("unimplemented type attribute"));
10452   else
10453     {
10454       LONGEST low, high;
10455
10456       if (ada_is_constrained_packed_array_type (type_arg))
10457         type_arg = decode_constrained_packed_array_type (type_arg);
10458
10459       struct type *type;
10460       if (op == OP_ATR_LENGTH)
10461         type = builtin_type (exp->gdbarch)->builtin_int;
10462       else
10463         {
10464           type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10465           if (type == NULL)
10466             type = builtin_type (exp->gdbarch)->builtin_int;
10467         }
10468
10469       switch (op)
10470         {
10471         default:
10472           error (_("unexpected attribute encountered"));
10473         case OP_ATR_FIRST:
10474           low = ada_array_bound_from_type (type_arg, tem, 0);
10475           return value_from_longest (type, low);
10476         case OP_ATR_LAST:
10477           high = ada_array_bound_from_type (type_arg, tem, 1);
10478           return value_from_longest (type, high);
10479         case OP_ATR_LENGTH:
10480           low = ada_array_bound_from_type (type_arg, tem, 0);
10481           high = ada_array_bound_from_type (type_arg, tem, 1);
10482           return value_from_longest (type, high - low + 1);
10483         }
10484     }
10485 }
10486
10487 /* A helper function for OP_ATR_MIN and OP_ATR_MAX.  */
10488
10489 struct value *
10490 ada_binop_minmax (struct type *expect_type,
10491                   struct expression *exp,
10492                   enum noside noside, enum exp_opcode op,
10493                   struct value *arg1, struct value *arg2)
10494 {
10495   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10496     return value_zero (value_type (arg1), not_lval);
10497   else
10498     {
10499       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10500       return value_binop (arg1, arg2, op);
10501     }
10502 }
10503
10504 /* A helper function for BINOP_EXP.  */
10505
10506 struct value *
10507 ada_binop_exp (struct type *expect_type,
10508                struct expression *exp,
10509                enum noside noside, enum exp_opcode op,
10510                struct value *arg1, struct value *arg2)
10511 {
10512   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10513     return value_zero (value_type (arg1), not_lval);
10514   else
10515     {
10516       /* For integer exponentiation operations,
10517          only promote the first argument.  */
10518       if (is_integral_type (value_type (arg2)))
10519         unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10520       else
10521         binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10522
10523       return value_binop (arg1, arg2, op);
10524     }
10525 }
10526
10527 namespace expr
10528 {
10529
10530 /* See ada-exp.h.  */
10531
10532 operation_up
10533 ada_resolvable::replace (operation_up &&owner,
10534                          struct expression *exp,
10535                          bool deprocedure_p,
10536                          bool parse_completion,
10537                          innermost_block_tracker *tracker,
10538                          struct type *context_type)
10539 {
10540   if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10541     return (make_operation<ada_funcall_operation>
10542             (std::move (owner),
10543              std::vector<operation_up> ()));
10544   return std::move (owner);
10545 }
10546
10547 /* Convert the character literal whose value would be VAL to the
10548    appropriate value of type TYPE, if there is a translation.
10549    Otherwise return VAL.  Hence, in an enumeration type ('A', 'B'),
10550    the literal 'A' (VAL == 65), returns 0.  */
10551
10552 static LONGEST
10553 convert_char_literal (struct type *type, LONGEST val)
10554 {
10555   char name[12];
10556   int f;
10557
10558   if (type == NULL)
10559     return val;
10560   type = check_typedef (type);
10561   if (type->code () != TYPE_CODE_ENUM)
10562     return val;
10563
10564   if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10565     xsnprintf (name, sizeof (name), "Q%c", (int) val);
10566   else if (val >= 0 && val < 256)
10567     xsnprintf (name, sizeof (name), "QU%02x", (unsigned) val);
10568   else if (val >= 0 && val < 0x10000)
10569     xsnprintf (name, sizeof (name), "QW%04x", (unsigned) val);
10570   else
10571     xsnprintf (name, sizeof (name), "QWW%08lx", (unsigned long) val);
10572   size_t len = strlen (name);
10573   for (f = 0; f < type->num_fields (); f += 1)
10574     {
10575       /* Check the suffix because an enum constant in a package will
10576          have a name like "pkg__QUxx".  This is safe enough because we
10577          already have the correct type, and because mangling means
10578          there can't be clashes.  */
10579       const char *ename = type->field (f).name ();
10580       size_t elen = strlen (ename);
10581
10582       if (elen >= len && strcmp (name, ename + elen - len) == 0)
10583         return type->field (f).loc_enumval ();
10584     }
10585   return val;
10586 }
10587
10588 value *
10589 ada_char_operation::evaluate (struct type *expect_type,
10590                               struct expression *exp,
10591                               enum noside noside)
10592 {
10593   value *result = long_const_operation::evaluate (expect_type, exp, noside);
10594   if (expect_type != nullptr)
10595     result = ada_value_cast (expect_type, result);
10596   return result;
10597 }
10598
10599 /* See ada-exp.h.  */
10600
10601 operation_up
10602 ada_char_operation::replace (operation_up &&owner,
10603                              struct expression *exp,
10604                              bool deprocedure_p,
10605                              bool parse_completion,
10606                              innermost_block_tracker *tracker,
10607                              struct type *context_type)
10608 {
10609   operation_up result = std::move (owner);
10610
10611   if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10612     {
10613       gdb_assert (result.get () == this);
10614       std::get<0> (m_storage) = context_type;
10615       std::get<1> (m_storage)
10616         = convert_char_literal (context_type, std::get<1> (m_storage));
10617     }
10618
10619   return result;
10620 }
10621
10622 value *
10623 ada_wrapped_operation::evaluate (struct type *expect_type,
10624                                  struct expression *exp,
10625                                  enum noside noside)
10626 {
10627   value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10628   if (noside == EVAL_NORMAL)
10629     result = unwrap_value (result);
10630
10631   /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10632      then we need to perform the conversion manually, because
10633      evaluate_subexp_standard doesn't do it.  This conversion is
10634      necessary in Ada because the different kinds of float/fixed
10635      types in Ada have different representations.
10636
10637      Similarly, we need to perform the conversion from OP_LONG
10638      ourselves.  */
10639   if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10640     result = ada_value_cast (expect_type, result);
10641
10642   return result;
10643 }
10644
10645 value *
10646 ada_string_operation::evaluate (struct type *expect_type,
10647                                 struct expression *exp,
10648                                 enum noside noside)
10649 {
10650   struct type *char_type;
10651   if (expect_type != nullptr && ada_is_string_type (expect_type))
10652     char_type = ada_array_element_type (expect_type, 1);
10653   else
10654     char_type = language_string_char_type (exp->language_defn, exp->gdbarch);
10655
10656   const std::string &str = std::get<0> (m_storage);
10657   const char *encoding;
10658   switch (TYPE_LENGTH (char_type))
10659     {
10660     case 1:
10661       {
10662         /* Simply copy over the data -- this isn't perhaps strictly
10663            correct according to the encodings, but it is gdb's
10664            historical behavior.  */
10665         struct type *stringtype
10666           = lookup_array_range_type (char_type, 1, str.length ());
10667         struct value *val = allocate_value (stringtype);
10668         memcpy (value_contents_raw (val).data (), str.c_str (),
10669                 str.length ());
10670         return val;
10671       }
10672
10673     case 2:
10674       if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10675         encoding = "UTF-16BE";
10676       else
10677         encoding = "UTF-16LE";
10678       break;
10679
10680     case 4:
10681       if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10682         encoding = "UTF-32BE";
10683       else
10684         encoding = "UTF-32LE";
10685       break;
10686
10687     default:
10688       error (_("unexpected character type size %s"),
10689              pulongest (TYPE_LENGTH (char_type)));
10690     }
10691
10692   auto_obstack converted;
10693   convert_between_encodings (host_charset (), encoding,
10694                              (const gdb_byte *) str.c_str (),
10695                              str.length (), 1,
10696                              &converted, translit_none);
10697
10698   struct type *stringtype
10699     = lookup_array_range_type (char_type, 1,
10700                                obstack_object_size (&converted)
10701                                / TYPE_LENGTH (char_type));
10702   struct value *val = allocate_value (stringtype);
10703   memcpy (value_contents_raw (val).data (),
10704           obstack_base (&converted),
10705           obstack_object_size (&converted));
10706   return val;
10707 }
10708
10709 value *
10710 ada_concat_operation::evaluate (struct type *expect_type,
10711                                 struct expression *exp,
10712                                 enum noside noside)
10713 {
10714   /* If one side is a literal, evaluate the other side first so that
10715      the expected type can be set properly.  */
10716   const operation_up &lhs_expr = std::get<0> (m_storage);
10717   const operation_up &rhs_expr = std::get<1> (m_storage);
10718
10719   value *lhs, *rhs;
10720   if (dynamic_cast<ada_string_operation *> (lhs_expr.get ()) != nullptr)
10721     {
10722       rhs = rhs_expr->evaluate (nullptr, exp, noside);
10723       lhs = lhs_expr->evaluate (value_type (rhs), exp, noside);
10724     }
10725   else if (dynamic_cast<ada_char_operation *> (lhs_expr.get ()) != nullptr)
10726     {
10727       rhs = rhs_expr->evaluate (nullptr, exp, noside);
10728       struct type *rhs_type = check_typedef (value_type (rhs));
10729       struct type *elt_type = nullptr;
10730       if (rhs_type->code () == TYPE_CODE_ARRAY)
10731         elt_type = TYPE_TARGET_TYPE (rhs_type);
10732       lhs = lhs_expr->evaluate (elt_type, exp, noside);
10733     }
10734   else if (dynamic_cast<ada_string_operation *> (rhs_expr.get ()) != nullptr)
10735     {
10736       lhs = lhs_expr->evaluate (nullptr, exp, noside);
10737       rhs = rhs_expr->evaluate (value_type (lhs), exp, noside);
10738     }
10739   else if (dynamic_cast<ada_char_operation *> (rhs_expr.get ()) != nullptr)
10740     {
10741       lhs = lhs_expr->evaluate (nullptr, exp, noside);
10742       struct type *lhs_type = check_typedef (value_type (lhs));
10743       struct type *elt_type = nullptr;
10744       if (lhs_type->code () == TYPE_CODE_ARRAY)
10745         elt_type = TYPE_TARGET_TYPE (lhs_type);
10746       rhs = rhs_expr->evaluate (elt_type, exp, noside);
10747     }
10748   else
10749     return concat_operation::evaluate (expect_type, exp, noside);
10750
10751   return value_concat (lhs, rhs);
10752 }
10753
10754 value *
10755 ada_qual_operation::evaluate (struct type *expect_type,
10756                               struct expression *exp,
10757                               enum noside noside)
10758 {
10759   struct type *type = std::get<1> (m_storage);
10760   return std::get<0> (m_storage)->evaluate (type, exp, noside);
10761 }
10762
10763 value *
10764 ada_ternop_range_operation::evaluate (struct type *expect_type,
10765                                       struct expression *exp,
10766                                       enum noside noside)
10767 {
10768   value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10769   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10770   value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10771   return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10772 }
10773
10774 value *
10775 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10776                                       struct expression *exp,
10777                                       enum noside noside)
10778 {
10779   value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10780   value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10781
10782   auto do_op = [=] (LONGEST x, LONGEST y)
10783     {
10784       if (std::get<0> (m_storage) == BINOP_ADD)
10785         return x + y;
10786       return x - y;
10787     };
10788
10789   if (value_type (arg1)->code () == TYPE_CODE_PTR)
10790     return (value_from_longest
10791             (value_type (arg1),
10792              do_op (value_as_long (arg1), value_as_long (arg2))));
10793   if (value_type (arg2)->code () == TYPE_CODE_PTR)
10794     return (value_from_longest
10795             (value_type (arg2),
10796              do_op (value_as_long (arg1), value_as_long (arg2))));
10797   /* Preserve the original type for use by the range case below.
10798      We cannot cast the result to a reference type, so if ARG1 is
10799      a reference type, find its underlying type.  */
10800   struct type *type = value_type (arg1);
10801   while (type->code () == TYPE_CODE_REF)
10802     type = TYPE_TARGET_TYPE (type);
10803   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10804   arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10805   /* We need to special-case the result with a range.
10806      This is done for the benefit of "ptype".  gdb's Ada support
10807      historically used the LHS to set the result type here, so
10808      preserve this behavior.  */
10809   if (type->code () == TYPE_CODE_RANGE)
10810     arg1 = value_cast (type, arg1);
10811   return arg1;
10812 }
10813
10814 value *
10815 ada_unop_atr_operation::evaluate (struct type *expect_type,
10816                                   struct expression *exp,
10817                                   enum noside noside)
10818 {
10819   struct type *type_arg = nullptr;
10820   value *val = nullptr;
10821
10822   if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10823     {
10824       value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10825                                                       EVAL_AVOID_SIDE_EFFECTS);
10826       type_arg = value_type (tem);
10827     }
10828   else
10829     val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10830
10831   return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10832                        val, type_arg, std::get<2> (m_storage));
10833 }
10834
10835 value *
10836 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10837                                                  struct expression *exp,
10838                                                  enum noside noside)
10839 {
10840   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10841     return value_zero (expect_type, not_lval);
10842
10843   const bound_minimal_symbol &b = std::get<0> (m_storage);
10844   value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10845
10846   val = ada_value_cast (expect_type, val);
10847
10848   /* Follow the Ada language semantics that do not allow taking
10849      an address of the result of a cast (view conversion in Ada).  */
10850   if (VALUE_LVAL (val) == lval_memory)
10851     {
10852       if (value_lazy (val))
10853         value_fetch_lazy (val);
10854       VALUE_LVAL (val) = not_lval;
10855     }
10856   return val;
10857 }
10858
10859 value *
10860 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10861                                             struct expression *exp,
10862                                             enum noside noside)
10863 {
10864   value *val = evaluate_var_value (noside,
10865                                    std::get<0> (m_storage).block,
10866                                    std::get<0> (m_storage).symbol);
10867
10868   val = ada_value_cast (expect_type, val);
10869
10870   /* Follow the Ada language semantics that do not allow taking
10871      an address of the result of a cast (view conversion in Ada).  */
10872   if (VALUE_LVAL (val) == lval_memory)
10873     {
10874       if (value_lazy (val))
10875         value_fetch_lazy (val);
10876       VALUE_LVAL (val) = not_lval;
10877     }
10878   return val;
10879 }
10880
10881 value *
10882 ada_var_value_operation::evaluate (struct type *expect_type,
10883                                    struct expression *exp,
10884                                    enum noside noside)
10885 {
10886   symbol *sym = std::get<0> (m_storage).symbol;
10887
10888   if (sym->domain () == UNDEF_DOMAIN)
10889     /* Only encountered when an unresolved symbol occurs in a
10890        context other than a function call, in which case, it is
10891        invalid.  */
10892     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10893            sym->print_name ());
10894
10895   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10896     {
10897       struct type *type = static_unwrap_type (sym->type ());
10898       /* Check to see if this is a tagged type.  We also need to handle
10899          the case where the type is a reference to a tagged type, but
10900          we have to be careful to exclude pointers to tagged types.
10901          The latter should be shown as usual (as a pointer), whereas
10902          a reference should mostly be transparent to the user.  */
10903       if (ada_is_tagged_type (type, 0)
10904           || (type->code () == TYPE_CODE_REF
10905               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10906         {
10907           /* Tagged types are a little special in the fact that the real
10908              type is dynamic and can only be determined by inspecting the
10909              object's tag.  This means that we need to get the object's
10910              value first (EVAL_NORMAL) and then extract the actual object
10911              type from its tag.
10912
10913              Note that we cannot skip the final step where we extract
10914              the object type from its tag, because the EVAL_NORMAL phase
10915              results in dynamic components being resolved into fixed ones.
10916              This can cause problems when trying to print the type
10917              description of tagged types whose parent has a dynamic size:
10918              We use the type name of the "_parent" component in order
10919              to print the name of the ancestor type in the type description.
10920              If that component had a dynamic size, the resolution into
10921              a fixed type would result in the loss of that type name,
10922              thus preventing us from printing the name of the ancestor
10923              type in the type description.  */
10924           value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10925
10926           if (type->code () != TYPE_CODE_REF)
10927             {
10928               struct type *actual_type;
10929
10930               actual_type = type_from_tag (ada_value_tag (arg1));
10931               if (actual_type == NULL)
10932                 /* If, for some reason, we were unable to determine
10933                    the actual type from the tag, then use the static
10934                    approximation that we just computed as a fallback.
10935                    This can happen if the debugging information is
10936                    incomplete, for instance.  */
10937                 actual_type = type;
10938               return value_zero (actual_type, not_lval);
10939             }
10940           else
10941             {
10942               /* In the case of a ref, ada_coerce_ref takes care
10943                  of determining the actual type.  But the evaluation
10944                  should return a ref as it should be valid to ask
10945                  for its address; so rebuild a ref after coerce.  */
10946               arg1 = ada_coerce_ref (arg1);
10947               return value_ref (arg1, TYPE_CODE_REF);
10948             }
10949         }
10950
10951       /* Records and unions for which GNAT encodings have been
10952          generated need to be statically fixed as well.
10953          Otherwise, non-static fixing produces a type where
10954          all dynamic properties are removed, which prevents "ptype"
10955          from being able to completely describe the type.
10956          For instance, a case statement in a variant record would be
10957          replaced by the relevant components based on the actual
10958          value of the discriminants.  */
10959       if ((type->code () == TYPE_CODE_STRUCT
10960            && dynamic_template_type (type) != NULL)
10961           || (type->code () == TYPE_CODE_UNION
10962               && ada_find_parallel_type (type, "___XVU") != NULL))
10963         return value_zero (to_static_fixed_type (type), not_lval);
10964     }
10965
10966   value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10967   return ada_to_fixed_value (arg1);
10968 }
10969
10970 bool
10971 ada_var_value_operation::resolve (struct expression *exp,
10972                                   bool deprocedure_p,
10973                                   bool parse_completion,
10974                                   innermost_block_tracker *tracker,
10975                                   struct type *context_type)
10976 {
10977   symbol *sym = std::get<0> (m_storage).symbol;
10978   if (sym->domain () == UNDEF_DOMAIN)
10979     {
10980       block_symbol resolved
10981         = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10982                                 context_type, parse_completion,
10983                                 deprocedure_p, tracker);
10984       std::get<0> (m_storage) = resolved;
10985     }
10986
10987   if (deprocedure_p
10988       && (std::get<0> (m_storage).symbol->type ()->code ()
10989           == TYPE_CODE_FUNC))
10990     return true;
10991
10992   return false;
10993 }
10994
10995 value *
10996 ada_atr_val_operation::evaluate (struct type *expect_type,
10997                                  struct expression *exp,
10998                                  enum noside noside)
10999 {
11000   value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
11001   return ada_val_atr (noside, std::get<0> (m_storage), arg);
11002 }
11003
11004 value *
11005 ada_unop_ind_operation::evaluate (struct type *expect_type,
11006                                   struct expression *exp,
11007                                   enum noside noside)
11008 {
11009   value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
11010
11011   struct type *type = ada_check_typedef (value_type (arg1));
11012   if (noside == EVAL_AVOID_SIDE_EFFECTS)
11013     {
11014       if (ada_is_array_descriptor_type (type))
11015         /* GDB allows dereferencing GNAT array descriptors.  */
11016         {
11017           struct type *arrType = ada_type_of_array (arg1, 0);
11018
11019           if (arrType == NULL)
11020             error (_("Attempt to dereference null array pointer."));
11021           return value_at_lazy (arrType, 0);
11022         }
11023       else if (type->code () == TYPE_CODE_PTR
11024                || type->code () == TYPE_CODE_REF
11025                /* In C you can dereference an array to get the 1st elt.  */
11026                || type->code () == TYPE_CODE_ARRAY)
11027         {
11028           /* As mentioned in the OP_VAR_VALUE case, tagged types can
11029              only be determined by inspecting the object's tag.
11030              This means that we need to evaluate completely the
11031              expression in order to get its type.  */
11032
11033           if ((type->code () == TYPE_CODE_REF
11034                || type->code () == TYPE_CODE_PTR)
11035               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11036             {
11037               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11038                                                         EVAL_NORMAL);
11039               type = value_type (ada_value_ind (arg1));
11040             }
11041           else
11042             {
11043               type = to_static_fixed_type
11044                 (ada_aligned_type
11045                  (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11046             }
11047           return value_zero (type, lval_memory);
11048         }
11049       else if (type->code () == TYPE_CODE_INT)
11050         {
11051           /* GDB allows dereferencing an int.  */
11052           if (expect_type == NULL)
11053             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11054                                lval_memory);
11055           else
11056             {
11057               expect_type =
11058                 to_static_fixed_type (ada_aligned_type (expect_type));
11059               return value_zero (expect_type, lval_memory);
11060             }
11061         }
11062       else
11063         error (_("Attempt to take contents of a non-pointer value."));
11064     }
11065   arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
11066   type = ada_check_typedef (value_type (arg1));
11067
11068   if (type->code () == TYPE_CODE_INT)
11069     /* GDB allows dereferencing an int.  If we were given
11070        the expect_type, then use that as the target type.
11071        Otherwise, assume that the target type is an int.  */
11072     {
11073       if (expect_type != NULL)
11074         return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11075                                           arg1));
11076       else
11077         return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11078                               (CORE_ADDR) value_as_address (arg1));
11079     }
11080
11081   if (ada_is_array_descriptor_type (type))
11082     /* GDB allows dereferencing GNAT array descriptors.  */
11083     return ada_coerce_to_simple_array (arg1);
11084   else
11085     return ada_value_ind (arg1);
11086 }
11087
11088 value *
11089 ada_structop_operation::evaluate (struct type *expect_type,
11090                                   struct expression *exp,
11091                                   enum noside noside)
11092 {
11093   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
11094   const char *str = std::get<1> (m_storage).c_str ();
11095   if (noside == EVAL_AVOID_SIDE_EFFECTS)
11096     {
11097       struct type *type;
11098       struct type *type1 = value_type (arg1);
11099
11100       if (ada_is_tagged_type (type1, 1))
11101         {
11102           type = ada_lookup_struct_elt_type (type1, str, 1, 1);
11103
11104           /* If the field is not found, check if it exists in the
11105              extension of this object's type. This means that we
11106              need to evaluate completely the expression.  */
11107
11108           if (type == NULL)
11109             {
11110               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11111                                                         EVAL_NORMAL);
11112               arg1 = ada_value_struct_elt (arg1, str, 0);
11113               arg1 = unwrap_value (arg1);
11114               type = value_type (ada_to_fixed_value (arg1));
11115             }
11116         }
11117       else
11118         type = ada_lookup_struct_elt_type (type1, str, 1, 0);
11119
11120       return value_zero (ada_aligned_type (type), lval_memory);
11121     }
11122   else
11123     {
11124       arg1 = ada_value_struct_elt (arg1, str, 0);
11125       arg1 = unwrap_value (arg1);
11126       return ada_to_fixed_value (arg1);
11127     }
11128 }
11129
11130 value *
11131 ada_funcall_operation::evaluate (struct type *expect_type,
11132                                  struct expression *exp,
11133                                  enum noside noside)
11134 {
11135   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11136   int nargs = args_up.size ();
11137   std::vector<value *> argvec (nargs);
11138   operation_up &callee_op = std::get<0> (m_storage);
11139
11140   ada_var_value_operation *avv
11141     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11142   if (avv != nullptr
11143       && avv->get_symbol ()->domain () == UNDEF_DOMAIN)
11144     error (_("Unexpected unresolved symbol, %s, during evaluation"),
11145            avv->get_symbol ()->print_name ());
11146
11147   value *callee = callee_op->evaluate (nullptr, exp, noside);
11148   for (int i = 0; i < args_up.size (); ++i)
11149     argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
11150
11151   if (ada_is_constrained_packed_array_type
11152       (desc_base_type (value_type (callee))))
11153     callee = ada_coerce_to_simple_array (callee);
11154   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11155            && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
11156     /* This is a packed array that has already been fixed, and
11157        therefore already coerced to a simple array.  Nothing further
11158        to do.  */
11159     ;
11160   else if (value_type (callee)->code () == TYPE_CODE_REF)
11161     {
11162       /* Make sure we dereference references so that all the code below
11163          feels like it's really handling the referenced value.  Wrapping
11164          types (for alignment) may be there, so make sure we strip them as
11165          well.  */
11166       callee = ada_to_fixed_value (coerce_ref (callee));
11167     }
11168   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11169            && VALUE_LVAL (callee) == lval_memory)
11170     callee = value_addr (callee);
11171
11172   struct type *type = ada_check_typedef (value_type (callee));
11173
11174   /* Ada allows us to implicitly dereference arrays when subscripting
11175      them.  So, if this is an array typedef (encoding use for array
11176      access types encoded as fat pointers), strip it now.  */
11177   if (type->code () == TYPE_CODE_TYPEDEF)
11178     type = ada_typedef_target_type (type);
11179
11180   if (type->code () == TYPE_CODE_PTR)
11181     {
11182       switch (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ())
11183         {
11184         case TYPE_CODE_FUNC:
11185           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
11186           break;
11187         case TYPE_CODE_ARRAY:
11188           break;
11189         case TYPE_CODE_STRUCT:
11190           if (noside != EVAL_AVOID_SIDE_EFFECTS)
11191             callee = ada_value_ind (callee);
11192           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
11193           break;
11194         default:
11195           error (_("cannot subscript or call something of type `%s'"),
11196                  ada_type_name (value_type (callee)));
11197           break;
11198         }
11199     }
11200
11201   switch (type->code ())
11202     {
11203     case TYPE_CODE_FUNC:
11204       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11205         {
11206           if (TYPE_TARGET_TYPE (type) == NULL)
11207             error_call_unknown_return_type (NULL);
11208           return allocate_value (TYPE_TARGET_TYPE (type));
11209         }
11210       return call_function_by_hand (callee, NULL, argvec);
11211     case TYPE_CODE_INTERNAL_FUNCTION:
11212       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11213         /* We don't know anything about what the internal
11214            function might return, but we have to return
11215            something.  */
11216         return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11217                            not_lval);
11218       else
11219         return call_internal_function (exp->gdbarch, exp->language_defn,
11220                                        callee, nargs,
11221                                        argvec.data ());
11222
11223     case TYPE_CODE_STRUCT:
11224       {
11225         int arity;
11226
11227         arity = ada_array_arity (type);
11228         type = ada_array_element_type (type, nargs);
11229         if (type == NULL)
11230           error (_("cannot subscript or call a record"));
11231         if (arity != nargs)
11232           error (_("wrong number of subscripts; expecting %d"), arity);
11233         if (noside == EVAL_AVOID_SIDE_EFFECTS)
11234           return value_zero (ada_aligned_type (type), lval_memory);
11235         return
11236           unwrap_value (ada_value_subscript
11237                         (callee, nargs, argvec.data ()));
11238       }
11239     case TYPE_CODE_ARRAY:
11240       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11241         {
11242           type = ada_array_element_type (type, nargs);
11243           if (type == NULL)
11244             error (_("element type of array unknown"));
11245           else
11246             return value_zero (ada_aligned_type (type), lval_memory);
11247         }
11248       return
11249         unwrap_value (ada_value_subscript
11250                       (ada_coerce_to_simple_array (callee),
11251                        nargs, argvec.data ()));
11252     case TYPE_CODE_PTR:     /* Pointer to array */
11253       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11254         {
11255           type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
11256           type = ada_array_element_type (type, nargs);
11257           if (type == NULL)
11258             error (_("element type of array unknown"));
11259           else
11260             return value_zero (ada_aligned_type (type), lval_memory);
11261         }
11262       return
11263         unwrap_value (ada_value_ptr_subscript (callee, nargs,
11264                                                argvec.data ()));
11265
11266     default:
11267       error (_("Attempt to index or call something other than an "
11268                "array or function"));
11269     }
11270 }
11271
11272 bool
11273 ada_funcall_operation::resolve (struct expression *exp,
11274                                 bool deprocedure_p,
11275                                 bool parse_completion,
11276                                 innermost_block_tracker *tracker,
11277                                 struct type *context_type)
11278 {
11279   operation_up &callee_op = std::get<0> (m_storage);
11280
11281   ada_var_value_operation *avv
11282     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11283   if (avv == nullptr)
11284     return false;
11285
11286   symbol *sym = avv->get_symbol ();
11287   if (sym->domain () != UNDEF_DOMAIN)
11288     return false;
11289
11290   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11291   int nargs = args_up.size ();
11292   std::vector<value *> argvec (nargs);
11293
11294   for (int i = 0; i < args_up.size (); ++i)
11295     argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
11296
11297   const block *block = avv->get_block ();
11298   block_symbol resolved
11299     = ada_resolve_funcall (sym, block,
11300                            context_type, parse_completion,
11301                            nargs, argvec.data (),
11302                            tracker);
11303
11304   std::get<0> (m_storage)
11305     = make_operation<ada_var_value_operation> (resolved);
11306   return false;
11307 }
11308
11309 bool
11310 ada_ternop_slice_operation::resolve (struct expression *exp,
11311                                      bool deprocedure_p,
11312                                      bool parse_completion,
11313                                      innermost_block_tracker *tracker,
11314                                      struct type *context_type)
11315 {
11316   /* Historically this check was done during resolution, so we
11317      continue that here.  */
11318   value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
11319                                                 EVAL_AVOID_SIDE_EFFECTS);
11320   if (ada_is_any_packed_array_type (value_type (v)))
11321     error (_("cannot slice a packed array"));
11322   return false;
11323 }
11324
11325 }
11326
11327 \f
11328
11329 /* Return non-zero iff TYPE represents a System.Address type.  */
11330
11331 int
11332 ada_is_system_address_type (struct type *type)
11333 {
11334   return (type->name () && strcmp (type->name (), "system__address") == 0);
11335 }
11336
11337 \f
11338
11339                                 /* Range types */
11340
11341 /* Scan STR beginning at position K for a discriminant name, and
11342    return the value of that discriminant field of DVAL in *PX.  If
11343    PNEW_K is not null, put the position of the character beyond the
11344    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
11345    not alter *PX and *PNEW_K if unsuccessful.  */
11346
11347 static int
11348 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11349                     int *pnew_k)
11350 {
11351   static std::string storage;
11352   const char *pstart, *pend, *bound;
11353   struct value *bound_val;
11354
11355   if (dval == NULL || str == NULL || str[k] == '\0')
11356     return 0;
11357
11358   pstart = str + k;
11359   pend = strstr (pstart, "__");
11360   if (pend == NULL)
11361     {
11362       bound = pstart;
11363       k += strlen (bound);
11364     }
11365   else
11366     {
11367       int len = pend - pstart;
11368
11369       /* Strip __ and beyond.  */
11370       storage = std::string (pstart, len);
11371       bound = storage.c_str ();
11372       k = pend - str;
11373     }
11374
11375   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11376   if (bound_val == NULL)
11377     return 0;
11378
11379   *px = value_as_long (bound_val);
11380   if (pnew_k != NULL)
11381     *pnew_k = k;
11382   return 1;
11383 }
11384
11385 /* Value of variable named NAME.  Only exact matches are considered.
11386    If no such variable found, then if ERR_MSG is null, returns 0, and
11387    otherwise causes an error with message ERR_MSG.  */
11388
11389 static struct value *
11390 get_var_value (const char *name, const char *err_msg)
11391 {
11392   std::string quoted_name = add_angle_brackets (name);
11393
11394   lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
11395
11396   std::vector<struct block_symbol> syms
11397     = ada_lookup_symbol_list_worker (lookup_name,
11398                                      get_selected_block (0),
11399                                      VAR_DOMAIN, 1);
11400
11401   if (syms.size () != 1)
11402     {
11403       if (err_msg == NULL)
11404         return 0;
11405       else
11406         error (("%s"), err_msg);
11407     }
11408
11409   return value_of_variable (syms[0].symbol, syms[0].block);
11410 }
11411
11412 /* Value of integer variable named NAME in the current environment.
11413    If no such variable is found, returns false.  Otherwise, sets VALUE
11414    to the variable's value and returns true.  */
11415
11416 bool
11417 get_int_var_value (const char *name, LONGEST &value)
11418 {
11419   struct value *var_val = get_var_value (name, 0);
11420
11421   if (var_val == 0)
11422     return false;
11423
11424   value = value_as_long (var_val);
11425   return true;
11426 }
11427
11428
11429 /* Return a range type whose base type is that of the range type named
11430    NAME in the current environment, and whose bounds are calculated
11431    from NAME according to the GNAT range encoding conventions.
11432    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
11433    corresponding range type from debug information; fall back to using it
11434    if symbol lookup fails.  If a new type must be created, allocate it
11435    like ORIG_TYPE was.  The bounds information, in general, is encoded
11436    in NAME, the base type given in the named range type.  */
11437
11438 static struct type *
11439 to_fixed_range_type (struct type *raw_type, struct value *dval)
11440 {
11441   const char *name;
11442   struct type *base_type;
11443   const char *subtype_info;
11444
11445   gdb_assert (raw_type != NULL);
11446   gdb_assert (raw_type->name () != NULL);
11447
11448   if (raw_type->code () == TYPE_CODE_RANGE)
11449     base_type = TYPE_TARGET_TYPE (raw_type);
11450   else
11451     base_type = raw_type;
11452
11453   name = raw_type->name ();
11454   subtype_info = strstr (name, "___XD");
11455   if (subtype_info == NULL)
11456     {
11457       LONGEST L = ada_discrete_type_low_bound (raw_type);
11458       LONGEST U = ada_discrete_type_high_bound (raw_type);
11459
11460       if (L < INT_MIN || U > INT_MAX)
11461         return raw_type;
11462       else
11463         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11464                                          L, U);
11465     }
11466   else
11467     {
11468       int prefix_len = subtype_info - name;
11469       LONGEST L, U;
11470       struct type *type;
11471       const char *bounds_str;
11472       int n;
11473
11474       subtype_info += 5;
11475       bounds_str = strchr (subtype_info, '_');
11476       n = 1;
11477
11478       if (*subtype_info == 'L')
11479         {
11480           if (!ada_scan_number (bounds_str, n, &L, &n)
11481               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11482             return raw_type;
11483           if (bounds_str[n] == '_')
11484             n += 2;
11485           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
11486             n += 1;
11487           subtype_info += 1;
11488         }
11489       else
11490         {
11491           std::string name_buf = std::string (name, prefix_len) + "___L";
11492           if (!get_int_var_value (name_buf.c_str (), L))
11493             {
11494               lim_warning (_("Unknown lower bound, using 1."));
11495               L = 1;
11496             }
11497         }
11498
11499       if (*subtype_info == 'U')
11500         {
11501           if (!ada_scan_number (bounds_str, n, &U, &n)
11502               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11503             return raw_type;
11504         }
11505       else
11506         {
11507           std::string name_buf = std::string (name, prefix_len) + "___U";
11508           if (!get_int_var_value (name_buf.c_str (), U))
11509             {
11510               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11511               U = L;
11512             }
11513         }
11514
11515       type = create_static_range_type (alloc_type_copy (raw_type),
11516                                        base_type, L, U);
11517       /* create_static_range_type alters the resulting type's length
11518          to match the size of the base_type, which is not what we want.
11519          Set it back to the original range type's length.  */
11520       TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11521       type->set_name (name);
11522       return type;
11523     }
11524 }
11525
11526 /* True iff NAME is the name of a range type.  */
11527
11528 int
11529 ada_is_range_type_name (const char *name)
11530 {
11531   return (name != NULL && strstr (name, "___XD"));
11532 }
11533 \f
11534
11535                                 /* Modular types */
11536
11537 /* True iff TYPE is an Ada modular type.  */
11538
11539 int
11540 ada_is_modular_type (struct type *type)
11541 {
11542   struct type *subranged_type = get_base_type (type);
11543
11544   return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11545           && subranged_type->code () == TYPE_CODE_INT
11546           && subranged_type->is_unsigned ());
11547 }
11548
11549 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
11550
11551 ULONGEST
11552 ada_modulus (struct type *type)
11553 {
11554   const dynamic_prop &high = type->bounds ()->high;
11555
11556   if (high.kind () == PROP_CONST)
11557     return (ULONGEST) high.const_val () + 1;
11558
11559   /* If TYPE is unresolved, the high bound might be a location list.  Return
11560      0, for lack of a better value to return.  */
11561   return 0;
11562 }
11563 \f
11564
11565 /* Ada exception catchpoint support:
11566    ---------------------------------
11567
11568    We support 3 kinds of exception catchpoints:
11569      . catchpoints on Ada exceptions
11570      . catchpoints on unhandled Ada exceptions
11571      . catchpoints on failed assertions
11572
11573    Exceptions raised during failed assertions, or unhandled exceptions
11574    could perfectly be caught with the general catchpoint on Ada exceptions.
11575    However, we can easily differentiate these two special cases, and having
11576    the option to distinguish these two cases from the rest can be useful
11577    to zero-in on certain situations.
11578
11579    Exception catchpoints are a specialized form of breakpoint,
11580    since they rely on inserting breakpoints inside known routines
11581    of the GNAT runtime.  The implementation therefore uses a standard
11582    breakpoint structure of the BP_BREAKPOINT type, but with its own set
11583    of breakpoint_ops.
11584
11585    Support in the runtime for exception catchpoints have been changed
11586    a few times already, and these changes affect the implementation
11587    of these catchpoints.  In order to be able to support several
11588    variants of the runtime, we use a sniffer that will determine
11589    the runtime variant used by the program being debugged.  */
11590
11591 /* Ada's standard exceptions.
11592
11593    The Ada 83 standard also defined Numeric_Error.  But there so many
11594    situations where it was unclear from the Ada 83 Reference Manual
11595    (RM) whether Constraint_Error or Numeric_Error should be raised,
11596    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11597    Interpretation saying that anytime the RM says that Numeric_Error
11598    should be raised, the implementation may raise Constraint_Error.
11599    Ada 95 went one step further and pretty much removed Numeric_Error
11600    from the list of standard exceptions (it made it a renaming of
11601    Constraint_Error, to help preserve compatibility when compiling
11602    an Ada83 compiler). As such, we do not include Numeric_Error from
11603    this list of standard exceptions.  */
11604
11605 static const char * const standard_exc[] = {
11606   "constraint_error",
11607   "program_error",
11608   "storage_error",
11609   "tasking_error"
11610 };
11611
11612 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11613
11614 /* A structure that describes how to support exception catchpoints
11615    for a given executable.  */
11616
11617 struct exception_support_info
11618 {
11619    /* The name of the symbol to break on in order to insert
11620       a catchpoint on exceptions.  */
11621    const char *catch_exception_sym;
11622
11623    /* The name of the symbol to break on in order to insert
11624       a catchpoint on unhandled exceptions.  */
11625    const char *catch_exception_unhandled_sym;
11626
11627    /* The name of the symbol to break on in order to insert
11628       a catchpoint on failed assertions.  */
11629    const char *catch_assert_sym;
11630
11631    /* The name of the symbol to break on in order to insert
11632       a catchpoint on exception handling.  */
11633    const char *catch_handlers_sym;
11634
11635    /* Assuming that the inferior just triggered an unhandled exception
11636       catchpoint, this function is responsible for returning the address
11637       in inferior memory where the name of that exception is stored.
11638       Return zero if the address could not be computed.  */
11639    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11640 };
11641
11642 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11643 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11644
11645 /* The following exception support info structure describes how to
11646    implement exception catchpoints with the latest version of the
11647    Ada runtime (as of 2019-08-??).  */
11648
11649 static const struct exception_support_info default_exception_support_info =
11650 {
11651   "__gnat_debug_raise_exception", /* catch_exception_sym */
11652   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11653   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11654   "__gnat_begin_handler_v1", /* catch_handlers_sym */
11655   ada_unhandled_exception_name_addr
11656 };
11657
11658 /* The following exception support info structure describes how to
11659    implement exception catchpoints with an earlier version of the
11660    Ada runtime (as of 2007-03-06) using v0 of the EH ABI.  */
11661
11662 static const struct exception_support_info exception_support_info_v0 =
11663 {
11664   "__gnat_debug_raise_exception", /* catch_exception_sym */
11665   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11666   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11667   "__gnat_begin_handler", /* catch_handlers_sym */
11668   ada_unhandled_exception_name_addr
11669 };
11670
11671 /* The following exception support info structure describes how to
11672    implement exception catchpoints with a slightly older version
11673    of the Ada runtime.  */
11674
11675 static const struct exception_support_info exception_support_info_fallback =
11676 {
11677   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11678   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11679   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
11680   "__gnat_begin_handler", /* catch_handlers_sym */
11681   ada_unhandled_exception_name_addr_from_raise
11682 };
11683
11684 /* Return nonzero if we can detect the exception support routines
11685    described in EINFO.
11686
11687    This function errors out if an abnormal situation is detected
11688    (for instance, if we find the exception support routines, but
11689    that support is found to be incomplete).  */
11690
11691 static int
11692 ada_has_this_exception_support (const struct exception_support_info *einfo)
11693 {
11694   struct symbol *sym;
11695
11696   /* The symbol we're looking up is provided by a unit in the GNAT runtime
11697      that should be compiled with debugging information.  As a result, we
11698      expect to find that symbol in the symtabs.  */
11699
11700   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11701   if (sym == NULL)
11702     {
11703       /* Perhaps we did not find our symbol because the Ada runtime was
11704          compiled without debugging info, or simply stripped of it.
11705          It happens on some GNU/Linux distributions for instance, where
11706          users have to install a separate debug package in order to get
11707          the runtime's debugging info.  In that situation, let the user
11708          know why we cannot insert an Ada exception catchpoint.
11709
11710          Note: Just for the purpose of inserting our Ada exception
11711          catchpoint, we could rely purely on the associated minimal symbol.
11712          But we would be operating in degraded mode anyway, since we are
11713          still lacking the debugging info needed later on to extract
11714          the name of the exception being raised (this name is printed in
11715          the catchpoint message, and is also used when trying to catch
11716          a specific exception).  We do not handle this case for now.  */
11717       struct bound_minimal_symbol msym
11718         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11719
11720       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11721         error (_("Your Ada runtime appears to be missing some debugging "
11722                  "information.\nCannot insert Ada exception catchpoint "
11723                  "in this configuration."));
11724
11725       return 0;
11726     }
11727
11728   /* Make sure that the symbol we found corresponds to a function.  */
11729
11730   if (sym->aclass () != LOC_BLOCK)
11731     {
11732       error (_("Symbol \"%s\" is not a function (class = %d)"),
11733              sym->linkage_name (), sym->aclass ());
11734       return 0;
11735     }
11736
11737   sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11738   if (sym == NULL)
11739     {
11740       struct bound_minimal_symbol msym
11741         = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11742
11743       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11744         error (_("Your Ada runtime appears to be missing some debugging "
11745                  "information.\nCannot insert Ada exception catchpoint "
11746                  "in this configuration."));
11747
11748       return 0;
11749     }
11750
11751   /* Make sure that the symbol we found corresponds to a function.  */
11752
11753   if (sym->aclass () != LOC_BLOCK)
11754     {
11755       error (_("Symbol \"%s\" is not a function (class = %d)"),
11756              sym->linkage_name (), sym->aclass ());
11757       return 0;
11758     }
11759
11760   return 1;
11761 }
11762
11763 /* Inspect the Ada runtime and determine which exception info structure
11764    should be used to provide support for exception catchpoints.
11765
11766    This function will always set the per-inferior exception_info,
11767    or raise an error.  */
11768
11769 static void
11770 ada_exception_support_info_sniffer (void)
11771 {
11772   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11773
11774   /* If the exception info is already known, then no need to recompute it.  */
11775   if (data->exception_info != NULL)
11776     return;
11777
11778   /* Check the latest (default) exception support info.  */
11779   if (ada_has_this_exception_support (&default_exception_support_info))
11780     {
11781       data->exception_info = &default_exception_support_info;
11782       return;
11783     }
11784
11785   /* Try the v0 exception suport info.  */
11786   if (ada_has_this_exception_support (&exception_support_info_v0))
11787     {
11788       data->exception_info = &exception_support_info_v0;
11789       return;
11790     }
11791
11792   /* Try our fallback exception suport info.  */
11793   if (ada_has_this_exception_support (&exception_support_info_fallback))
11794     {
11795       data->exception_info = &exception_support_info_fallback;
11796       return;
11797     }
11798
11799   /* Sometimes, it is normal for us to not be able to find the routine
11800      we are looking for.  This happens when the program is linked with
11801      the shared version of the GNAT runtime, and the program has not been
11802      started yet.  Inform the user of these two possible causes if
11803      applicable.  */
11804
11805   if (ada_update_initial_language (language_unknown) != language_ada)
11806     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
11807
11808   /* If the symbol does not exist, then check that the program is
11809      already started, to make sure that shared libraries have been
11810      loaded.  If it is not started, this may mean that the symbol is
11811      in a shared library.  */
11812
11813   if (inferior_ptid.pid () == 0)
11814     error (_("Unable to insert catchpoint. Try to start the program first."));
11815
11816   /* At this point, we know that we are debugging an Ada program and
11817      that the inferior has been started, but we still are not able to
11818      find the run-time symbols.  That can mean that we are in
11819      configurable run time mode, or that a-except as been optimized
11820      out by the linker...  In any case, at this point it is not worth
11821      supporting this feature.  */
11822
11823   error (_("Cannot insert Ada exception catchpoints in this configuration."));
11824 }
11825
11826 /* True iff FRAME is very likely to be that of a function that is
11827    part of the runtime system.  This is all very heuristic, but is
11828    intended to be used as advice as to what frames are uninteresting
11829    to most users.  */
11830
11831 static int
11832 is_known_support_routine (struct frame_info *frame)
11833 {
11834   enum language func_lang;
11835   int i;
11836   const char *fullname;
11837
11838   /* If this code does not have any debugging information (no symtab),
11839      This cannot be any user code.  */
11840
11841   symtab_and_line sal = find_frame_sal (frame);
11842   if (sal.symtab == NULL)
11843     return 1;
11844
11845   /* If there is a symtab, but the associated source file cannot be
11846      located, then assume this is not user code:  Selecting a frame
11847      for which we cannot display the code would not be very helpful
11848      for the user.  This should also take care of case such as VxWorks
11849      where the kernel has some debugging info provided for a few units.  */
11850
11851   fullname = symtab_to_fullname (sal.symtab);
11852   if (access (fullname, R_OK) != 0)
11853     return 1;
11854
11855   /* Check the unit filename against the Ada runtime file naming.
11856      We also check the name of the objfile against the name of some
11857      known system libraries that sometimes come with debugging info
11858      too.  */
11859
11860   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11861     {
11862       re_comp (known_runtime_file_name_patterns[i]);
11863       if (re_exec (lbasename (sal.symtab->filename)))
11864         return 1;
11865       if (sal.symtab->objfile () != NULL
11866           && re_exec (objfile_name (sal.symtab->objfile ())))
11867         return 1;
11868     }
11869
11870   /* Check whether the function is a GNAT-generated entity.  */
11871
11872   gdb::unique_xmalloc_ptr<char> func_name
11873     = find_frame_funname (frame, &func_lang, NULL);
11874   if (func_name == NULL)
11875     return 1;
11876
11877   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11878     {
11879       re_comp (known_auxiliary_function_name_patterns[i]);
11880       if (re_exec (func_name.get ()))
11881         return 1;
11882     }
11883
11884   return 0;
11885 }
11886
11887 /* Find the first frame that contains debugging information and that is not
11888    part of the Ada run-time, starting from FI and moving upward.  */
11889
11890 void
11891 ada_find_printable_frame (struct frame_info *fi)
11892 {
11893   for (; fi != NULL; fi = get_prev_frame (fi))
11894     {
11895       if (!is_known_support_routine (fi))
11896         {
11897           select_frame (fi);
11898           break;
11899         }
11900     }
11901
11902 }
11903
11904 /* Assuming that the inferior just triggered an unhandled exception
11905    catchpoint, return the address in inferior memory where the name
11906    of the exception is stored.
11907    
11908    Return zero if the address could not be computed.  */
11909
11910 static CORE_ADDR
11911 ada_unhandled_exception_name_addr (void)
11912 {
11913   return parse_and_eval_address ("e.full_name");
11914 }
11915
11916 /* Same as ada_unhandled_exception_name_addr, except that this function
11917    should be used when the inferior uses an older version of the runtime,
11918    where the exception name needs to be extracted from a specific frame
11919    several frames up in the callstack.  */
11920
11921 static CORE_ADDR
11922 ada_unhandled_exception_name_addr_from_raise (void)
11923 {
11924   int frame_level;
11925   struct frame_info *fi;
11926   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11927
11928   /* To determine the name of this exception, we need to select
11929      the frame corresponding to RAISE_SYM_NAME.  This frame is
11930      at least 3 levels up, so we simply skip the first 3 frames
11931      without checking the name of their associated function.  */
11932   fi = get_current_frame ();
11933   for (frame_level = 0; frame_level < 3; frame_level += 1)
11934     if (fi != NULL)
11935       fi = get_prev_frame (fi); 
11936
11937   while (fi != NULL)
11938     {
11939       enum language func_lang;
11940
11941       gdb::unique_xmalloc_ptr<char> func_name
11942         = find_frame_funname (fi, &func_lang, NULL);
11943       if (func_name != NULL)
11944         {
11945           if (strcmp (func_name.get (),
11946                       data->exception_info->catch_exception_sym) == 0)
11947             break; /* We found the frame we were looking for...  */
11948         }
11949       fi = get_prev_frame (fi);
11950     }
11951
11952   if (fi == NULL)
11953     return 0;
11954
11955   select_frame (fi);
11956   return parse_and_eval_address ("id.full_name");
11957 }
11958
11959 /* Assuming the inferior just triggered an Ada exception catchpoint
11960    (of any type), return the address in inferior memory where the name
11961    of the exception is stored, if applicable.
11962
11963    Assumes the selected frame is the current frame.
11964
11965    Return zero if the address could not be computed, or if not relevant.  */
11966
11967 static CORE_ADDR
11968 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
11969                            struct breakpoint *b)
11970 {
11971   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11972
11973   switch (ex)
11974     {
11975       case ada_catch_exception:
11976         return (parse_and_eval_address ("e.full_name"));
11977         break;
11978
11979       case ada_catch_exception_unhandled:
11980         return data->exception_info->unhandled_exception_name_addr ();
11981         break;
11982
11983       case ada_catch_handlers:
11984         return 0;  /* The runtimes does not provide access to the exception
11985                       name.  */
11986         break;
11987
11988       case ada_catch_assert:
11989         return 0;  /* Exception name is not relevant in this case.  */
11990         break;
11991
11992       default:
11993         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11994         break;
11995     }
11996
11997   return 0; /* Should never be reached.  */
11998 }
11999
12000 /* Assuming the inferior is stopped at an exception catchpoint,
12001    return the message which was associated to the exception, if
12002    available.  Return NULL if the message could not be retrieved.
12003
12004    Note: The exception message can be associated to an exception
12005    either through the use of the Raise_Exception function, or
12006    more simply (Ada 2005 and later), via:
12007
12008        raise Exception_Name with "exception message";
12009
12010    */
12011
12012 static gdb::unique_xmalloc_ptr<char>
12013 ada_exception_message_1 (void)
12014 {
12015   struct value *e_msg_val;
12016   int e_msg_len;
12017
12018   /* For runtimes that support this feature, the exception message
12019      is passed as an unbounded string argument called "message".  */
12020   e_msg_val = parse_and_eval ("message");
12021   if (e_msg_val == NULL)
12022     return NULL; /* Exception message not supported.  */
12023
12024   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12025   gdb_assert (e_msg_val != NULL);
12026   e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12027
12028   /* If the message string is empty, then treat it as if there was
12029      no exception message.  */
12030   if (e_msg_len <= 0)
12031     return NULL;
12032
12033   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12034   read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
12035                e_msg_len);
12036   e_msg.get ()[e_msg_len] = '\0';
12037
12038   return e_msg;
12039 }
12040
12041 /* Same as ada_exception_message_1, except that all exceptions are
12042    contained here (returning NULL instead).  */
12043
12044 static gdb::unique_xmalloc_ptr<char>
12045 ada_exception_message (void)
12046 {
12047   gdb::unique_xmalloc_ptr<char> e_msg;
12048
12049   try
12050     {
12051       e_msg = ada_exception_message_1 ();
12052     }
12053   catch (const gdb_exception_error &e)
12054     {
12055       e_msg.reset (nullptr);
12056     }
12057
12058   return e_msg;
12059 }
12060
12061 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12062    any error that ada_exception_name_addr_1 might cause to be thrown.
12063    When an error is intercepted, a warning with the error message is printed,
12064    and zero is returned.  */
12065
12066 static CORE_ADDR
12067 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
12068                          struct breakpoint *b)
12069 {
12070   CORE_ADDR result = 0;
12071
12072   try
12073     {
12074       result = ada_exception_name_addr_1 (ex, b);
12075     }
12076
12077   catch (const gdb_exception_error &e)
12078     {
12079       warning (_("failed to get exception name: %s"), e.what ());
12080       return 0;
12081     }
12082
12083   return result;
12084 }
12085
12086 static std::string ada_exception_catchpoint_cond_string
12087   (const char *excep_string,
12088    enum ada_exception_catchpoint_kind ex);
12089
12090 /* Ada catchpoints.
12091
12092    In the case of catchpoints on Ada exceptions, the catchpoint will
12093    stop the target on every exception the program throws.  When a user
12094    specifies the name of a specific exception, we translate this
12095    request into a condition expression (in text form), and then parse
12096    it into an expression stored in each of the catchpoint's locations.
12097    We then use this condition to check whether the exception that was
12098    raised is the one the user is interested in.  If not, then the
12099    target is resumed again.  We store the name of the requested
12100    exception, in order to be able to re-set the condition expression
12101    when symbols change.  */
12102
12103 /* An instance of this type is used to represent an Ada catchpoint
12104    breakpoint location.  */
12105
12106 class ada_catchpoint_location : public bp_location
12107 {
12108 public:
12109   ada_catchpoint_location (breakpoint *owner)
12110     : bp_location (owner, bp_loc_software_breakpoint)
12111   {}
12112
12113   /* The condition that checks whether the exception that was raised
12114      is the specific exception the user specified on catchpoint
12115      creation.  */
12116   expression_up excep_cond_expr;
12117 };
12118
12119 /* An instance of this type is used to represent an Ada catchpoint.  */
12120
12121 struct ada_catchpoint : public breakpoint
12122 {
12123   explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind)
12124     : m_kind (kind)
12125   {
12126   }
12127
12128   /* The name of the specific exception the user specified.  */
12129   std::string excep_string;
12130
12131   /* What kind of catchpoint this is.  */
12132   enum ada_exception_catchpoint_kind m_kind;
12133 };
12134
12135 /* Parse the exception condition string in the context of each of the
12136    catchpoint's locations, and store them for later evaluation.  */
12137
12138 static void
12139 create_excep_cond_exprs (struct ada_catchpoint *c,
12140                          enum ada_exception_catchpoint_kind ex)
12141 {
12142   /* Nothing to do if there's no specific exception to catch.  */
12143   if (c->excep_string.empty ())
12144     return;
12145
12146   /* Same if there are no locations... */
12147   if (c->loc == NULL)
12148     return;
12149
12150   /* Compute the condition expression in text form, from the specific
12151      expection we want to catch.  */
12152   std::string cond_string
12153     = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
12154
12155   /* Iterate over all the catchpoint's locations, and parse an
12156      expression for each.  */
12157   for (bp_location *bl : c->locations ())
12158     {
12159       struct ada_catchpoint_location *ada_loc
12160         = (struct ada_catchpoint_location *) bl;
12161       expression_up exp;
12162
12163       if (!bl->shlib_disabled)
12164         {
12165           const char *s;
12166
12167           s = cond_string.c_str ();
12168           try
12169             {
12170               exp = parse_exp_1 (&s, bl->address,
12171                                  block_for_pc (bl->address),
12172                                  0);
12173             }
12174           catch (const gdb_exception_error &e)
12175             {
12176               warning (_("failed to reevaluate internal exception condition "
12177                          "for catchpoint %d: %s"),
12178                        c->number, e.what ());
12179             }
12180         }
12181
12182       ada_loc->excep_cond_expr = std::move (exp);
12183     }
12184 }
12185
12186 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12187    structure for all exception catchpoint kinds.  */
12188
12189 static struct bp_location *
12190 allocate_location_exception (struct breakpoint *self)
12191 {
12192   return new ada_catchpoint_location (self);
12193 }
12194
12195 /* Implement the RE_SET method in the breakpoint_ops structure for all
12196    exception catchpoint kinds.  */
12197
12198 static void
12199 re_set_exception (struct breakpoint *b)
12200 {
12201   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12202
12203   /* Call the base class's method.  This updates the catchpoint's
12204      locations.  */
12205   bkpt_breakpoint_ops.re_set (b);
12206
12207   /* Reparse the exception conditional expressions.  One for each
12208      location.  */
12209   create_excep_cond_exprs (c, c->m_kind);
12210 }
12211
12212 /* Returns true if we should stop for this breakpoint hit.  If the
12213    user specified a specific exception, we only want to cause a stop
12214    if the program thrown that exception.  */
12215
12216 static bool
12217 should_stop_exception (const struct bp_location *bl)
12218 {
12219   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12220   const struct ada_catchpoint_location *ada_loc
12221     = (const struct ada_catchpoint_location *) bl;
12222   bool stop;
12223
12224   struct internalvar *var = lookup_internalvar ("_ada_exception");
12225   if (c->m_kind == ada_catch_assert)
12226     clear_internalvar (var);
12227   else
12228     {
12229       try
12230         {
12231           const char *expr;
12232
12233           if (c->m_kind == ada_catch_handlers)
12234             expr = ("GNAT_GCC_exception_Access(gcc_exception)"
12235                     ".all.occurrence.id");
12236           else
12237             expr = "e";
12238
12239           struct value *exc = parse_and_eval (expr);
12240           set_internalvar (var, exc);
12241         }
12242       catch (const gdb_exception_error &ex)
12243         {
12244           clear_internalvar (var);
12245         }
12246     }
12247
12248   /* With no specific exception, should always stop.  */
12249   if (c->excep_string.empty ())
12250     return true;
12251
12252   if (ada_loc->excep_cond_expr == NULL)
12253     {
12254       /* We will have a NULL expression if back when we were creating
12255          the expressions, this location's had failed to parse.  */
12256       return true;
12257     }
12258
12259   stop = true;
12260   try
12261     {
12262       struct value *mark;
12263
12264       mark = value_mark ();
12265       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12266       value_free_to_mark (mark);
12267     }
12268   catch (const gdb_exception &ex)
12269     {
12270       exception_fprintf (gdb_stderr, ex,
12271                          _("Error in testing exception condition:\n"));
12272     }
12273
12274   return stop;
12275 }
12276
12277 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12278    for all exception catchpoint kinds.  */
12279
12280 static void
12281 check_status_exception (bpstat *bs)
12282 {
12283   bs->stop = should_stop_exception (bs->bp_location_at.get ());
12284 }
12285
12286 /* Implement the PRINT_IT method in the breakpoint_ops structure
12287    for all exception catchpoint kinds.  */
12288
12289 static enum print_stop_action
12290 print_it_exception (bpstat *bs)
12291 {
12292   struct ui_out *uiout = current_uiout;
12293   struct breakpoint *b = bs->breakpoint_at;
12294
12295   annotate_catchpoint (b->number);
12296
12297   if (uiout->is_mi_like_p ())
12298     {
12299       uiout->field_string ("reason",
12300                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12301       uiout->field_string ("disp", bpdisp_text (b->disposition));
12302     }
12303
12304   uiout->text (b->disposition == disp_del
12305                ? "\nTemporary catchpoint " : "\nCatchpoint ");
12306   uiout->field_signed ("bkptno", b->number);
12307   uiout->text (", ");
12308
12309   /* ada_exception_name_addr relies on the selected frame being the
12310      current frame.  Need to do this here because this function may be
12311      called more than once when printing a stop, and below, we'll
12312      select the first frame past the Ada run-time (see
12313      ada_find_printable_frame).  */
12314   select_frame (get_current_frame ());
12315
12316   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12317   switch (c->m_kind)
12318     {
12319       case ada_catch_exception:
12320       case ada_catch_exception_unhandled:
12321       case ada_catch_handlers:
12322         {
12323           const CORE_ADDR addr = ada_exception_name_addr (c->m_kind, b);
12324           char exception_name[256];
12325
12326           if (addr != 0)
12327             {
12328               read_memory (addr, (gdb_byte *) exception_name,
12329                            sizeof (exception_name) - 1);
12330               exception_name [sizeof (exception_name) - 1] = '\0';
12331             }
12332           else
12333             {
12334               /* For some reason, we were unable to read the exception
12335                  name.  This could happen if the Runtime was compiled
12336                  without debugging info, for instance.  In that case,
12337                  just replace the exception name by the generic string
12338                  "exception" - it will read as "an exception" in the
12339                  notification we are about to print.  */
12340               memcpy (exception_name, "exception", sizeof ("exception"));
12341             }
12342           /* In the case of unhandled exception breakpoints, we print
12343              the exception name as "unhandled EXCEPTION_NAME", to make
12344              it clearer to the user which kind of catchpoint just got
12345              hit.  We used ui_out_text to make sure that this extra
12346              info does not pollute the exception name in the MI case.  */
12347           if (c->m_kind == ada_catch_exception_unhandled)
12348             uiout->text ("unhandled ");
12349           uiout->field_string ("exception-name", exception_name);
12350         }
12351         break;
12352       case ada_catch_assert:
12353         /* In this case, the name of the exception is not really
12354            important.  Just print "failed assertion" to make it clearer
12355            that his program just hit an assertion-failure catchpoint.
12356            We used ui_out_text because this info does not belong in
12357            the MI output.  */
12358         uiout->text ("failed assertion");
12359         break;
12360     }
12361
12362   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12363   if (exception_message != NULL)
12364     {
12365       uiout->text (" (");
12366       uiout->field_string ("exception-message", exception_message.get ());
12367       uiout->text (")");
12368     }
12369
12370   uiout->text (" at ");
12371   ada_find_printable_frame (get_current_frame ());
12372
12373   return PRINT_SRC_AND_LOC;
12374 }
12375
12376 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12377    for all exception catchpoint kinds.  */
12378
12379 static void
12380 print_one_exception (struct breakpoint *b, struct bp_location **last_loc)
12381
12382   struct ui_out *uiout = current_uiout;
12383   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12384   struct value_print_options opts;
12385
12386   get_user_print_options (&opts);
12387
12388   if (opts.addressprint)
12389     uiout->field_skip ("addr");
12390
12391   annotate_field (5);
12392   switch (c->m_kind)
12393     {
12394       case ada_catch_exception:
12395         if (!c->excep_string.empty ())
12396           {
12397             std::string msg = string_printf (_("`%s' Ada exception"),
12398                                              c->excep_string.c_str ());
12399
12400             uiout->field_string ("what", msg);
12401           }
12402         else
12403           uiout->field_string ("what", "all Ada exceptions");
12404         
12405         break;
12406
12407       case ada_catch_exception_unhandled:
12408         uiout->field_string ("what", "unhandled Ada exceptions");
12409         break;
12410       
12411       case ada_catch_handlers:
12412         if (!c->excep_string.empty ())
12413           {
12414             uiout->field_fmt ("what",
12415                               _("`%s' Ada exception handlers"),
12416                               c->excep_string.c_str ());
12417           }
12418         else
12419           uiout->field_string ("what", "all Ada exceptions handlers");
12420         break;
12421
12422       case ada_catch_assert:
12423         uiout->field_string ("what", "failed Ada assertions");
12424         break;
12425
12426       default:
12427         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12428         break;
12429     }
12430 }
12431
12432 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12433    for all exception catchpoint kinds.  */
12434
12435 static void
12436 print_mention_exception (struct breakpoint *b)
12437 {
12438   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12439   struct ui_out *uiout = current_uiout;
12440
12441   uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
12442                                                  : _("Catchpoint "));
12443   uiout->field_signed ("bkptno", b->number);
12444   uiout->text (": ");
12445
12446   switch (c->m_kind)
12447     {
12448       case ada_catch_exception:
12449         if (!c->excep_string.empty ())
12450           {
12451             std::string info = string_printf (_("`%s' Ada exception"),
12452                                               c->excep_string.c_str ());
12453             uiout->text (info);
12454           }
12455         else
12456           uiout->text (_("all Ada exceptions"));
12457         break;
12458
12459       case ada_catch_exception_unhandled:
12460         uiout->text (_("unhandled Ada exceptions"));
12461         break;
12462
12463       case ada_catch_handlers:
12464         if (!c->excep_string.empty ())
12465           {
12466             std::string info
12467               = string_printf (_("`%s' Ada exception handlers"),
12468                                c->excep_string.c_str ());
12469             uiout->text (info);
12470           }
12471         else
12472           uiout->text (_("all Ada exceptions handlers"));
12473         break;
12474
12475       case ada_catch_assert:
12476         uiout->text (_("failed Ada assertions"));
12477         break;
12478
12479       default:
12480         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12481         break;
12482     }
12483 }
12484
12485 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12486    for all exception catchpoint kinds.  */
12487
12488 static void
12489 print_recreate_exception (struct breakpoint *b, struct ui_file *fp)
12490 {
12491   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12492
12493   switch (c->m_kind)
12494     {
12495       case ada_catch_exception:
12496         gdb_printf (fp, "catch exception");
12497         if (!c->excep_string.empty ())
12498           gdb_printf (fp, " %s", c->excep_string.c_str ());
12499         break;
12500
12501       case ada_catch_exception_unhandled:
12502         gdb_printf (fp, "catch exception unhandled");
12503         break;
12504
12505       case ada_catch_handlers:
12506         gdb_printf (fp, "catch handlers");
12507         break;
12508
12509       case ada_catch_assert:
12510         gdb_printf (fp, "catch assert");
12511         break;
12512
12513       default:
12514         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12515     }
12516   print_recreate_thread (b, fp);
12517 }
12518
12519 /* Virtual table for breakpoint type.  */
12520 static struct breakpoint_ops catch_exception_breakpoint_ops;
12521
12522 /* See ada-lang.h.  */
12523
12524 bool
12525 is_ada_exception_catchpoint (breakpoint *bp)
12526 {
12527   return bp->ops == &catch_exception_breakpoint_ops;
12528 }
12529
12530 /* Split the arguments specified in a "catch exception" command.  
12531    Set EX to the appropriate catchpoint type.
12532    Set EXCEP_STRING to the name of the specific exception if
12533    specified by the user.
12534    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12535    "catch handlers" command.  False otherwise.
12536    If a condition is found at the end of the arguments, the condition
12537    expression is stored in COND_STRING (memory must be deallocated
12538    after use).  Otherwise COND_STRING is set to NULL.  */
12539
12540 static void
12541 catch_ada_exception_command_split (const char *args,
12542                                    bool is_catch_handlers_cmd,
12543                                    enum ada_exception_catchpoint_kind *ex,
12544                                    std::string *excep_string,
12545                                    std::string *cond_string)
12546 {
12547   std::string exception_name;
12548
12549   exception_name = extract_arg (&args);
12550   if (exception_name == "if")
12551     {
12552       /* This is not an exception name; this is the start of a condition
12553          expression for a catchpoint on all exceptions.  So, "un-get"
12554          this token, and set exception_name to NULL.  */
12555       exception_name.clear ();
12556       args -= 2;
12557     }
12558
12559   /* Check to see if we have a condition.  */
12560
12561   args = skip_spaces (args);
12562   if (startswith (args, "if")
12563       && (isspace (args[2]) || args[2] == '\0'))
12564     {
12565       args += 2;
12566       args = skip_spaces (args);
12567
12568       if (args[0] == '\0')
12569         error (_("Condition missing after `if' keyword"));
12570       *cond_string = args;
12571
12572       args += strlen (args);
12573     }
12574
12575   /* Check that we do not have any more arguments.  Anything else
12576      is unexpected.  */
12577
12578   if (args[0] != '\0')
12579     error (_("Junk at end of expression"));
12580
12581   if (is_catch_handlers_cmd)
12582     {
12583       /* Catch handling of exceptions.  */
12584       *ex = ada_catch_handlers;
12585       *excep_string = exception_name;
12586     }
12587   else if (exception_name.empty ())
12588     {
12589       /* Catch all exceptions.  */
12590       *ex = ada_catch_exception;
12591       excep_string->clear ();
12592     }
12593   else if (exception_name == "unhandled")
12594     {
12595       /* Catch unhandled exceptions.  */
12596       *ex = ada_catch_exception_unhandled;
12597       excep_string->clear ();
12598     }
12599   else
12600     {
12601       /* Catch a specific exception.  */
12602       *ex = ada_catch_exception;
12603       *excep_string = exception_name;
12604     }
12605 }
12606
12607 /* Return the name of the symbol on which we should break in order to
12608    implement a catchpoint of the EX kind.  */
12609
12610 static const char *
12611 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12612 {
12613   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12614
12615   gdb_assert (data->exception_info != NULL);
12616
12617   switch (ex)
12618     {
12619       case ada_catch_exception:
12620         return (data->exception_info->catch_exception_sym);
12621         break;
12622       case ada_catch_exception_unhandled:
12623         return (data->exception_info->catch_exception_unhandled_sym);
12624         break;
12625       case ada_catch_assert:
12626         return (data->exception_info->catch_assert_sym);
12627         break;
12628       case ada_catch_handlers:
12629         return (data->exception_info->catch_handlers_sym);
12630         break;
12631       default:
12632         internal_error (__FILE__, __LINE__,
12633                         _("unexpected catchpoint kind (%d)"), ex);
12634     }
12635 }
12636
12637 /* Return the condition that will be used to match the current exception
12638    being raised with the exception that the user wants to catch.  This
12639    assumes that this condition is used when the inferior just triggered
12640    an exception catchpoint.
12641    EX: the type of catchpoints used for catching Ada exceptions.  */
12642
12643 static std::string
12644 ada_exception_catchpoint_cond_string (const char *excep_string,
12645                                       enum ada_exception_catchpoint_kind ex)
12646 {
12647   bool is_standard_exc = false;
12648   std::string result;
12649
12650   if (ex == ada_catch_handlers)
12651     {
12652       /* For exception handlers catchpoints, the condition string does
12653          not use the same parameter as for the other exceptions.  */
12654       result = ("long_integer (GNAT_GCC_exception_Access"
12655                 "(gcc_exception).all.occurrence.id)");
12656     }
12657   else
12658     result = "long_integer (e)";
12659
12660   /* The standard exceptions are a special case.  They are defined in
12661      runtime units that have been compiled without debugging info; if
12662      EXCEP_STRING is the not-fully-qualified name of a standard
12663      exception (e.g. "constraint_error") then, during the evaluation
12664      of the condition expression, the symbol lookup on this name would
12665      *not* return this standard exception.  The catchpoint condition
12666      may then be set only on user-defined exceptions which have the
12667      same not-fully-qualified name (e.g. my_package.constraint_error).
12668
12669      To avoid this unexcepted behavior, these standard exceptions are
12670      systematically prefixed by "standard".  This means that "catch
12671      exception constraint_error" is rewritten into "catch exception
12672      standard.constraint_error".
12673
12674      If an exception named constraint_error is defined in another package of
12675      the inferior program, then the only way to specify this exception as a
12676      breakpoint condition is to use its fully-qualified named:
12677      e.g. my_package.constraint_error.  */
12678
12679   for (const char *name : standard_exc)
12680     {
12681       if (strcmp (name, excep_string) == 0)
12682         {
12683           is_standard_exc = true;
12684           break;
12685         }
12686     }
12687
12688   result += " = ";
12689
12690   if (is_standard_exc)
12691     string_appendf (result, "long_integer (&standard.%s)", excep_string);
12692   else
12693     string_appendf (result, "long_integer (&%s)", excep_string);
12694
12695   return result;
12696 }
12697
12698 /* Return the symtab_and_line that should be used to insert an exception
12699    catchpoint of the TYPE kind.
12700
12701    ADDR_STRING returns the name of the function where the real
12702    breakpoint that implements the catchpoints is set, depending on the
12703    type of catchpoint we need to create.  */
12704
12705 static struct symtab_and_line
12706 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12707                    std::string *addr_string, const struct breakpoint_ops **ops)
12708 {
12709   const char *sym_name;
12710   struct symbol *sym;
12711
12712   /* First, find out which exception support info to use.  */
12713   ada_exception_support_info_sniffer ();
12714
12715   /* Then lookup the function on which we will break in order to catch
12716      the Ada exceptions requested by the user.  */
12717   sym_name = ada_exception_sym_name (ex);
12718   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12719
12720   if (sym == NULL)
12721     error (_("Catchpoint symbol not found: %s"), sym_name);
12722
12723   if (sym->aclass () != LOC_BLOCK)
12724     error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12725
12726   /* Set ADDR_STRING.  */
12727   *addr_string = sym_name;
12728
12729   /* Set OPS.  */
12730   *ops = &catch_exception_breakpoint_ops;
12731
12732   return find_function_start_sal (sym, 1);
12733 }
12734
12735 /* Create an Ada exception catchpoint.
12736
12737    EX_KIND is the kind of exception catchpoint to be created.
12738
12739    If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12740    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
12741    of the exception to which this catchpoint applies.
12742
12743    COND_STRING, if not empty, is the catchpoint condition.
12744
12745    TEMPFLAG, if nonzero, means that the underlying breakpoint
12746    should be temporary.
12747
12748    FROM_TTY is the usual argument passed to all commands implementations.  */
12749
12750 void
12751 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12752                                  enum ada_exception_catchpoint_kind ex_kind,
12753                                  const std::string &excep_string,
12754                                  const std::string &cond_string,
12755                                  int tempflag,
12756                                  int disabled,
12757                                  int from_tty)
12758 {
12759   std::string addr_string;
12760   const struct breakpoint_ops *ops = NULL;
12761   struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
12762
12763   std::unique_ptr<ada_catchpoint> c (new ada_catchpoint (ex_kind));
12764   init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
12765                                  ops, tempflag, disabled, from_tty);
12766   c->excep_string = excep_string;
12767   create_excep_cond_exprs (c.get (), ex_kind);
12768   if (!cond_string.empty ())
12769     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12770   install_breakpoint (0, std::move (c), 1);
12771 }
12772
12773 /* Implement the "catch exception" command.  */
12774
12775 static void
12776 catch_ada_exception_command (const char *arg_entry, int from_tty,
12777                              struct cmd_list_element *command)
12778 {
12779   const char *arg = arg_entry;
12780   struct gdbarch *gdbarch = get_current_arch ();
12781   int tempflag;
12782   enum ada_exception_catchpoint_kind ex_kind;
12783   std::string excep_string;
12784   std::string cond_string;
12785
12786   tempflag = command->context () == CATCH_TEMPORARY;
12787
12788   if (!arg)
12789     arg = "";
12790   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12791                                      &cond_string);
12792   create_ada_exception_catchpoint (gdbarch, ex_kind,
12793                                    excep_string, cond_string,
12794                                    tempflag, 1 /* enabled */,
12795                                    from_tty);
12796 }
12797
12798 /* Implement the "catch handlers" command.  */
12799
12800 static void
12801 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12802                             struct cmd_list_element *command)
12803 {
12804   const char *arg = arg_entry;
12805   struct gdbarch *gdbarch = get_current_arch ();
12806   int tempflag;
12807   enum ada_exception_catchpoint_kind ex_kind;
12808   std::string excep_string;
12809   std::string cond_string;
12810
12811   tempflag = command->context () == CATCH_TEMPORARY;
12812
12813   if (!arg)
12814     arg = "";
12815   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12816                                      &cond_string);
12817   create_ada_exception_catchpoint (gdbarch, ex_kind,
12818                                    excep_string, cond_string,
12819                                    tempflag, 1 /* enabled */,
12820                                    from_tty);
12821 }
12822
12823 /* Completion function for the Ada "catch" commands.  */
12824
12825 static void
12826 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12827                      const char *text, const char *word)
12828 {
12829   std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12830
12831   for (const ada_exc_info &info : exceptions)
12832     {
12833       if (startswith (info.name, word))
12834         tracker.add_completion (make_unique_xstrdup (info.name));
12835     }
12836 }
12837
12838 /* Split the arguments specified in a "catch assert" command.
12839
12840    ARGS contains the command's arguments (or the empty string if
12841    no arguments were passed).
12842
12843    If ARGS contains a condition, set COND_STRING to that condition
12844    (the memory needs to be deallocated after use).  */
12845
12846 static void
12847 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12848 {
12849   args = skip_spaces (args);
12850
12851   /* Check whether a condition was provided.  */
12852   if (startswith (args, "if")
12853       && (isspace (args[2]) || args[2] == '\0'))
12854     {
12855       args += 2;
12856       args = skip_spaces (args);
12857       if (args[0] == '\0')
12858         error (_("condition missing after `if' keyword"));
12859       cond_string.assign (args);
12860     }
12861
12862   /* Otherwise, there should be no other argument at the end of
12863      the command.  */
12864   else if (args[0] != '\0')
12865     error (_("Junk at end of arguments."));
12866 }
12867
12868 /* Implement the "catch assert" command.  */
12869
12870 static void
12871 catch_assert_command (const char *arg_entry, int from_tty,
12872                       struct cmd_list_element *command)
12873 {
12874   const char *arg = arg_entry;
12875   struct gdbarch *gdbarch = get_current_arch ();
12876   int tempflag;
12877   std::string cond_string;
12878
12879   tempflag = command->context () == CATCH_TEMPORARY;
12880
12881   if (!arg)
12882     arg = "";
12883   catch_ada_assert_command_split (arg, cond_string);
12884   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12885                                    "", cond_string,
12886                                    tempflag, 1 /* enabled */,
12887                                    from_tty);
12888 }
12889
12890 /* Return non-zero if the symbol SYM is an Ada exception object.  */
12891
12892 static int
12893 ada_is_exception_sym (struct symbol *sym)
12894 {
12895   const char *type_name = sym->type ()->name ();
12896
12897   return (sym->aclass () != LOC_TYPEDEF
12898           && sym->aclass () != LOC_BLOCK
12899           && sym->aclass () != LOC_CONST
12900           && sym->aclass () != LOC_UNRESOLVED
12901           && type_name != NULL && strcmp (type_name, "exception") == 0);
12902 }
12903
12904 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12905    Ada exception object.  This matches all exceptions except the ones
12906    defined by the Ada language.  */
12907
12908 static int
12909 ada_is_non_standard_exception_sym (struct symbol *sym)
12910 {
12911   if (!ada_is_exception_sym (sym))
12912     return 0;
12913
12914   for (const char *name : standard_exc)
12915     if (strcmp (sym->linkage_name (), name) == 0)
12916       return 0;  /* A standard exception.  */
12917
12918   /* Numeric_Error is also a standard exception, so exclude it.
12919      See the STANDARD_EXC description for more details as to why
12920      this exception is not listed in that array.  */
12921   if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12922     return 0;
12923
12924   return 1;
12925 }
12926
12927 /* A helper function for std::sort, comparing two struct ada_exc_info
12928    objects.
12929
12930    The comparison is determined first by exception name, and then
12931    by exception address.  */
12932
12933 bool
12934 ada_exc_info::operator< (const ada_exc_info &other) const
12935 {
12936   int result;
12937
12938   result = strcmp (name, other.name);
12939   if (result < 0)
12940     return true;
12941   if (result == 0 && addr < other.addr)
12942     return true;
12943   return false;
12944 }
12945
12946 bool
12947 ada_exc_info::operator== (const ada_exc_info &other) const
12948 {
12949   return addr == other.addr && strcmp (name, other.name) == 0;
12950 }
12951
12952 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12953    routine, but keeping the first SKIP elements untouched.
12954
12955    All duplicates are also removed.  */
12956
12957 static void
12958 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
12959                                       int skip)
12960 {
12961   std::sort (exceptions->begin () + skip, exceptions->end ());
12962   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
12963                      exceptions->end ());
12964 }
12965
12966 /* Add all exceptions defined by the Ada standard whose name match
12967    a regular expression.
12968
12969    If PREG is not NULL, then this regexp_t object is used to
12970    perform the symbol name matching.  Otherwise, no name-based
12971    filtering is performed.
12972
12973    EXCEPTIONS is a vector of exceptions to which matching exceptions
12974    gets pushed.  */
12975
12976 static void
12977 ada_add_standard_exceptions (compiled_regex *preg,
12978                              std::vector<ada_exc_info> *exceptions)
12979 {
12980   for (const char *name : standard_exc)
12981     {
12982       if (preg == NULL || preg->exec (name, 0, NULL, 0) == 0)
12983         {
12984           struct bound_minimal_symbol msymbol
12985             = ada_lookup_simple_minsym (name);
12986
12987           if (msymbol.minsym != NULL)
12988             {
12989               struct ada_exc_info info
12990                 = {name, BMSYMBOL_VALUE_ADDRESS (msymbol)};
12991
12992               exceptions->push_back (info);
12993             }
12994         }
12995     }
12996 }
12997
12998 /* Add all Ada exceptions defined locally and accessible from the given
12999    FRAME.
13000
13001    If PREG is not NULL, then this regexp_t object is used to
13002    perform the symbol name matching.  Otherwise, no name-based
13003    filtering is performed.
13004
13005    EXCEPTIONS is a vector of exceptions to which matching exceptions
13006    gets pushed.  */
13007
13008 static void
13009 ada_add_exceptions_from_frame (compiled_regex *preg,
13010                                struct frame_info *frame,
13011                                std::vector<ada_exc_info> *exceptions)
13012 {
13013   const struct block *block = get_frame_block (frame, 0);
13014
13015   while (block != 0)
13016     {
13017       struct block_iterator iter;
13018       struct symbol *sym;
13019
13020       ALL_BLOCK_SYMBOLS (block, iter, sym)
13021         {
13022           switch (sym->aclass ())
13023             {
13024             case LOC_TYPEDEF:
13025             case LOC_BLOCK:
13026             case LOC_CONST:
13027               break;
13028             default:
13029               if (ada_is_exception_sym (sym))
13030                 {
13031                   struct ada_exc_info info = {sym->print_name (),
13032                                               SYMBOL_VALUE_ADDRESS (sym)};
13033
13034                   exceptions->push_back (info);
13035                 }
13036             }
13037         }
13038       if (BLOCK_FUNCTION (block) != NULL)
13039         break;
13040       block = BLOCK_SUPERBLOCK (block);
13041     }
13042 }
13043
13044 /* Return true if NAME matches PREG or if PREG is NULL.  */
13045
13046 static bool
13047 name_matches_regex (const char *name, compiled_regex *preg)
13048 {
13049   return (preg == NULL
13050           || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
13051 }
13052
13053 /* Add all exceptions defined globally whose name name match
13054    a regular expression, excluding standard exceptions.
13055
13056    The reason we exclude standard exceptions is that they need
13057    to be handled separately: Standard exceptions are defined inside
13058    a runtime unit which is normally not compiled with debugging info,
13059    and thus usually do not show up in our symbol search.  However,
13060    if the unit was in fact built with debugging info, we need to
13061    exclude them because they would duplicate the entry we found
13062    during the special loop that specifically searches for those
13063    standard exceptions.
13064
13065    If PREG is not NULL, then this regexp_t object is used to
13066    perform the symbol name matching.  Otherwise, no name-based
13067    filtering is performed.
13068
13069    EXCEPTIONS is a vector of exceptions to which matching exceptions
13070    gets pushed.  */
13071
13072 static void
13073 ada_add_global_exceptions (compiled_regex *preg,
13074                            std::vector<ada_exc_info> *exceptions)
13075 {
13076   /* In Ada, the symbol "search name" is a linkage name, whereas the
13077      regular expression used to do the matching refers to the natural
13078      name.  So match against the decoded name.  */
13079   expand_symtabs_matching (NULL,
13080                            lookup_name_info::match_any (),
13081                            [&] (const char *search_name)
13082                            {
13083                              std::string decoded = ada_decode (search_name);
13084                              return name_matches_regex (decoded.c_str (), preg);
13085                            },
13086                            NULL,
13087                            SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13088                            VARIABLES_DOMAIN);
13089
13090   for (objfile *objfile : current_program_space->objfiles ())
13091     {
13092       for (compunit_symtab *s : objfile->compunits ())
13093         {
13094           const struct blockvector *bv = s->blockvector ();
13095           int i;
13096
13097           for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13098             {
13099               const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13100               struct block_iterator iter;
13101               struct symbol *sym;
13102
13103               ALL_BLOCK_SYMBOLS (b, iter, sym)
13104                 if (ada_is_non_standard_exception_sym (sym)
13105                     && name_matches_regex (sym->natural_name (), preg))
13106                   {
13107                     struct ada_exc_info info
13108                       = {sym->print_name (), SYMBOL_VALUE_ADDRESS (sym)};
13109
13110                     exceptions->push_back (info);
13111                   }
13112             }
13113         }
13114     }
13115 }
13116
13117 /* Implements ada_exceptions_list with the regular expression passed
13118    as a regex_t, rather than a string.
13119
13120    If not NULL, PREG is used to filter out exceptions whose names
13121    do not match.  Otherwise, all exceptions are listed.  */
13122
13123 static std::vector<ada_exc_info>
13124 ada_exceptions_list_1 (compiled_regex *preg)
13125 {
13126   std::vector<ada_exc_info> result;
13127   int prev_len;
13128
13129   /* First, list the known standard exceptions.  These exceptions
13130      need to be handled separately, as they are usually defined in
13131      runtime units that have been compiled without debugging info.  */
13132
13133   ada_add_standard_exceptions (preg, &result);
13134
13135   /* Next, find all exceptions whose scope is local and accessible
13136      from the currently selected frame.  */
13137
13138   if (has_stack_frames ())
13139     {
13140       prev_len = result.size ();
13141       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13142                                      &result);
13143       if (result.size () > prev_len)
13144         sort_remove_dups_ada_exceptions_list (&result, prev_len);
13145     }
13146
13147   /* Add all exceptions whose scope is global.  */
13148
13149   prev_len = result.size ();
13150   ada_add_global_exceptions (preg, &result);
13151   if (result.size () > prev_len)
13152     sort_remove_dups_ada_exceptions_list (&result, prev_len);
13153
13154   return result;
13155 }
13156
13157 /* Return a vector of ada_exc_info.
13158
13159    If REGEXP is NULL, all exceptions are included in the result.
13160    Otherwise, it should contain a valid regular expression,
13161    and only the exceptions whose names match that regular expression
13162    are included in the result.
13163
13164    The exceptions are sorted in the following order:
13165      - Standard exceptions (defined by the Ada language), in
13166        alphabetical order;
13167      - Exceptions only visible from the current frame, in
13168        alphabetical order;
13169      - Exceptions whose scope is global, in alphabetical order.  */
13170
13171 std::vector<ada_exc_info>
13172 ada_exceptions_list (const char *regexp)
13173 {
13174   if (regexp == NULL)
13175     return ada_exceptions_list_1 (NULL);
13176
13177   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13178   return ada_exceptions_list_1 (&reg);
13179 }
13180
13181 /* Implement the "info exceptions" command.  */
13182
13183 static void
13184 info_exceptions_command (const char *regexp, int from_tty)
13185 {
13186   struct gdbarch *gdbarch = get_current_arch ();
13187
13188   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13189
13190   if (regexp != NULL)
13191     gdb_printf
13192       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13193   else
13194     gdb_printf (_("All defined Ada exceptions:\n"));
13195
13196   for (const ada_exc_info &info : exceptions)
13197     gdb_printf ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13198 }
13199
13200 \f
13201                                 /* Language vector */
13202
13203 /* symbol_name_matcher_ftype adapter for wild_match.  */
13204
13205 static bool
13206 do_wild_match (const char *symbol_search_name,
13207                const lookup_name_info &lookup_name,
13208                completion_match_result *comp_match_res)
13209 {
13210   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
13211 }
13212
13213 /* symbol_name_matcher_ftype adapter for full_match.  */
13214
13215 static bool
13216 do_full_match (const char *symbol_search_name,
13217                const lookup_name_info &lookup_name,
13218                completion_match_result *comp_match_res)
13219 {
13220   const char *lname = lookup_name.ada ().lookup_name ().c_str ();
13221
13222   /* If both symbols start with "_ada_", just let the loop below
13223      handle the comparison.  However, if only the symbol name starts
13224      with "_ada_", skip the prefix and let the match proceed as
13225      usual.  */
13226   if (startswith (symbol_search_name, "_ada_")
13227       && !startswith (lname, "_ada"))
13228     symbol_search_name += 5;
13229   /* Likewise for ghost entities.  */
13230   if (startswith (symbol_search_name, "___ghost_")
13231       && !startswith (lname, "___ghost_"))
13232     symbol_search_name += 9;
13233
13234   int uscore_count = 0;
13235   while (*lname != '\0')
13236     {
13237       if (*symbol_search_name != *lname)
13238         {
13239           if (*symbol_search_name == 'B' && uscore_count == 2
13240               && symbol_search_name[1] == '_')
13241             {
13242               symbol_search_name += 2;
13243               while (isdigit (*symbol_search_name))
13244                 ++symbol_search_name;
13245               if (symbol_search_name[0] == '_'
13246                   && symbol_search_name[1] == '_')
13247                 {
13248                   symbol_search_name += 2;
13249                   continue;
13250                 }
13251             }
13252           return false;
13253         }
13254
13255       if (*symbol_search_name == '_')
13256         ++uscore_count;
13257       else
13258         uscore_count = 0;
13259
13260       ++symbol_search_name;
13261       ++lname;
13262     }
13263
13264   return is_name_suffix (symbol_search_name);
13265 }
13266
13267 /* symbol_name_matcher_ftype for exact (verbatim) matches.  */
13268
13269 static bool
13270 do_exact_match (const char *symbol_search_name,
13271                 const lookup_name_info &lookup_name,
13272                 completion_match_result *comp_match_res)
13273 {
13274   return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
13275 }
13276
13277 /* Build the Ada lookup name for LOOKUP_NAME.  */
13278
13279 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
13280 {
13281   gdb::string_view user_name = lookup_name.name ();
13282
13283   if (!user_name.empty () && user_name[0] == '<')
13284     {
13285       if (user_name.back () == '>')
13286         m_encoded_name
13287           = gdb::to_string (user_name.substr (1, user_name.size () - 2));
13288       else
13289         m_encoded_name
13290           = gdb::to_string (user_name.substr (1, user_name.size () - 1));
13291       m_encoded_p = true;
13292       m_verbatim_p = true;
13293       m_wild_match_p = false;
13294       m_standard_p = false;
13295     }
13296   else
13297     {
13298       m_verbatim_p = false;
13299
13300       m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
13301
13302       if (!m_encoded_p)
13303         {
13304           const char *folded = ada_fold_name (user_name);
13305           m_encoded_name = ada_encode_1 (folded, false);
13306           if (m_encoded_name.empty ())
13307             m_encoded_name = gdb::to_string (user_name);
13308         }
13309       else
13310         m_encoded_name = gdb::to_string (user_name);
13311
13312       /* Handle the 'package Standard' special case.  See description
13313          of m_standard_p.  */
13314       if (startswith (m_encoded_name.c_str (), "standard__"))
13315         {
13316           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
13317           m_standard_p = true;
13318         }
13319       else
13320         m_standard_p = false;
13321
13322       /* If the name contains a ".", then the user is entering a fully
13323          qualified entity name, and the match must not be done in wild
13324          mode.  Similarly, if the user wants to complete what looks
13325          like an encoded name, the match must not be done in wild
13326          mode.  Also, in the standard__ special case always do
13327          non-wild matching.  */
13328       m_wild_match_p
13329         = (lookup_name.match_type () != symbol_name_match_type::FULL
13330            && !m_encoded_p
13331            && !m_standard_p
13332            && user_name.find ('.') == std::string::npos);
13333     }
13334 }
13335
13336 /* symbol_name_matcher_ftype method for Ada.  This only handles
13337    completion mode.  */
13338
13339 static bool
13340 ada_symbol_name_matches (const char *symbol_search_name,
13341                          const lookup_name_info &lookup_name,
13342                          completion_match_result *comp_match_res)
13343 {
13344   return lookup_name.ada ().matches (symbol_search_name,
13345                                      lookup_name.match_type (),
13346                                      comp_match_res);
13347 }
13348
13349 /* A name matcher that matches the symbol name exactly, with
13350    strcmp.  */
13351
13352 static bool
13353 literal_symbol_name_matcher (const char *symbol_search_name,
13354                              const lookup_name_info &lookup_name,
13355                              completion_match_result *comp_match_res)
13356 {
13357   gdb::string_view name_view = lookup_name.name ();
13358
13359   if (lookup_name.completion_mode ()
13360       ? (strncmp (symbol_search_name, name_view.data (),
13361                   name_view.size ()) == 0)
13362       : symbol_search_name == name_view)
13363     {
13364       if (comp_match_res != NULL)
13365         comp_match_res->set_match (symbol_search_name);
13366       return true;
13367     }
13368   else
13369     return false;
13370 }
13371
13372 /* Implement the "get_symbol_name_matcher" language_defn method for
13373    Ada.  */
13374
13375 static symbol_name_matcher_ftype *
13376 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
13377 {
13378   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
13379     return literal_symbol_name_matcher;
13380
13381   if (lookup_name.completion_mode ())
13382     return ada_symbol_name_matches;
13383   else
13384     {
13385       if (lookup_name.ada ().wild_match_p ())
13386         return do_wild_match;
13387       else if (lookup_name.ada ().verbatim_p ())
13388         return do_exact_match;
13389       else
13390         return do_full_match;
13391     }
13392 }
13393
13394 /* Class representing the Ada language.  */
13395
13396 class ada_language : public language_defn
13397 {
13398 public:
13399   ada_language ()
13400     : language_defn (language_ada)
13401   { /* Nothing.  */ }
13402
13403   /* See language.h.  */
13404
13405   const char *name () const override
13406   { return "ada"; }
13407
13408   /* See language.h.  */
13409
13410   const char *natural_name () const override
13411   { return "Ada"; }
13412
13413   /* See language.h.  */
13414
13415   const std::vector<const char *> &filename_extensions () const override
13416   {
13417     static const std::vector<const char *> extensions
13418       = { ".adb", ".ads", ".a", ".ada", ".dg" };
13419     return extensions;
13420   }
13421
13422   /* Print an array element index using the Ada syntax.  */
13423
13424   void print_array_index (struct type *index_type,
13425                           LONGEST index,
13426                           struct ui_file *stream,
13427                           const value_print_options *options) const override
13428   {
13429     struct value *index_value = val_atr (index_type, index);
13430
13431     value_print (index_value, stream, options);
13432     gdb_printf (stream, " => ");
13433   }
13434
13435   /* Implement the "read_var_value" language_defn method for Ada.  */
13436
13437   struct value *read_var_value (struct symbol *var,
13438                                 const struct block *var_block,
13439                                 struct frame_info *frame) const override
13440   {
13441     /* The only case where default_read_var_value is not sufficient
13442        is when VAR is a renaming...  */
13443     if (frame != nullptr)
13444       {
13445         const struct block *frame_block = get_frame_block (frame, NULL);
13446         if (frame_block != nullptr && ada_is_renaming_symbol (var))
13447           return ada_read_renaming_var_value (var, frame_block);
13448       }
13449
13450     /* This is a typical case where we expect the default_read_var_value
13451        function to work.  */
13452     return language_defn::read_var_value (var, var_block, frame);
13453   }
13454
13455   /* See language.h.  */
13456   virtual bool symbol_printing_suppressed (struct symbol *symbol) const override
13457   {
13458     return symbol->artificial;
13459   }
13460
13461   /* See language.h.  */
13462   void language_arch_info (struct gdbarch *gdbarch,
13463                            struct language_arch_info *lai) const override
13464   {
13465     const struct builtin_type *builtin = builtin_type (gdbarch);
13466
13467     /* Helper function to allow shorter lines below.  */
13468     auto add = [&] (struct type *t)
13469     {
13470       lai->add_primitive_type (t);
13471     };
13472
13473     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13474                             0, "integer"));
13475     add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13476                             0, "long_integer"));
13477     add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13478                             0, "short_integer"));
13479     struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
13480                                                   1, "character");
13481     lai->set_string_char_type (char_type);
13482     add (char_type);
13483     add (arch_character_type (gdbarch, 16, 1, "wide_character"));
13484     add (arch_character_type (gdbarch, 32, 1, "wide_wide_character"));
13485     add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13486                           "float", gdbarch_float_format (gdbarch)));
13487     add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13488                           "long_float", gdbarch_double_format (gdbarch)));
13489     add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13490                             0, "long_long_integer"));
13491     add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13492                           "long_long_float",
13493                           gdbarch_long_double_format (gdbarch)));
13494     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13495                             0, "natural"));
13496     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13497                             0, "positive"));
13498     add (builtin->builtin_void);
13499
13500     struct type *system_addr_ptr
13501       = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13502                                         "void"));
13503     system_addr_ptr->set_name ("system__address");
13504     add (system_addr_ptr);
13505
13506     /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13507        type.  This is a signed integral type whose size is the same as
13508        the size of addresses.  */
13509     unsigned int addr_length = TYPE_LENGTH (system_addr_ptr);
13510     add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13511                             "storage_offset"));
13512
13513     lai->set_bool_type (builtin->builtin_bool);
13514   }
13515
13516   /* See language.h.  */
13517
13518   bool iterate_over_symbols
13519         (const struct block *block, const lookup_name_info &name,
13520          domain_enum domain,
13521          gdb::function_view<symbol_found_callback_ftype> callback) const override
13522   {
13523     std::vector<struct block_symbol> results
13524       = ada_lookup_symbol_list_worker (name, block, domain, 0);
13525     for (block_symbol &sym : results)
13526       {
13527         if (!callback (&sym))
13528           return false;
13529       }
13530
13531     return true;
13532   }
13533
13534   /* See language.h.  */
13535   bool sniff_from_mangled_name
13536        (const char *mangled,
13537         gdb::unique_xmalloc_ptr<char> *out) const override
13538   {
13539     std::string demangled = ada_decode (mangled);
13540
13541     *out = NULL;
13542
13543     if (demangled != mangled && demangled[0] != '<')
13544       {
13545         /* Set the gsymbol language to Ada, but still return 0.
13546            Two reasons for that:
13547
13548            1. For Ada, we prefer computing the symbol's decoded name
13549            on the fly rather than pre-compute it, in order to save
13550            memory (Ada projects are typically very large).
13551
13552            2. There are some areas in the definition of the GNAT
13553            encoding where, with a bit of bad luck, we might be able
13554            to decode a non-Ada symbol, generating an incorrect
13555            demangled name (Eg: names ending with "TB" for instance
13556            are identified as task bodies and so stripped from
13557            the decoded name returned).
13558
13559            Returning true, here, but not setting *DEMANGLED, helps us get
13560            a little bit of the best of both worlds.  Because we're last,
13561            we should not affect any of the other languages that were
13562            able to demangle the symbol before us; we get to correctly
13563            tag Ada symbols as such; and even if we incorrectly tagged a
13564            non-Ada symbol, which should be rare, any routing through the
13565            Ada language should be transparent (Ada tries to behave much
13566            like C/C++ with non-Ada symbols).  */
13567         return true;
13568       }
13569
13570     return false;
13571   }
13572
13573   /* See language.h.  */
13574
13575   gdb::unique_xmalloc_ptr<char> demangle_symbol (const char *mangled,
13576                                                  int options) const override
13577   {
13578     return make_unique_xstrdup (ada_decode (mangled).c_str ());
13579   }
13580
13581   /* See language.h.  */
13582
13583   void print_type (struct type *type, const char *varstring,
13584                    struct ui_file *stream, int show, int level,
13585                    const struct type_print_options *flags) const override
13586   {
13587     ada_print_type (type, varstring, stream, show, level, flags);
13588   }
13589
13590   /* See language.h.  */
13591
13592   const char *word_break_characters (void) const override
13593   {
13594     return ada_completer_word_break_characters;
13595   }
13596
13597   /* See language.h.  */
13598
13599   void collect_symbol_completion_matches (completion_tracker &tracker,
13600                                           complete_symbol_mode mode,
13601                                           symbol_name_match_type name_match_type,
13602                                           const char *text, const char *word,
13603                                           enum type_code code) const override
13604   {
13605     struct symbol *sym;
13606     const struct block *b, *surrounding_static_block = 0;
13607     struct block_iterator iter;
13608
13609     gdb_assert (code == TYPE_CODE_UNDEF);
13610
13611     lookup_name_info lookup_name (text, name_match_type, true);
13612
13613     /* First, look at the partial symtab symbols.  */
13614     expand_symtabs_matching (NULL,
13615                              lookup_name,
13616                              NULL,
13617                              NULL,
13618                              SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13619                              ALL_DOMAIN);
13620
13621     /* At this point scan through the misc symbol vectors and add each
13622        symbol you find to the list.  Eventually we want to ignore
13623        anything that isn't a text symbol (everything else will be
13624        handled by the psymtab code above).  */
13625
13626     for (objfile *objfile : current_program_space->objfiles ())
13627       {
13628         for (minimal_symbol *msymbol : objfile->msymbols ())
13629           {
13630             QUIT;
13631
13632             if (completion_skip_symbol (mode, msymbol))
13633               continue;
13634
13635             language symbol_language = msymbol->language ();
13636
13637             /* Ada minimal symbols won't have their language set to Ada.  If
13638                we let completion_list_add_name compare using the
13639                default/C-like matcher, then when completing e.g., symbols in a
13640                package named "pck", we'd match internal Ada symbols like
13641                "pckS", which are invalid in an Ada expression, unless you wrap
13642                them in '<' '>' to request a verbatim match.
13643
13644                Unfortunately, some Ada encoded names successfully demangle as
13645                C++ symbols (using an old mangling scheme), such as "name__2Xn"
13646                -> "Xn::name(void)" and thus some Ada minimal symbols end up
13647                with the wrong language set.  Paper over that issue here.  */
13648             if (symbol_language == language_auto
13649                 || symbol_language == language_cplus)
13650               symbol_language = language_ada;
13651
13652             completion_list_add_name (tracker,
13653                                       symbol_language,
13654                                       msymbol->linkage_name (),
13655                                       lookup_name, text, word);
13656           }
13657       }
13658
13659     /* Search upwards from currently selected frame (so that we can
13660        complete on local vars.  */
13661
13662     for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
13663       {
13664         if (!BLOCK_SUPERBLOCK (b))
13665           surrounding_static_block = b;   /* For elmin of dups */
13666
13667         ALL_BLOCK_SYMBOLS (b, iter, sym)
13668           {
13669             if (completion_skip_symbol (mode, sym))
13670               continue;
13671
13672             completion_list_add_name (tracker,
13673                                       sym->language (),
13674                                       sym->linkage_name (),
13675                                       lookup_name, text, word);
13676           }
13677       }
13678
13679     /* Go through the symtabs and check the externs and statics for
13680        symbols which match.  */
13681
13682     for (objfile *objfile : current_program_space->objfiles ())
13683       {
13684         for (compunit_symtab *s : objfile->compunits ())
13685           {
13686             QUIT;
13687             b = BLOCKVECTOR_BLOCK (s->blockvector (), GLOBAL_BLOCK);
13688             ALL_BLOCK_SYMBOLS (b, iter, sym)
13689               {
13690                 if (completion_skip_symbol (mode, sym))
13691                   continue;
13692
13693                 completion_list_add_name (tracker,
13694                                           sym->language (),
13695                                           sym->linkage_name (),
13696                                           lookup_name, text, word);
13697               }
13698           }
13699       }
13700
13701     for (objfile *objfile : current_program_space->objfiles ())
13702       {
13703         for (compunit_symtab *s : objfile->compunits ())
13704           {
13705             QUIT;
13706             b = BLOCKVECTOR_BLOCK (s->blockvector (), STATIC_BLOCK);
13707             /* Don't do this block twice.  */
13708             if (b == surrounding_static_block)
13709               continue;
13710             ALL_BLOCK_SYMBOLS (b, iter, sym)
13711               {
13712                 if (completion_skip_symbol (mode, sym))
13713                   continue;
13714
13715                 completion_list_add_name (tracker,
13716                                           sym->language (),
13717                                           sym->linkage_name (),
13718                                           lookup_name, text, word);
13719               }
13720           }
13721       }
13722   }
13723
13724   /* See language.h.  */
13725
13726   gdb::unique_xmalloc_ptr<char> watch_location_expression
13727         (struct type *type, CORE_ADDR addr) const override
13728   {
13729     type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
13730     std::string name = type_to_string (type);
13731     return xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr));
13732   }
13733
13734   /* See language.h.  */
13735
13736   void value_print (struct value *val, struct ui_file *stream,
13737                     const struct value_print_options *options) const override
13738   {
13739     return ada_value_print (val, stream, options);
13740   }
13741
13742   /* See language.h.  */
13743
13744   void value_print_inner
13745         (struct value *val, struct ui_file *stream, int recurse,
13746          const struct value_print_options *options) const override
13747   {
13748     return ada_value_print_inner (val, stream, recurse, options);
13749   }
13750
13751   /* See language.h.  */
13752
13753   struct block_symbol lookup_symbol_nonlocal
13754         (const char *name, const struct block *block,
13755          const domain_enum domain) const override
13756   {
13757     struct block_symbol sym;
13758
13759     sym = ada_lookup_symbol (name, block_static_block (block), domain);
13760     if (sym.symbol != NULL)
13761       return sym;
13762
13763     /* If we haven't found a match at this point, try the primitive
13764        types.  In other languages, this search is performed before
13765        searching for global symbols in order to short-circuit that
13766        global-symbol search if it happens that the name corresponds
13767        to a primitive type.  But we cannot do the same in Ada, because
13768        it is perfectly legitimate for a program to declare a type which
13769        has the same name as a standard type.  If looking up a type in
13770        that situation, we have traditionally ignored the primitive type
13771        in favor of user-defined types.  This is why, unlike most other
13772        languages, we search the primitive types this late and only after
13773        having searched the global symbols without success.  */
13774
13775     if (domain == VAR_DOMAIN)
13776       {
13777         struct gdbarch *gdbarch;
13778
13779         if (block == NULL)
13780           gdbarch = target_gdbarch ();
13781         else
13782           gdbarch = block_gdbarch (block);
13783         sym.symbol
13784           = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13785         if (sym.symbol != NULL)
13786           return sym;
13787       }
13788
13789     return {};
13790   }
13791
13792   /* See language.h.  */
13793
13794   int parser (struct parser_state *ps) const override
13795   {
13796     warnings_issued = 0;
13797     return ada_parse (ps);
13798   }
13799
13800   /* See language.h.  */
13801
13802   void emitchar (int ch, struct type *chtype,
13803                  struct ui_file *stream, int quoter) const override
13804   {
13805     ada_emit_char (ch, chtype, stream, quoter, 1);
13806   }
13807
13808   /* See language.h.  */
13809
13810   void printchar (int ch, struct type *chtype,
13811                   struct ui_file *stream) const override
13812   {
13813     ada_printchar (ch, chtype, stream);
13814   }
13815
13816   /* See language.h.  */
13817
13818   void printstr (struct ui_file *stream, struct type *elttype,
13819                  const gdb_byte *string, unsigned int length,
13820                  const char *encoding, int force_ellipses,
13821                  const struct value_print_options *options) const override
13822   {
13823     ada_printstr (stream, elttype, string, length, encoding,
13824                   force_ellipses, options);
13825   }
13826
13827   /* See language.h.  */
13828
13829   void print_typedef (struct type *type, struct symbol *new_symbol,
13830                       struct ui_file *stream) const override
13831   {
13832     ada_print_typedef (type, new_symbol, stream);
13833   }
13834
13835   /* See language.h.  */
13836
13837   bool is_string_type_p (struct type *type) const override
13838   {
13839     return ada_is_string_type (type);
13840   }
13841
13842   /* See language.h.  */
13843
13844   const char *struct_too_deep_ellipsis () const override
13845   { return "(...)"; }
13846
13847   /* See language.h.  */
13848
13849   bool c_style_arrays_p () const override
13850   { return false; }
13851
13852   /* See language.h.  */
13853
13854   bool store_sym_names_in_linkage_form_p () const override
13855   { return true; }
13856
13857   /* See language.h.  */
13858
13859   const struct lang_varobj_ops *varobj_ops () const override
13860   { return &ada_varobj_ops; }
13861
13862 protected:
13863   /* See language.h.  */
13864
13865   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13866         (const lookup_name_info &lookup_name) const override
13867   {
13868     return ada_get_symbol_name_matcher (lookup_name);
13869   }
13870 };
13871
13872 /* Single instance of the Ada language class.  */
13873
13874 static ada_language ada_language_defn;
13875
13876 /* Command-list for the "set/show ada" prefix command.  */
13877 static struct cmd_list_element *set_ada_list;
13878 static struct cmd_list_element *show_ada_list;
13879
13880 static void
13881 initialize_ada_catchpoint_ops (void)
13882 {
13883   struct breakpoint_ops *ops;
13884
13885   initialize_breakpoint_ops ();
13886
13887   ops = &catch_exception_breakpoint_ops;
13888   *ops = bkpt_breakpoint_ops;
13889   ops->allocate_location = allocate_location_exception;
13890   ops->re_set = re_set_exception;
13891   ops->check_status = check_status_exception;
13892   ops->print_it = print_it_exception;
13893   ops->print_one = print_one_exception;
13894   ops->print_mention = print_mention_exception;
13895   ops->print_recreate = print_recreate_exception;
13896 }
13897
13898 /* This module's 'new_objfile' observer.  */
13899
13900 static void
13901 ada_new_objfile_observer (struct objfile *objfile)
13902 {
13903   ada_clear_symbol_cache ();
13904 }
13905
13906 /* This module's 'free_objfile' observer.  */
13907
13908 static void
13909 ada_free_objfile_observer (struct objfile *objfile)
13910 {
13911   ada_clear_symbol_cache ();
13912 }
13913
13914 /* Charsets known to GNAT.  */
13915 static const char * const gnat_source_charsets[] =
13916 {
13917   /* Note that code below assumes that the default comes first.
13918      Latin-1 is the default here, because that is also GNAT's
13919      default.  */
13920   "ISO-8859-1",
13921   "ISO-8859-2",
13922   "ISO-8859-3",
13923   "ISO-8859-4",
13924   "ISO-8859-5",
13925   "ISO-8859-15",
13926   "CP437",
13927   "CP850",
13928   /* Note that this value is special-cased in the encoder and
13929      decoder.  */
13930   ada_utf8,
13931   nullptr
13932 };
13933
13934 void _initialize_ada_language ();
13935 void
13936 _initialize_ada_language ()
13937 {
13938   initialize_ada_catchpoint_ops ();
13939
13940   add_setshow_prefix_cmd
13941     ("ada", no_class,
13942      _("Prefix command for changing Ada-specific settings."),
13943      _("Generic command for showing Ada-specific settings."),
13944      &set_ada_list, &show_ada_list,
13945      &setlist, &showlist);
13946
13947   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13948                            &trust_pad_over_xvs, _("\
13949 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13950 Show whether an optimization trusting PAD types over XVS types is activated."),
13951                            _("\
13952 This is related to the encoding used by the GNAT compiler.  The debugger\n\
13953 should normally trust the contents of PAD types, but certain older versions\n\
13954 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13955 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
13956 work around this bug.  It is always safe to turn this option \"off\", but\n\
13957 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13958 this option to \"off\" unless necessary."),
13959                             NULL, NULL, &set_ada_list, &show_ada_list);
13960
13961   add_setshow_boolean_cmd ("print-signatures", class_vars,
13962                            &print_signatures, _("\
13963 Enable or disable the output of formal and return types for functions in the \
13964 overloads selection menu."), _("\
13965 Show whether the output of formal and return types for functions in the \
13966 overloads selection menu is activated."),
13967                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
13968
13969   ada_source_charset = gnat_source_charsets[0];
13970   add_setshow_enum_cmd ("source-charset", class_files,
13971                         gnat_source_charsets,
13972                         &ada_source_charset,  _("\
13973 Set the Ada source character set."), _("\
13974 Show the Ada source character set."), _("\
13975 The character set used for Ada source files.\n\
13976 This must correspond to the '-gnati' or '-gnatW' option passed to GNAT."),
13977                         nullptr, nullptr,
13978                         &set_ada_list, &show_ada_list);
13979
13980   add_catch_command ("exception", _("\
13981 Catch Ada exceptions, when raised.\n\
13982 Usage: catch exception [ARG] [if CONDITION]\n\
13983 Without any argument, stop when any Ada exception is raised.\n\
13984 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
13985 being raised does not have a handler (and will therefore lead to the task's\n\
13986 termination).\n\
13987 Otherwise, the catchpoint only stops when the name of the exception being\n\
13988 raised is the same as ARG.\n\
13989 CONDITION is a boolean expression that is evaluated to see whether the\n\
13990 exception should cause a stop."),
13991                      catch_ada_exception_command,
13992                      catch_ada_completer,
13993                      CATCH_PERMANENT,
13994                      CATCH_TEMPORARY);
13995
13996   add_catch_command ("handlers", _("\
13997 Catch Ada exceptions, when handled.\n\
13998 Usage: catch handlers [ARG] [if CONDITION]\n\
13999 Without any argument, stop when any Ada exception is handled.\n\
14000 With an argument, catch only exceptions with the given name.\n\
14001 CONDITION is a boolean expression that is evaluated to see whether the\n\
14002 exception should cause a stop."),
14003                      catch_ada_handlers_command,
14004                      catch_ada_completer,
14005                      CATCH_PERMANENT,
14006                      CATCH_TEMPORARY);
14007   add_catch_command ("assert", _("\
14008 Catch failed Ada assertions, when raised.\n\
14009 Usage: catch assert [if CONDITION]\n\
14010 CONDITION is a boolean expression that is evaluated to see whether the\n\
14011 exception should cause a stop."),
14012                      catch_assert_command,
14013                      NULL,
14014                      CATCH_PERMANENT,
14015                      CATCH_TEMPORARY);
14016
14017   add_info ("exceptions", info_exceptions_command,
14018             _("\
14019 List all Ada exception names.\n\
14020 Usage: info exceptions [REGEXP]\n\
14021 If a regular expression is passed as an argument, only those matching\n\
14022 the regular expression are listed."));
14023
14024   add_setshow_prefix_cmd ("ada", class_maintenance,
14025                           _("Set Ada maintenance-related variables."),
14026                           _("Show Ada maintenance-related variables."),
14027                           &maint_set_ada_cmdlist, &maint_show_ada_cmdlist,
14028                           &maintenance_set_cmdlist, &maintenance_show_cmdlist);
14029
14030   add_setshow_boolean_cmd
14031     ("ignore-descriptive-types", class_maintenance,
14032      &ada_ignore_descriptive_types_p,
14033      _("Set whether descriptive types generated by GNAT should be ignored."),
14034      _("Show whether descriptive types generated by GNAT should be ignored."),
14035      _("\
14036 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14037 DWARF attribute."),
14038      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14039
14040   decoded_names_store = htab_create_alloc (256, htab_hash_string,
14041                                            htab_eq_string,
14042                                            NULL, xcalloc, xfree);
14043
14044   /* The ada-lang observers.  */
14045   gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
14046   gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
14047   gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");
14048 }
This page took 0.825566 seconds and 4 git commands to generate.