]> Git Repo - binutils.git/blob - gdb/ada-lang.c
Defer Ada character literal resolution
[binutils.git] / gdb / ada-lang.c
1 /* Ada language support routines for GDB, the GNU debugger.
2
3    Copyright (C) 1992-2021 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 "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 "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
63 /* Define whether or not the C operator '/' truncates towards zero for
64    differently signed operands (truncation direction is undefined in C).
65    Copied from valarith.c.  */
66
67 #ifndef TRUNCATION_TOWARDS_ZERO
68 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
69 #endif
70
71 static struct type *desc_base_type (struct type *);
72
73 static struct type *desc_bounds_type (struct type *);
74
75 static struct value *desc_bounds (struct value *);
76
77 static int fat_pntr_bounds_bitpos (struct type *);
78
79 static int fat_pntr_bounds_bitsize (struct type *);
80
81 static struct type *desc_data_target_type (struct type *);
82
83 static struct value *desc_data (struct value *);
84
85 static int fat_pntr_data_bitpos (struct type *);
86
87 static int fat_pntr_data_bitsize (struct type *);
88
89 static struct value *desc_one_bound (struct value *, int, int);
90
91 static int desc_bound_bitpos (struct type *, int, int);
92
93 static int desc_bound_bitsize (struct type *, int, int);
94
95 static struct type *desc_index_type (struct type *, int);
96
97 static int desc_arity (struct type *);
98
99 static int ada_args_match (struct symbol *, struct value **, int);
100
101 static struct value *make_array_descriptor (struct type *, struct value *);
102
103 static void ada_add_block_symbols (std::vector<struct block_symbol> &,
104                                    const struct block *,
105                                    const lookup_name_info &lookup_name,
106                                    domain_enum, struct objfile *);
107
108 static void ada_add_all_symbols (std::vector<struct block_symbol> &,
109                                  const struct block *,
110                                  const lookup_name_info &lookup_name,
111                                  domain_enum, int, int *);
112
113 static int is_nonfunction (const std::vector<struct block_symbol> &);
114
115 static void add_defn_to_vec (std::vector<struct block_symbol> &,
116                              struct symbol *,
117                              const struct block *);
118
119 static int possible_user_operator_p (enum exp_opcode, struct value **);
120
121 static const char *ada_decoded_op_name (enum exp_opcode);
122
123 static int numeric_type_p (struct type *);
124
125 static int integer_type_p (struct type *);
126
127 static int scalar_type_p (struct type *);
128
129 static int discrete_type_p (struct type *);
130
131 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
132                                                 int, int);
133
134 static struct type *ada_find_parallel_type_with_name (struct type *,
135                                                       const char *);
136
137 static int is_dynamic_field (struct type *, int);
138
139 static struct type *to_fixed_variant_branch_type (struct type *,
140                                                   const gdb_byte *,
141                                                   CORE_ADDR, struct value *);
142
143 static struct type *to_fixed_array_type (struct type *, struct value *, int);
144
145 static struct type *to_fixed_range_type (struct type *, struct value *);
146
147 static struct type *to_static_fixed_type (struct type *);
148 static struct type *static_unwrap_type (struct type *type);
149
150 static struct value *unwrap_value (struct value *);
151
152 static struct type *constrained_packed_array_type (struct type *, long *);
153
154 static struct type *decode_constrained_packed_array_type (struct type *);
155
156 static long decode_packed_array_bitsize (struct type *);
157
158 static struct value *decode_constrained_packed_array (struct value *);
159
160 static int ada_is_unconstrained_packed_array_type (struct type *);
161
162 static struct value *value_subscript_packed (struct value *, int,
163                                              struct value **);
164
165 static struct value *coerce_unspec_val_to_type (struct value *,
166                                                 struct type *);
167
168 static int lesseq_defined_than (struct symbol *, struct symbol *);
169
170 static int equiv_types (struct type *, struct type *);
171
172 static int is_name_suffix (const char *);
173
174 static int advance_wild_match (const char **, const char *, char);
175
176 static bool wild_match (const char *name, const char *patn);
177
178 static struct value *ada_coerce_ref (struct value *);
179
180 static LONGEST pos_atr (struct value *);
181
182 static struct value *val_atr (struct type *, LONGEST);
183
184 static struct symbol *standard_lookup (const char *, const struct block *,
185                                        domain_enum);
186
187 static struct value *ada_search_struct_field (const char *, struct value *, int,
188                                               struct type *);
189
190 static int find_struct_field (const char *, struct type *, int,
191                               struct type **, int *, int *, int *, int *);
192
193 static int ada_resolve_function (std::vector<struct block_symbol> &,
194                                  struct value **, int, const char *,
195                                  struct type *, bool);
196
197 static int ada_is_direct_array_type (struct type *);
198
199 static struct value *ada_index_struct_field (int, struct value *, int,
200                                              struct type *);
201
202 static void add_component_interval (LONGEST, LONGEST, std::vector<LONGEST> &);
203
204
205 static struct type *ada_find_any_type (const char *name);
206
207 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
208   (const lookup_name_info &lookup_name);
209
210 \f
211
212 /* The result of a symbol lookup to be stored in our symbol cache.  */
213
214 struct cache_entry
215 {
216   /* The name used to perform the lookup.  */
217   const char *name;
218   /* The namespace used during the lookup.  */
219   domain_enum domain;
220   /* The symbol returned by the lookup, or NULL if no matching symbol
221      was found.  */
222   struct symbol *sym;
223   /* The block where the symbol was found, or NULL if no matching
224      symbol was found.  */
225   const struct block *block;
226   /* A pointer to the next entry with the same hash.  */
227   struct cache_entry *next;
228 };
229
230 /* The Ada symbol cache, used to store the result of Ada-mode symbol
231    lookups in the course of executing the user's commands.
232
233    The cache is implemented using a simple, fixed-sized hash.
234    The size is fixed on the grounds that there are not likely to be
235    all that many symbols looked up during any given session, regardless
236    of the size of the symbol table.  If we decide to go to a resizable
237    table, let's just use the stuff from libiberty instead.  */
238
239 #define HASH_SIZE 1009
240
241 struct ada_symbol_cache
242 {
243   /* An obstack used to store the entries in our cache.  */
244   struct auto_obstack cache_space;
245
246   /* The root of the hash table used to implement our symbol cache.  */
247   struct cache_entry *root[HASH_SIZE] {};
248 };
249
250 /* Maximum-sized dynamic type.  */
251 static unsigned int varsize_limit;
252
253 static const char ada_completer_word_break_characters[] =
254 #ifdef VMS
255   " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
256 #else
257   " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
258 #endif
259
260 /* The name of the symbol to use to get the name of the main subprogram.  */
261 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
262   = "__gnat_ada_main_program_name";
263
264 /* Limit on the number of warnings to raise per expression evaluation.  */
265 static int warning_limit = 2;
266
267 /* Number of warning messages issued; reset to 0 by cleanups after
268    expression evaluation.  */
269 static int warnings_issued = 0;
270
271 static const char * const known_runtime_file_name_patterns[] = {
272   ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
273 };
274
275 static const char * const known_auxiliary_function_name_patterns[] = {
276   ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
277 };
278
279 /* Maintenance-related settings for this module.  */
280
281 static struct cmd_list_element *maint_set_ada_cmdlist;
282 static struct cmd_list_element *maint_show_ada_cmdlist;
283
284 /* The "maintenance ada set/show ignore-descriptive-type" value.  */
285
286 static bool ada_ignore_descriptive_types_p = false;
287
288                         /* Inferior-specific data.  */
289
290 /* Per-inferior data for this module.  */
291
292 struct ada_inferior_data
293 {
294   /* The ada__tags__type_specific_data type, which is used when decoding
295      tagged types.  With older versions of GNAT, this type was directly
296      accessible through a component ("tsd") in the object tag.  But this
297      is no longer the case, so we cache it for each inferior.  */
298   struct type *tsd_type = nullptr;
299
300   /* The exception_support_info data.  This data is used to determine
301      how to implement support for Ada exception catchpoints in a given
302      inferior.  */
303   const struct exception_support_info *exception_info = nullptr;
304 };
305
306 /* Our key to this module's inferior data.  */
307 static const struct inferior_key<ada_inferior_data> ada_inferior_data;
308
309 /* Return our inferior data for the given inferior (INF).
310
311    This function always returns a valid pointer to an allocated
312    ada_inferior_data structure.  If INF's inferior data has not
313    been previously set, this functions creates a new one with all
314    fields set to zero, sets INF's inferior to it, and then returns
315    a pointer to that newly allocated ada_inferior_data.  */
316
317 static struct ada_inferior_data *
318 get_ada_inferior_data (struct inferior *inf)
319 {
320   struct ada_inferior_data *data;
321
322   data = ada_inferior_data.get (inf);
323   if (data == NULL)
324     data = ada_inferior_data.emplace (inf);
325
326   return data;
327 }
328
329 /* Perform all necessary cleanups regarding our module's inferior data
330    that is required after the inferior INF just exited.  */
331
332 static void
333 ada_inferior_exit (struct inferior *inf)
334 {
335   ada_inferior_data.clear (inf);
336 }
337
338
339                         /* program-space-specific data.  */
340
341 /* This module's per-program-space data.  */
342 struct ada_pspace_data
343 {
344   /* The Ada symbol cache.  */
345   std::unique_ptr<ada_symbol_cache> sym_cache;
346 };
347
348 /* Key to our per-program-space data.  */
349 static const struct program_space_key<ada_pspace_data> ada_pspace_data_handle;
350
351 /* Return this module's data for the given program space (PSPACE).
352    If not is found, add a zero'ed one now.
353
354    This function always returns a valid object.  */
355
356 static struct ada_pspace_data *
357 get_ada_pspace_data (struct program_space *pspace)
358 {
359   struct ada_pspace_data *data;
360
361   data = ada_pspace_data_handle.get (pspace);
362   if (data == NULL)
363     data = ada_pspace_data_handle.emplace (pspace);
364
365   return data;
366 }
367
368                         /* Utilities */
369
370 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
371    all typedef layers have been peeled.  Otherwise, return TYPE.
372
373    Normally, we really expect a typedef type to only have 1 typedef layer.
374    In other words, we really expect the target type of a typedef type to be
375    a non-typedef type.  This is particularly true for Ada units, because
376    the language does not have a typedef vs not-typedef distinction.
377    In that respect, the Ada compiler has been trying to eliminate as many
378    typedef definitions in the debugging information, since they generally
379    do not bring any extra information (we still use typedef under certain
380    circumstances related mostly to the GNAT encoding).
381
382    Unfortunately, we have seen situations where the debugging information
383    generated by the compiler leads to such multiple typedef layers.  For
384    instance, consider the following example with stabs:
385
386      .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
387      .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
388
389    This is an error in the debugging information which causes type
390    pck__float_array___XUP to be defined twice, and the second time,
391    it is defined as a typedef of a typedef.
392
393    This is on the fringe of legality as far as debugging information is
394    concerned, and certainly unexpected.  But it is easy to handle these
395    situations correctly, so we can afford to be lenient in this case.  */
396
397 static struct type *
398 ada_typedef_target_type (struct type *type)
399 {
400   while (type->code () == TYPE_CODE_TYPEDEF)
401     type = TYPE_TARGET_TYPE (type);
402   return type;
403 }
404
405 /* Given DECODED_NAME a string holding a symbol name in its
406    decoded form (ie using the Ada dotted notation), returns
407    its unqualified name.  */
408
409 static const char *
410 ada_unqualified_name (const char *decoded_name)
411 {
412   const char *result;
413   
414   /* If the decoded name starts with '<', it means that the encoded
415      name does not follow standard naming conventions, and thus that
416      it is not your typical Ada symbol name.  Trying to unqualify it
417      is therefore pointless and possibly erroneous.  */
418   if (decoded_name[0] == '<')
419     return decoded_name;
420
421   result = strrchr (decoded_name, '.');
422   if (result != NULL)
423     result++;                   /* Skip the dot...  */
424   else
425     result = decoded_name;
426
427   return result;
428 }
429
430 /* Return a string starting with '<', followed by STR, and '>'.  */
431
432 static std::string
433 add_angle_brackets (const char *str)
434 {
435   return string_printf ("<%s>", str);
436 }
437
438 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
439    suffix of FIELD_NAME beginning "___".  */
440
441 static int
442 field_name_match (const char *field_name, const char *target)
443 {
444   int len = strlen (target);
445
446   return
447     (strncmp (field_name, target, len) == 0
448      && (field_name[len] == '\0'
449          || (startswith (field_name + len, "___")
450              && strcmp (field_name + strlen (field_name) - 6,
451                         "___XVN") != 0)));
452 }
453
454
455 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
456    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
457    and return its index.  This function also handles fields whose name
458    have ___ suffixes because the compiler sometimes alters their name
459    by adding such a suffix to represent fields with certain constraints.
460    If the field could not be found, return a negative number if
461    MAYBE_MISSING is set.  Otherwise raise an error.  */
462
463 int
464 ada_get_field_index (const struct type *type, const char *field_name,
465                      int maybe_missing)
466 {
467   int fieldno;
468   struct type *struct_type = check_typedef ((struct type *) type);
469
470   for (fieldno = 0; fieldno < struct_type->num_fields (); fieldno++)
471     if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
472       return fieldno;
473
474   if (!maybe_missing)
475     error (_("Unable to find field %s in struct %s.  Aborting"),
476            field_name, struct_type->name ());
477
478   return -1;
479 }
480
481 /* The length of the prefix of NAME prior to any "___" suffix.  */
482
483 int
484 ada_name_prefix_len (const char *name)
485 {
486   if (name == NULL)
487     return 0;
488   else
489     {
490       const char *p = strstr (name, "___");
491
492       if (p == NULL)
493         return strlen (name);
494       else
495         return p - name;
496     }
497 }
498
499 /* Return non-zero if SUFFIX is a suffix of STR.
500    Return zero if STR is null.  */
501
502 static int
503 is_suffix (const char *str, const char *suffix)
504 {
505   int len1, len2;
506
507   if (str == NULL)
508     return 0;
509   len1 = strlen (str);
510   len2 = strlen (suffix);
511   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
512 }
513
514 /* The contents of value VAL, treated as a value of type TYPE.  The
515    result is an lval in memory if VAL is.  */
516
517 static struct value *
518 coerce_unspec_val_to_type (struct value *val, struct type *type)
519 {
520   type = ada_check_typedef (type);
521   if (value_type (val) == type)
522     return val;
523   else
524     {
525       struct value *result;
526
527       /* Make sure that the object size is not unreasonable before
528          trying to allocate some memory for it.  */
529       ada_ensure_varsize_limit (type);
530
531       if (value_optimized_out (val))
532         result = allocate_optimized_out_value (type);
533       else if (value_lazy (val)
534                /* Be careful not to make a lazy not_lval value.  */
535                || (VALUE_LVAL (val) != not_lval
536                    && TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val))))
537         result = allocate_value_lazy (type);
538       else
539         {
540           result = allocate_value (type);
541           value_contents_copy (result, 0, val, 0, TYPE_LENGTH (type));
542         }
543       set_value_component_location (result, val);
544       set_value_bitsize (result, value_bitsize (val));
545       set_value_bitpos (result, value_bitpos (val));
546       if (VALUE_LVAL (result) == lval_memory)
547         set_value_address (result, value_address (val));
548       return result;
549     }
550 }
551
552 static const gdb_byte *
553 cond_offset_host (const gdb_byte *valaddr, long offset)
554 {
555   if (valaddr == NULL)
556     return NULL;
557   else
558     return valaddr + offset;
559 }
560
561 static CORE_ADDR
562 cond_offset_target (CORE_ADDR address, long offset)
563 {
564   if (address == 0)
565     return 0;
566   else
567     return address + offset;
568 }
569
570 /* Issue a warning (as for the definition of warning in utils.c, but
571    with exactly one argument rather than ...), unless the limit on the
572    number of warnings has passed during the evaluation of the current
573    expression.  */
574
575 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
576    provided by "complaint".  */
577 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
578
579 static void
580 lim_warning (const char *format, ...)
581 {
582   va_list args;
583
584   va_start (args, format);
585   warnings_issued += 1;
586   if (warnings_issued <= warning_limit)
587     vwarning (format, args);
588
589   va_end (args);
590 }
591
592 /* Issue an error if the size of an object of type T is unreasonable,
593    i.e. if it would be a bad idea to allocate a value of this type in
594    GDB.  */
595
596 void
597 ada_ensure_varsize_limit (const struct type *type)
598 {
599   if (TYPE_LENGTH (type) > varsize_limit)
600     error (_("object size is larger than varsize-limit"));
601 }
602
603 /* Maximum value of a SIZE-byte signed integer type.  */
604 static LONGEST
605 max_of_size (int size)
606 {
607   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
608
609   return top_bit | (top_bit - 1);
610 }
611
612 /* Minimum value of a SIZE-byte signed integer type.  */
613 static LONGEST
614 min_of_size (int size)
615 {
616   return -max_of_size (size) - 1;
617 }
618
619 /* Maximum value of a SIZE-byte unsigned integer type.  */
620 static ULONGEST
621 umax_of_size (int size)
622 {
623   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
624
625   return top_bit | (top_bit - 1);
626 }
627
628 /* Maximum value of integral type T, as a signed quantity.  */
629 static LONGEST
630 max_of_type (struct type *t)
631 {
632   if (t->is_unsigned ())
633     return (LONGEST) umax_of_size (TYPE_LENGTH (t));
634   else
635     return max_of_size (TYPE_LENGTH (t));
636 }
637
638 /* Minimum value of integral type T, as a signed quantity.  */
639 static LONGEST
640 min_of_type (struct type *t)
641 {
642   if (t->is_unsigned ())
643     return 0;
644   else
645     return min_of_size (TYPE_LENGTH (t));
646 }
647
648 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
649 LONGEST
650 ada_discrete_type_high_bound (struct type *type)
651 {
652   type = resolve_dynamic_type (type, {}, 0);
653   switch (type->code ())
654     {
655     case TYPE_CODE_RANGE:
656       {
657         const dynamic_prop &high = type->bounds ()->high;
658
659         if (high.kind () == PROP_CONST)
660           return high.const_val ();
661         else
662           {
663             gdb_assert (high.kind () == PROP_UNDEFINED);
664
665             /* This happens when trying to evaluate a type's dynamic bound
666                without a live target.  There is nothing relevant for us to
667                return here, so return 0.  */
668             return 0;
669           }
670       }
671     case TYPE_CODE_ENUM:
672       return TYPE_FIELD_ENUMVAL (type, type->num_fields () - 1);
673     case TYPE_CODE_BOOL:
674       return 1;
675     case TYPE_CODE_CHAR:
676     case TYPE_CODE_INT:
677       return max_of_type (type);
678     default:
679       error (_("Unexpected type in ada_discrete_type_high_bound."));
680     }
681 }
682
683 /* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
684 LONGEST
685 ada_discrete_type_low_bound (struct type *type)
686 {
687   type = resolve_dynamic_type (type, {}, 0);
688   switch (type->code ())
689     {
690     case TYPE_CODE_RANGE:
691       {
692         const dynamic_prop &low = type->bounds ()->low;
693
694         if (low.kind () == PROP_CONST)
695           return low.const_val ();
696         else
697           {
698             gdb_assert (low.kind () == PROP_UNDEFINED);
699
700             /* This happens when trying to evaluate a type's dynamic bound
701                without a live target.  There is nothing relevant for us to
702                return here, so return 0.  */
703             return 0;
704           }
705       }
706     case TYPE_CODE_ENUM:
707       return TYPE_FIELD_ENUMVAL (type, 0);
708     case TYPE_CODE_BOOL:
709       return 0;
710     case TYPE_CODE_CHAR:
711     case TYPE_CODE_INT:
712       return min_of_type (type);
713     default:
714       error (_("Unexpected type in ada_discrete_type_low_bound."));
715     }
716 }
717
718 /* The identity on non-range types.  For range types, the underlying
719    non-range scalar type.  */
720
721 static struct type *
722 get_base_type (struct type *type)
723 {
724   while (type != NULL && type->code () == TYPE_CODE_RANGE)
725     {
726       if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
727         return type;
728       type = TYPE_TARGET_TYPE (type);
729     }
730   return type;
731 }
732
733 /* Return a decoded version of the given VALUE.  This means returning
734    a value whose type is obtained by applying all the GNAT-specific
735    encodings, making the resulting type a static but standard description
736    of the initial type.  */
737
738 struct value *
739 ada_get_decoded_value (struct value *value)
740 {
741   struct type *type = ada_check_typedef (value_type (value));
742
743   if (ada_is_array_descriptor_type (type)
744       || (ada_is_constrained_packed_array_type (type)
745           && type->code () != TYPE_CODE_PTR))
746     {
747       if (type->code () == TYPE_CODE_TYPEDEF)  /* array access type.  */
748         value = ada_coerce_to_simple_array_ptr (value);
749       else
750         value = ada_coerce_to_simple_array (value);
751     }
752   else
753     value = ada_to_fixed_value (value);
754
755   return value;
756 }
757
758 /* Same as ada_get_decoded_value, but with the given TYPE.
759    Because there is no associated actual value for this type,
760    the resulting type might be a best-effort approximation in
761    the case of dynamic types.  */
762
763 struct type *
764 ada_get_decoded_type (struct type *type)
765 {
766   type = to_static_fixed_type (type);
767   if (ada_is_constrained_packed_array_type (type))
768     type = ada_coerce_to_simple_array_type (type);
769   return type;
770 }
771
772 \f
773
774                                 /* Language Selection */
775
776 /* If the main program is in Ada, return language_ada, otherwise return LANG
777    (the main program is in Ada iif the adainit symbol is found).  */
778
779 static enum language
780 ada_update_initial_language (enum language lang)
781 {
782   if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
783     return language_ada;
784
785   return lang;
786 }
787
788 /* If the main procedure is written in Ada, then return its name.
789    The result is good until the next call.  Return NULL if the main
790    procedure doesn't appear to be in Ada.  */
791
792 char *
793 ada_main_name (void)
794 {
795   struct bound_minimal_symbol msym;
796   static gdb::unique_xmalloc_ptr<char> main_program_name;
797
798   /* For Ada, the name of the main procedure is stored in a specific
799      string constant, generated by the binder.  Look for that symbol,
800      extract its address, and then read that string.  If we didn't find
801      that string, then most probably the main procedure is not written
802      in Ada.  */
803   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
804
805   if (msym.minsym != NULL)
806     {
807       CORE_ADDR main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
808       if (main_program_name_addr == 0)
809         error (_("Invalid address for Ada main program name."));
810
811       main_program_name = target_read_string (main_program_name_addr, 1024);
812       return main_program_name.get ();
813     }
814
815   /* The main procedure doesn't seem to be in Ada.  */
816   return NULL;
817 }
818 \f
819                                 /* Symbols */
820
821 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
822    of NULLs.  */
823
824 const struct ada_opname_map ada_opname_table[] = {
825   {"Oadd", "\"+\"", BINOP_ADD},
826   {"Osubtract", "\"-\"", BINOP_SUB},
827   {"Omultiply", "\"*\"", BINOP_MUL},
828   {"Odivide", "\"/\"", BINOP_DIV},
829   {"Omod", "\"mod\"", BINOP_MOD},
830   {"Orem", "\"rem\"", BINOP_REM},
831   {"Oexpon", "\"**\"", BINOP_EXP},
832   {"Olt", "\"<\"", BINOP_LESS},
833   {"Ole", "\"<=\"", BINOP_LEQ},
834   {"Ogt", "\">\"", BINOP_GTR},
835   {"Oge", "\">=\"", BINOP_GEQ},
836   {"Oeq", "\"=\"", BINOP_EQUAL},
837   {"One", "\"/=\"", BINOP_NOTEQUAL},
838   {"Oand", "\"and\"", BINOP_BITWISE_AND},
839   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
840   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
841   {"Oconcat", "\"&\"", BINOP_CONCAT},
842   {"Oabs", "\"abs\"", UNOP_ABS},
843   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
844   {"Oadd", "\"+\"", UNOP_PLUS},
845   {"Osubtract", "\"-\"", UNOP_NEG},
846   {NULL, NULL}
847 };
848
849 /* The "encoded" form of DECODED, according to GNAT conventions.  If
850    THROW_ERRORS, throw an error if invalid operator name is found.
851    Otherwise, return the empty string in that case.  */
852
853 static std::string
854 ada_encode_1 (const char *decoded, bool throw_errors)
855 {
856   if (decoded == NULL)
857     return {};
858
859   std::string encoding_buffer;
860   for (const char *p = decoded; *p != '\0'; p += 1)
861     {
862       if (*p == '.')
863         encoding_buffer.append ("__");
864       else if (*p == '"')
865         {
866           const struct ada_opname_map *mapping;
867
868           for (mapping = ada_opname_table;
869                mapping->encoded != NULL
870                && !startswith (p, mapping->decoded); mapping += 1)
871             ;
872           if (mapping->encoded == NULL)
873             {
874               if (throw_errors)
875                 error (_("invalid Ada operator name: %s"), p);
876               else
877                 return {};
878             }
879           encoding_buffer.append (mapping->encoded);
880           break;
881         }
882       else
883         encoding_buffer.push_back (*p);
884     }
885
886   return encoding_buffer;
887 }
888
889 /* The "encoded" form of DECODED, according to GNAT conventions.  */
890
891 std::string
892 ada_encode (const char *decoded)
893 {
894   return ada_encode_1 (decoded, true);
895 }
896
897 /* Return NAME folded to lower case, or, if surrounded by single
898    quotes, unfolded, but with the quotes stripped away.  Result good
899    to next call.  */
900
901 static const char *
902 ada_fold_name (gdb::string_view name)
903 {
904   static std::string fold_storage;
905
906   if (!name.empty () && name[0] == '\'')
907     fold_storage = gdb::to_string (name.substr (1, name.size () - 2));
908   else
909     {
910       fold_storage = gdb::to_string (name);
911       for (int i = 0; i < name.size (); i += 1)
912         fold_storage[i] = tolower (fold_storage[i]);
913     }
914
915   return fold_storage.c_str ();
916 }
917
918 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
919
920 static int
921 is_lower_alphanum (const char c)
922 {
923   return (isdigit (c) || (isalpha (c) && islower (c)));
924 }
925
926 /* ENCODED is the linkage name of a symbol and LEN contains its length.
927    This function saves in LEN the length of that same symbol name but
928    without either of these suffixes:
929      . .{DIGIT}+
930      . ${DIGIT}+
931      . ___{DIGIT}+
932      . __{DIGIT}+.
933
934    These are suffixes introduced by the compiler for entities such as
935    nested subprogram for instance, in order to avoid name clashes.
936    They do not serve any purpose for the debugger.  */
937
938 static void
939 ada_remove_trailing_digits (const char *encoded, int *len)
940 {
941   if (*len > 1 && isdigit (encoded[*len - 1]))
942     {
943       int i = *len - 2;
944
945       while (i > 0 && isdigit (encoded[i]))
946         i--;
947       if (i >= 0 && encoded[i] == '.')
948         *len = i;
949       else if (i >= 0 && encoded[i] == '$')
950         *len = i;
951       else if (i >= 2 && startswith (encoded + i - 2, "___"))
952         *len = i - 2;
953       else if (i >= 1 && startswith (encoded + i - 1, "__"))
954         *len = i - 1;
955     }
956 }
957
958 /* Remove the suffix introduced by the compiler for protected object
959    subprograms.  */
960
961 static void
962 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
963 {
964   /* Remove trailing N.  */
965
966   /* Protected entry subprograms are broken into two
967      separate subprograms: The first one is unprotected, and has
968      a 'N' suffix; the second is the protected version, and has
969      the 'P' suffix.  The second calls the first one after handling
970      the protection.  Since the P subprograms are internally generated,
971      we leave these names undecoded, giving the user a clue that this
972      entity is internal.  */
973
974   if (*len > 1
975       && encoded[*len - 1] == 'N'
976       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
977     *len = *len - 1;
978 }
979
980 /* See ada-lang.h.  */
981
982 std::string
983 ada_decode (const char *encoded, bool wrap)
984 {
985   int i, j;
986   int len0;
987   const char *p;
988   int at_start_name;
989   std::string decoded;
990
991   /* With function descriptors on PPC64, the value of a symbol named
992      ".FN", if it exists, is the entry point of the function "FN".  */
993   if (encoded[0] == '.')
994     encoded += 1;
995
996   /* The name of the Ada main procedure starts with "_ada_".
997      This prefix is not part of the decoded name, so skip this part
998      if we see this prefix.  */
999   if (startswith (encoded, "_ada_"))
1000     encoded += 5;
1001
1002   /* If the name starts with '_', then it is not a properly encoded
1003      name, so do not attempt to decode it.  Similarly, if the name
1004      starts with '<', the name should not be decoded.  */
1005   if (encoded[0] == '_' || encoded[0] == '<')
1006     goto Suppress;
1007
1008   len0 = strlen (encoded);
1009
1010   ada_remove_trailing_digits (encoded, &len0);
1011   ada_remove_po_subprogram_suffix (encoded, &len0);
1012
1013   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1014      the suffix is located before the current "end" of ENCODED.  We want
1015      to avoid re-matching parts of ENCODED that have previously been
1016      marked as discarded (by decrementing LEN0).  */
1017   p = strstr (encoded, "___");
1018   if (p != NULL && p - encoded < len0 - 3)
1019     {
1020       if (p[3] == 'X')
1021         len0 = p - encoded;
1022       else
1023         goto Suppress;
1024     }
1025
1026   /* Remove any trailing TKB suffix.  It tells us that this symbol
1027      is for the body of a task, but that information does not actually
1028      appear in the decoded name.  */
1029
1030   if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1031     len0 -= 3;
1032
1033   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1034      from the TKB suffix because it is used for non-anonymous task
1035      bodies.  */
1036
1037   if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1038     len0 -= 2;
1039
1040   /* Remove trailing "B" suffixes.  */
1041   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1042
1043   if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1044     len0 -= 1;
1045
1046   /* Make decoded big enough for possible expansion by operator name.  */
1047
1048   decoded.resize (2 * len0 + 1, 'X');
1049
1050   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1051
1052   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1053     {
1054       i = len0 - 2;
1055       while ((i >= 0 && isdigit (encoded[i]))
1056              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1057         i -= 1;
1058       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1059         len0 = i - 1;
1060       else if (encoded[i] == '$')
1061         len0 = i;
1062     }
1063
1064   /* The first few characters that are not alphabetic are not part
1065      of any encoding we use, so we can copy them over verbatim.  */
1066
1067   for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1068     decoded[j] = encoded[i];
1069
1070   at_start_name = 1;
1071   while (i < len0)
1072     {
1073       /* Is this a symbol function?  */
1074       if (at_start_name && encoded[i] == 'O')
1075         {
1076           int k;
1077
1078           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1079             {
1080               int op_len = strlen (ada_opname_table[k].encoded);
1081               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1082                             op_len - 1) == 0)
1083                   && !isalnum (encoded[i + op_len]))
1084                 {
1085                   strcpy (&decoded.front() + j, ada_opname_table[k].decoded);
1086                   at_start_name = 0;
1087                   i += op_len;
1088                   j += strlen (ada_opname_table[k].decoded);
1089                   break;
1090                 }
1091             }
1092           if (ada_opname_table[k].encoded != NULL)
1093             continue;
1094         }
1095       at_start_name = 0;
1096
1097       /* Replace "TK__" with "__", which will eventually be translated
1098          into "." (just below).  */
1099
1100       if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1101         i += 2;
1102
1103       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1104          be translated into "." (just below).  These are internal names
1105          generated for anonymous blocks inside which our symbol is nested.  */
1106
1107       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1108           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1109           && isdigit (encoded [i+4]))
1110         {
1111           int k = i + 5;
1112           
1113           while (k < len0 && isdigit (encoded[k]))
1114             k++;  /* Skip any extra digit.  */
1115
1116           /* Double-check that the "__B_{DIGITS}+" sequence we found
1117              is indeed followed by "__".  */
1118           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1119             i = k;
1120         }
1121
1122       /* Remove _E{DIGITS}+[sb] */
1123
1124       /* Just as for protected object subprograms, there are 2 categories
1125          of subprograms created by the compiler for each entry.  The first
1126          one implements the actual entry code, and has a suffix following
1127          the convention above; the second one implements the barrier and
1128          uses the same convention as above, except that the 'E' is replaced
1129          by a 'B'.
1130
1131          Just as above, we do not decode the name of barrier functions
1132          to give the user a clue that the code he is debugging has been
1133          internally generated.  */
1134
1135       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1136           && isdigit (encoded[i+2]))
1137         {
1138           int k = i + 3;
1139
1140           while (k < len0 && isdigit (encoded[k]))
1141             k++;
1142
1143           if (k < len0
1144               && (encoded[k] == 'b' || encoded[k] == 's'))
1145             {
1146               k++;
1147               /* Just as an extra precaution, make sure that if this
1148                  suffix is followed by anything else, it is a '_'.
1149                  Otherwise, we matched this sequence by accident.  */
1150               if (k == len0
1151                   || (k < len0 && encoded[k] == '_'))
1152                 i = k;
1153             }
1154         }
1155
1156       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1157          the GNAT front-end in protected object subprograms.  */
1158
1159       if (i < len0 + 3
1160           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1161         {
1162           /* Backtrack a bit up until we reach either the begining of
1163              the encoded name, or "__".  Make sure that we only find
1164              digits or lowercase characters.  */
1165           const char *ptr = encoded + i - 1;
1166
1167           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1168             ptr--;
1169           if (ptr < encoded
1170               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1171             i++;
1172         }
1173
1174       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1175         {
1176           /* This is a X[bn]* sequence not separated from the previous
1177              part of the name with a non-alpha-numeric character (in other
1178              words, immediately following an alpha-numeric character), then
1179              verify that it is placed at the end of the encoded name.  If
1180              not, then the encoding is not valid and we should abort the
1181              decoding.  Otherwise, just skip it, it is used in body-nested
1182              package names.  */
1183           do
1184             i += 1;
1185           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1186           if (i < len0)
1187             goto Suppress;
1188         }
1189       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1190         {
1191          /* Replace '__' by '.'.  */
1192           decoded[j] = '.';
1193           at_start_name = 1;
1194           i += 2;
1195           j += 1;
1196         }
1197       else
1198         {
1199           /* It's a character part of the decoded name, so just copy it
1200              over.  */
1201           decoded[j] = encoded[i];
1202           i += 1;
1203           j += 1;
1204         }
1205     }
1206   decoded.resize (j);
1207
1208   /* Decoded names should never contain any uppercase character.
1209      Double-check this, and abort the decoding if we find one.  */
1210
1211   for (i = 0; i < decoded.length(); ++i)
1212     if (isupper (decoded[i]) || decoded[i] == ' ')
1213       goto Suppress;
1214
1215   return decoded;
1216
1217 Suppress:
1218   if (!wrap)
1219     return {};
1220
1221   if (encoded[0] == '<')
1222     decoded = encoded;
1223   else
1224     decoded = '<' + std::string(encoded) + '>';
1225   return decoded;
1226 }
1227
1228 /* Table for keeping permanent unique copies of decoded names.  Once
1229    allocated, names in this table are never released.  While this is a
1230    storage leak, it should not be significant unless there are massive
1231    changes in the set of decoded names in successive versions of a 
1232    symbol table loaded during a single session.  */
1233 static struct htab *decoded_names_store;
1234
1235 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1236    in the language-specific part of GSYMBOL, if it has not been
1237    previously computed.  Tries to save the decoded name in the same
1238    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1239    in any case, the decoded symbol has a lifetime at least that of
1240    GSYMBOL).
1241    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1242    const, but nevertheless modified to a semantically equivalent form
1243    when a decoded name is cached in it.  */
1244
1245 const char *
1246 ada_decode_symbol (const struct general_symbol_info *arg)
1247 {
1248   struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1249   const char **resultp =
1250     &gsymbol->language_specific.demangled_name;
1251
1252   if (!gsymbol->ada_mangled)
1253     {
1254       std::string decoded = ada_decode (gsymbol->linkage_name ());
1255       struct obstack *obstack = gsymbol->language_specific.obstack;
1256
1257       gsymbol->ada_mangled = 1;
1258
1259       if (obstack != NULL)
1260         *resultp = obstack_strdup (obstack, decoded.c_str ());
1261       else
1262         {
1263           /* Sometimes, we can't find a corresponding objfile, in
1264              which case, we put the result on the heap.  Since we only
1265              decode when needed, we hope this usually does not cause a
1266              significant memory leak (FIXME).  */
1267
1268           char **slot = (char **) htab_find_slot (decoded_names_store,
1269                                                   decoded.c_str (), INSERT);
1270
1271           if (*slot == NULL)
1272             *slot = xstrdup (decoded.c_str ());
1273           *resultp = *slot;
1274         }
1275     }
1276
1277   return *resultp;
1278 }
1279
1280 static char *
1281 ada_la_decode (const char *encoded, int options)
1282 {
1283   return xstrdup (ada_decode (encoded).c_str ());
1284 }
1285
1286 \f
1287
1288                                 /* Arrays */
1289
1290 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1291    generated by the GNAT compiler to describe the index type used
1292    for each dimension of an array, check whether it follows the latest
1293    known encoding.  If not, fix it up to conform to the latest encoding.
1294    Otherwise, do nothing.  This function also does nothing if
1295    INDEX_DESC_TYPE is NULL.
1296
1297    The GNAT encoding used to describe the array index type evolved a bit.
1298    Initially, the information would be provided through the name of each
1299    field of the structure type only, while the type of these fields was
1300    described as unspecified and irrelevant.  The debugger was then expected
1301    to perform a global type lookup using the name of that field in order
1302    to get access to the full index type description.  Because these global
1303    lookups can be very expensive, the encoding was later enhanced to make
1304    the global lookup unnecessary by defining the field type as being
1305    the full index type description.
1306
1307    The purpose of this routine is to allow us to support older versions
1308    of the compiler by detecting the use of the older encoding, and by
1309    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1310    we essentially replace each field's meaningless type by the associated
1311    index subtype).  */
1312
1313 void
1314 ada_fixup_array_indexes_type (struct type *index_desc_type)
1315 {
1316   int i;
1317
1318   if (index_desc_type == NULL)
1319     return;
1320   gdb_assert (index_desc_type->num_fields () > 0);
1321
1322   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1323      to check one field only, no need to check them all).  If not, return
1324      now.
1325
1326      If our INDEX_DESC_TYPE was generated using the older encoding,
1327      the field type should be a meaningless integer type whose name
1328      is not equal to the field name.  */
1329   if (index_desc_type->field (0).type ()->name () != NULL
1330       && strcmp (index_desc_type->field (0).type ()->name (),
1331                  TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1332     return;
1333
1334   /* Fixup each field of INDEX_DESC_TYPE.  */
1335   for (i = 0; i < index_desc_type->num_fields (); i++)
1336    {
1337      const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1338      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1339
1340      if (raw_type)
1341        index_desc_type->field (i).set_type (raw_type);
1342    }
1343 }
1344
1345 /* The desc_* routines return primitive portions of array descriptors
1346    (fat pointers).  */
1347
1348 /* The descriptor or array type, if any, indicated by TYPE; removes
1349    level of indirection, if needed.  */
1350
1351 static struct type *
1352 desc_base_type (struct type *type)
1353 {
1354   if (type == NULL)
1355     return NULL;
1356   type = ada_check_typedef (type);
1357   if (type->code () == TYPE_CODE_TYPEDEF)
1358     type = ada_typedef_target_type (type);
1359
1360   if (type != NULL
1361       && (type->code () == TYPE_CODE_PTR
1362           || type->code () == TYPE_CODE_REF))
1363     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1364   else
1365     return type;
1366 }
1367
1368 /* True iff TYPE indicates a "thin" array pointer type.  */
1369
1370 static int
1371 is_thin_pntr (struct type *type)
1372 {
1373   return
1374     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1375     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1376 }
1377
1378 /* The descriptor type for thin pointer type TYPE.  */
1379
1380 static struct type *
1381 thin_descriptor_type (struct type *type)
1382 {
1383   struct type *base_type = desc_base_type (type);
1384
1385   if (base_type == NULL)
1386     return NULL;
1387   if (is_suffix (ada_type_name (base_type), "___XVE"))
1388     return base_type;
1389   else
1390     {
1391       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1392
1393       if (alt_type == NULL)
1394         return base_type;
1395       else
1396         return alt_type;
1397     }
1398 }
1399
1400 /* A pointer to the array data for thin-pointer value VAL.  */
1401
1402 static struct value *
1403 thin_data_pntr (struct value *val)
1404 {
1405   struct type *type = ada_check_typedef (value_type (val));
1406   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1407
1408   data_type = lookup_pointer_type (data_type);
1409
1410   if (type->code () == TYPE_CODE_PTR)
1411     return value_cast (data_type, value_copy (val));
1412   else
1413     return value_from_longest (data_type, value_address (val));
1414 }
1415
1416 /* True iff TYPE indicates a "thick" array pointer type.  */
1417
1418 static int
1419 is_thick_pntr (struct type *type)
1420 {
1421   type = desc_base_type (type);
1422   return (type != NULL && type->code () == TYPE_CODE_STRUCT
1423           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1424 }
1425
1426 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1427    pointer to one, the type of its bounds data; otherwise, NULL.  */
1428
1429 static struct type *
1430 desc_bounds_type (struct type *type)
1431 {
1432   struct type *r;
1433
1434   type = desc_base_type (type);
1435
1436   if (type == NULL)
1437     return NULL;
1438   else if (is_thin_pntr (type))
1439     {
1440       type = thin_descriptor_type (type);
1441       if (type == NULL)
1442         return NULL;
1443       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1444       if (r != NULL)
1445         return ada_check_typedef (r);
1446     }
1447   else if (type->code () == TYPE_CODE_STRUCT)
1448     {
1449       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1450       if (r != NULL)
1451         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1452     }
1453   return NULL;
1454 }
1455
1456 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1457    one, a pointer to its bounds data.   Otherwise NULL.  */
1458
1459 static struct value *
1460 desc_bounds (struct value *arr)
1461 {
1462   struct type *type = ada_check_typedef (value_type (arr));
1463
1464   if (is_thin_pntr (type))
1465     {
1466       struct type *bounds_type =
1467         desc_bounds_type (thin_descriptor_type (type));
1468       LONGEST addr;
1469
1470       if (bounds_type == NULL)
1471         error (_("Bad GNAT array descriptor"));
1472
1473       /* NOTE: The following calculation is not really kosher, but
1474          since desc_type is an XVE-encoded type (and shouldn't be),
1475          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1476       if (type->code () == TYPE_CODE_PTR)
1477         addr = value_as_long (arr);
1478       else
1479         addr = value_address (arr);
1480
1481       return
1482         value_from_longest (lookup_pointer_type (bounds_type),
1483                             addr - TYPE_LENGTH (bounds_type));
1484     }
1485
1486   else if (is_thick_pntr (type))
1487     {
1488       struct value *p_bounds = value_struct_elt (&arr, {}, "P_BOUNDS", NULL,
1489                                                _("Bad GNAT array descriptor"));
1490       struct type *p_bounds_type = value_type (p_bounds);
1491
1492       if (p_bounds_type
1493           && p_bounds_type->code () == TYPE_CODE_PTR)
1494         {
1495           struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1496
1497           if (target_type->is_stub ())
1498             p_bounds = value_cast (lookup_pointer_type
1499                                    (ada_check_typedef (target_type)),
1500                                    p_bounds);
1501         }
1502       else
1503         error (_("Bad GNAT array descriptor"));
1504
1505       return p_bounds;
1506     }
1507   else
1508     return NULL;
1509 }
1510
1511 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1512    position of the field containing the address of the bounds data.  */
1513
1514 static int
1515 fat_pntr_bounds_bitpos (struct type *type)
1516 {
1517   return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1518 }
1519
1520 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1521    size of the field containing the address of the bounds data.  */
1522
1523 static int
1524 fat_pntr_bounds_bitsize (struct type *type)
1525 {
1526   type = desc_base_type (type);
1527
1528   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1529     return TYPE_FIELD_BITSIZE (type, 1);
1530   else
1531     return 8 * TYPE_LENGTH (ada_check_typedef (type->field (1).type ()));
1532 }
1533
1534 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1535    pointer to one, the type of its array data (a array-with-no-bounds type);
1536    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1537    data.  */
1538
1539 static struct type *
1540 desc_data_target_type (struct type *type)
1541 {
1542   type = desc_base_type (type);
1543
1544   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1545   if (is_thin_pntr (type))
1546     return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1547   else if (is_thick_pntr (type))
1548     {
1549       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1550
1551       if (data_type
1552           && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1553         return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1554     }
1555
1556   return NULL;
1557 }
1558
1559 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1560    its array data.  */
1561
1562 static struct value *
1563 desc_data (struct value *arr)
1564 {
1565   struct type *type = value_type (arr);
1566
1567   if (is_thin_pntr (type))
1568     return thin_data_pntr (arr);
1569   else if (is_thick_pntr (type))
1570     return value_struct_elt (&arr, {}, "P_ARRAY", NULL,
1571                              _("Bad GNAT array descriptor"));
1572   else
1573     return NULL;
1574 }
1575
1576
1577 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1578    position of the field containing the address of the data.  */
1579
1580 static int
1581 fat_pntr_data_bitpos (struct type *type)
1582 {
1583   return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1584 }
1585
1586 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1587    size of the field containing the address of the data.  */
1588
1589 static int
1590 fat_pntr_data_bitsize (struct type *type)
1591 {
1592   type = desc_base_type (type);
1593
1594   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1595     return TYPE_FIELD_BITSIZE (type, 0);
1596   else
1597     return TARGET_CHAR_BIT * TYPE_LENGTH (type->field (0).type ());
1598 }
1599
1600 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1601    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1602    bound, if WHICH is 1.  The first bound is I=1.  */
1603
1604 static struct value *
1605 desc_one_bound (struct value *bounds, int i, int which)
1606 {
1607   char bound_name[20];
1608   xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1609              which ? 'U' : 'L', i - 1);
1610   return value_struct_elt (&bounds, {}, bound_name, NULL,
1611                            _("Bad GNAT array descriptor bounds"));
1612 }
1613
1614 /* If BOUNDS is an array-bounds structure type, return the bit position
1615    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1616    bound, if WHICH is 1.  The first bound is I=1.  */
1617
1618 static int
1619 desc_bound_bitpos (struct type *type, int i, int which)
1620 {
1621   return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1622 }
1623
1624 /* If BOUNDS is an array-bounds structure type, return the bit field size
1625    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1626    bound, if WHICH is 1.  The first bound is I=1.  */
1627
1628 static int
1629 desc_bound_bitsize (struct type *type, int i, int which)
1630 {
1631   type = desc_base_type (type);
1632
1633   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1634     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1635   else
1636     return 8 * TYPE_LENGTH (type->field (2 * i + which - 2).type ());
1637 }
1638
1639 /* If TYPE is the type of an array-bounds structure, the type of its
1640    Ith bound (numbering from 1).  Otherwise, NULL.  */
1641
1642 static struct type *
1643 desc_index_type (struct type *type, int i)
1644 {
1645   type = desc_base_type (type);
1646
1647   if (type->code () == TYPE_CODE_STRUCT)
1648     {
1649       char bound_name[20];
1650       xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
1651       return lookup_struct_elt_type (type, bound_name, 1);
1652     }
1653   else
1654     return NULL;
1655 }
1656
1657 /* The number of index positions in the array-bounds type TYPE.
1658    Return 0 if TYPE is NULL.  */
1659
1660 static int
1661 desc_arity (struct type *type)
1662 {
1663   type = desc_base_type (type);
1664
1665   if (type != NULL)
1666     return type->num_fields () / 2;
1667   return 0;
1668 }
1669
1670 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
1671    an array descriptor type (representing an unconstrained array
1672    type).  */
1673
1674 static int
1675 ada_is_direct_array_type (struct type *type)
1676 {
1677   if (type == NULL)
1678     return 0;
1679   type = ada_check_typedef (type);
1680   return (type->code () == TYPE_CODE_ARRAY
1681           || ada_is_array_descriptor_type (type));
1682 }
1683
1684 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1685  * to one.  */
1686
1687 static int
1688 ada_is_array_type (struct type *type)
1689 {
1690   while (type != NULL
1691          && (type->code () == TYPE_CODE_PTR
1692              || type->code () == TYPE_CODE_REF))
1693     type = TYPE_TARGET_TYPE (type);
1694   return ada_is_direct_array_type (type);
1695 }
1696
1697 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
1698
1699 int
1700 ada_is_simple_array_type (struct type *type)
1701 {
1702   if (type == NULL)
1703     return 0;
1704   type = ada_check_typedef (type);
1705   return (type->code () == TYPE_CODE_ARRAY
1706           || (type->code () == TYPE_CODE_PTR
1707               && (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ()
1708                   == TYPE_CODE_ARRAY)));
1709 }
1710
1711 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
1712
1713 int
1714 ada_is_array_descriptor_type (struct type *type)
1715 {
1716   struct type *data_type = desc_data_target_type (type);
1717
1718   if (type == NULL)
1719     return 0;
1720   type = ada_check_typedef (type);
1721   return (data_type != NULL
1722           && data_type->code () == TYPE_CODE_ARRAY
1723           && desc_arity (desc_bounds_type (type)) > 0);
1724 }
1725
1726 /* Non-zero iff type is a partially mal-formed GNAT array
1727    descriptor.  FIXME: This is to compensate for some problems with
1728    debugging output from GNAT.  Re-examine periodically to see if it
1729    is still needed.  */
1730
1731 int
1732 ada_is_bogus_array_descriptor (struct type *type)
1733 {
1734   return
1735     type != NULL
1736     && type->code () == TYPE_CODE_STRUCT
1737     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1738         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1739     && !ada_is_array_descriptor_type (type);
1740 }
1741
1742
1743 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1744    (fat pointer) returns the type of the array data described---specifically,
1745    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
1746    in from the descriptor; otherwise, they are left unspecified.  If
1747    the ARR denotes a null array descriptor and BOUNDS is non-zero,
1748    returns NULL.  The result is simply the type of ARR if ARR is not
1749    a descriptor.  */
1750
1751 static struct type *
1752 ada_type_of_array (struct value *arr, int bounds)
1753 {
1754   if (ada_is_constrained_packed_array_type (value_type (arr)))
1755     return decode_constrained_packed_array_type (value_type (arr));
1756
1757   if (!ada_is_array_descriptor_type (value_type (arr)))
1758     return value_type (arr);
1759
1760   if (!bounds)
1761     {
1762       struct type *array_type =
1763         ada_check_typedef (desc_data_target_type (value_type (arr)));
1764
1765       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1766         TYPE_FIELD_BITSIZE (array_type, 0) =
1767           decode_packed_array_bitsize (value_type (arr));
1768       
1769       return array_type;
1770     }
1771   else
1772     {
1773       struct type *elt_type;
1774       int arity;
1775       struct value *descriptor;
1776
1777       elt_type = ada_array_element_type (value_type (arr), -1);
1778       arity = ada_array_arity (value_type (arr));
1779
1780       if (elt_type == NULL || arity == 0)
1781         return ada_check_typedef (value_type (arr));
1782
1783       descriptor = desc_bounds (arr);
1784       if (value_as_long (descriptor) == 0)
1785         return NULL;
1786       while (arity > 0)
1787         {
1788           struct type *range_type = alloc_type_copy (value_type (arr));
1789           struct type *array_type = alloc_type_copy (value_type (arr));
1790           struct value *low = desc_one_bound (descriptor, arity, 0);
1791           struct value *high = desc_one_bound (descriptor, arity, 1);
1792
1793           arity -= 1;
1794           create_static_range_type (range_type, value_type (low),
1795                                     longest_to_int (value_as_long (low)),
1796                                     longest_to_int (value_as_long (high)));
1797           elt_type = create_array_type (array_type, elt_type, range_type);
1798
1799           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1800             {
1801               /* We need to store the element packed bitsize, as well as
1802                  recompute the array size, because it was previously
1803                  computed based on the unpacked element size.  */
1804               LONGEST lo = value_as_long (low);
1805               LONGEST hi = value_as_long (high);
1806
1807               TYPE_FIELD_BITSIZE (elt_type, 0) =
1808                 decode_packed_array_bitsize (value_type (arr));
1809               /* If the array has no element, then the size is already
1810                  zero, and does not need to be recomputed.  */
1811               if (lo < hi)
1812                 {
1813                   int array_bitsize =
1814                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1815
1816                   TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1817                 }
1818             }
1819         }
1820
1821       return lookup_pointer_type (elt_type);
1822     }
1823 }
1824
1825 /* If ARR does not represent an array, returns ARR unchanged.
1826    Otherwise, returns either a standard GDB array with bounds set
1827    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1828    GDB array.  Returns NULL if ARR is a null fat pointer.  */
1829
1830 struct value *
1831 ada_coerce_to_simple_array_ptr (struct value *arr)
1832 {
1833   if (ada_is_array_descriptor_type (value_type (arr)))
1834     {
1835       struct type *arrType = ada_type_of_array (arr, 1);
1836
1837       if (arrType == NULL)
1838         return NULL;
1839       return value_cast (arrType, value_copy (desc_data (arr)));
1840     }
1841   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1842     return decode_constrained_packed_array (arr);
1843   else
1844     return arr;
1845 }
1846
1847 /* If ARR does not represent an array, returns ARR unchanged.
1848    Otherwise, returns a standard GDB array describing ARR (which may
1849    be ARR itself if it already is in the proper form).  */
1850
1851 struct value *
1852 ada_coerce_to_simple_array (struct value *arr)
1853 {
1854   if (ada_is_array_descriptor_type (value_type (arr)))
1855     {
1856       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1857
1858       if (arrVal == NULL)
1859         error (_("Bounds unavailable for null array pointer."));
1860       ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
1861       return value_ind (arrVal);
1862     }
1863   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1864     return decode_constrained_packed_array (arr);
1865   else
1866     return arr;
1867 }
1868
1869 /* If TYPE represents a GNAT array type, return it translated to an
1870    ordinary GDB array type (possibly with BITSIZE fields indicating
1871    packing).  For other types, is the identity.  */
1872
1873 struct type *
1874 ada_coerce_to_simple_array_type (struct type *type)
1875 {
1876   if (ada_is_constrained_packed_array_type (type))
1877     return decode_constrained_packed_array_type (type);
1878
1879   if (ada_is_array_descriptor_type (type))
1880     return ada_check_typedef (desc_data_target_type (type));
1881
1882   return type;
1883 }
1884
1885 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
1886
1887 static int
1888 ada_is_gnat_encoded_packed_array_type  (struct type *type)
1889 {
1890   if (type == NULL)
1891     return 0;
1892   type = desc_base_type (type);
1893   type = ada_check_typedef (type);
1894   return
1895     ada_type_name (type) != NULL
1896     && strstr (ada_type_name (type), "___XP") != NULL;
1897 }
1898
1899 /* Non-zero iff TYPE represents a standard GNAT constrained
1900    packed-array type.  */
1901
1902 int
1903 ada_is_constrained_packed_array_type (struct type *type)
1904 {
1905   return ada_is_gnat_encoded_packed_array_type (type)
1906     && !ada_is_array_descriptor_type (type);
1907 }
1908
1909 /* Non-zero iff TYPE represents an array descriptor for a
1910    unconstrained packed-array type.  */
1911
1912 static int
1913 ada_is_unconstrained_packed_array_type (struct type *type)
1914 {
1915   if (!ada_is_array_descriptor_type (type))
1916     return 0;
1917
1918   if (ada_is_gnat_encoded_packed_array_type (type))
1919     return 1;
1920
1921   /* If we saw GNAT encodings, then the above code is sufficient.
1922      However, with minimal encodings, we will just have a thick
1923      pointer instead.  */
1924   if (is_thick_pntr (type))
1925     {
1926       type = desc_base_type (type);
1927       /* The structure's first field is a pointer to an array, so this
1928          fetches the array type.  */
1929       type = TYPE_TARGET_TYPE (type->field (0).type ());
1930       /* Now we can see if the array elements are packed.  */
1931       return TYPE_FIELD_BITSIZE (type, 0) > 0;
1932     }
1933
1934   return 0;
1935 }
1936
1937 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
1938    type, or if it is an ordinary (non-Gnat-encoded) packed array.  */
1939
1940 static bool
1941 ada_is_any_packed_array_type (struct type *type)
1942 {
1943   return (ada_is_constrained_packed_array_type (type)
1944           || (type->code () == TYPE_CODE_ARRAY
1945               && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
1946 }
1947
1948 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
1949    return the size of its elements in bits.  */
1950
1951 static long
1952 decode_packed_array_bitsize (struct type *type)
1953 {
1954   const char *raw_name;
1955   const char *tail;
1956   long bits;
1957
1958   /* Access to arrays implemented as fat pointers are encoded as a typedef
1959      of the fat pointer type.  We need the name of the fat pointer type
1960      to do the decoding, so strip the typedef layer.  */
1961   if (type->code () == TYPE_CODE_TYPEDEF)
1962     type = ada_typedef_target_type (type);
1963
1964   raw_name = ada_type_name (ada_check_typedef (type));
1965   if (!raw_name)
1966     raw_name = ada_type_name (desc_base_type (type));
1967
1968   if (!raw_name)
1969     return 0;
1970
1971   tail = strstr (raw_name, "___XP");
1972   if (tail == nullptr)
1973     {
1974       gdb_assert (is_thick_pntr (type));
1975       /* The structure's first field is a pointer to an array, so this
1976          fetches the array type.  */
1977       type = TYPE_TARGET_TYPE (type->field (0).type ());
1978       /* Now we can see if the array elements are packed.  */
1979       return TYPE_FIELD_BITSIZE (type, 0);
1980     }
1981
1982   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1983     {
1984       lim_warning
1985         (_("could not understand bit size information on packed array"));
1986       return 0;
1987     }
1988
1989   return bits;
1990 }
1991
1992 /* Given that TYPE is a standard GDB array type with all bounds filled
1993    in, and that the element size of its ultimate scalar constituents
1994    (that is, either its elements, or, if it is an array of arrays, its
1995    elements' elements, etc.) is *ELT_BITS, return an identical type,
1996    but with the bit sizes of its elements (and those of any
1997    constituent arrays) recorded in the BITSIZE components of its
1998    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1999    in bits.
2000
2001    Note that, for arrays whose index type has an XA encoding where
2002    a bound references a record discriminant, getting that discriminant,
2003    and therefore the actual value of that bound, is not possible
2004    because none of the given parameters gives us access to the record.
2005    This function assumes that it is OK in the context where it is being
2006    used to return an array whose bounds are still dynamic and where
2007    the length is arbitrary.  */
2008
2009 static struct type *
2010 constrained_packed_array_type (struct type *type, long *elt_bits)
2011 {
2012   struct type *new_elt_type;
2013   struct type *new_type;
2014   struct type *index_type_desc;
2015   struct type *index_type;
2016   LONGEST low_bound, high_bound;
2017
2018   type = ada_check_typedef (type);
2019   if (type->code () != TYPE_CODE_ARRAY)
2020     return type;
2021
2022   index_type_desc = ada_find_parallel_type (type, "___XA");
2023   if (index_type_desc)
2024     index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2025                                       NULL);
2026   else
2027     index_type = type->index_type ();
2028
2029   new_type = alloc_type_copy (type);
2030   new_elt_type =
2031     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2032                                    elt_bits);
2033   create_array_type (new_type, new_elt_type, index_type);
2034   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2035   new_type->set_name (ada_type_name (type));
2036
2037   if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2038        && is_dynamic_type (check_typedef (index_type)))
2039       || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2040     low_bound = high_bound = 0;
2041   if (high_bound < low_bound)
2042     *elt_bits = TYPE_LENGTH (new_type) = 0;
2043   else
2044     {
2045       *elt_bits *= (high_bound - low_bound + 1);
2046       TYPE_LENGTH (new_type) =
2047         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2048     }
2049
2050   new_type->set_is_fixed_instance (true);
2051   return new_type;
2052 }
2053
2054 /* The array type encoded by TYPE, where
2055    ada_is_constrained_packed_array_type (TYPE).  */
2056
2057 static struct type *
2058 decode_constrained_packed_array_type (struct type *type)
2059 {
2060   const char *raw_name = ada_type_name (ada_check_typedef (type));
2061   char *name;
2062   const char *tail;
2063   struct type *shadow_type;
2064   long bits;
2065
2066   if (!raw_name)
2067     raw_name = ada_type_name (desc_base_type (type));
2068
2069   if (!raw_name)
2070     return NULL;
2071
2072   name = (char *) alloca (strlen (raw_name) + 1);
2073   tail = strstr (raw_name, "___XP");
2074   type = desc_base_type (type);
2075
2076   memcpy (name, raw_name, tail - raw_name);
2077   name[tail - raw_name] = '\000';
2078
2079   shadow_type = ada_find_parallel_type_with_name (type, name);
2080
2081   if (shadow_type == NULL)
2082     {
2083       lim_warning (_("could not find bounds information on packed array"));
2084       return NULL;
2085     }
2086   shadow_type = check_typedef (shadow_type);
2087
2088   if (shadow_type->code () != TYPE_CODE_ARRAY)
2089     {
2090       lim_warning (_("could not understand bounds "
2091                      "information on packed array"));
2092       return NULL;
2093     }
2094
2095   bits = decode_packed_array_bitsize (type);
2096   return constrained_packed_array_type (shadow_type, &bits);
2097 }
2098
2099 /* Helper function for decode_constrained_packed_array.  Set the field
2100    bitsize on a series of packed arrays.  Returns the number of
2101    elements in TYPE.  */
2102
2103 static LONGEST
2104 recursively_update_array_bitsize (struct type *type)
2105 {
2106   gdb_assert (type->code () == TYPE_CODE_ARRAY);
2107
2108   LONGEST low, high;
2109   if (!get_discrete_bounds (type->index_type (), &low, &high)
2110       || low > high)
2111     return 0;
2112   LONGEST our_len = high - low + 1;
2113
2114   struct type *elt_type = TYPE_TARGET_TYPE (type);
2115   if (elt_type->code () == TYPE_CODE_ARRAY)
2116     {
2117       LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2118       LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2119       TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2120
2121       TYPE_LENGTH (type) = ((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2122                             / HOST_CHAR_BIT);
2123     }
2124
2125   return our_len;
2126 }
2127
2128 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2129    array, returns a simple array that denotes that array.  Its type is a
2130    standard GDB array type except that the BITSIZEs of the array
2131    target types are set to the number of bits in each element, and the
2132    type length is set appropriately.  */
2133
2134 static struct value *
2135 decode_constrained_packed_array (struct value *arr)
2136 {
2137   struct type *type;
2138
2139   /* If our value is a pointer, then dereference it. Likewise if
2140      the value is a reference.  Make sure that this operation does not
2141      cause the target type to be fixed, as this would indirectly cause
2142      this array to be decoded.  The rest of the routine assumes that
2143      the array hasn't been decoded yet, so we use the basic "coerce_ref"
2144      and "value_ind" routines to perform the dereferencing, as opposed
2145      to using "ada_coerce_ref" or "ada_value_ind".  */
2146   arr = coerce_ref (arr);
2147   if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2148     arr = value_ind (arr);
2149
2150   type = decode_constrained_packed_array_type (value_type (arr));
2151   if (type == NULL)
2152     {
2153       error (_("can't unpack array"));
2154       return NULL;
2155     }
2156
2157   /* Decoding the packed array type could not correctly set the field
2158      bitsizes for any dimension except the innermost, because the
2159      bounds may be variable and were not passed to that function.  So,
2160      we further resolve the array bounds here and then update the
2161      sizes.  */
2162   const gdb_byte *valaddr = value_contents_for_printing (arr);
2163   CORE_ADDR address = value_address (arr);
2164   gdb::array_view<const gdb_byte> view
2165     = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
2166   type = resolve_dynamic_type (type, view, address);
2167   recursively_update_array_bitsize (type);
2168
2169   if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2170       && ada_is_modular_type (value_type (arr)))
2171     {
2172        /* This is a (right-justified) modular type representing a packed
2173           array with no wrapper.  In order to interpret the value through
2174           the (left-justified) packed array type we just built, we must
2175           first left-justify it.  */
2176       int bit_size, bit_pos;
2177       ULONGEST mod;
2178
2179       mod = ada_modulus (value_type (arr)) - 1;
2180       bit_size = 0;
2181       while (mod > 0)
2182         {
2183           bit_size += 1;
2184           mod >>= 1;
2185         }
2186       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2187       arr = ada_value_primitive_packed_val (arr, NULL,
2188                                             bit_pos / HOST_CHAR_BIT,
2189                                             bit_pos % HOST_CHAR_BIT,
2190                                             bit_size,
2191                                             type);
2192     }
2193
2194   return coerce_unspec_val_to_type (arr, type);
2195 }
2196
2197
2198 /* The value of the element of packed array ARR at the ARITY indices
2199    given in IND.   ARR must be a simple array.  */
2200
2201 static struct value *
2202 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2203 {
2204   int i;
2205   int bits, elt_off, bit_off;
2206   long elt_total_bit_offset;
2207   struct type *elt_type;
2208   struct value *v;
2209
2210   bits = 0;
2211   elt_total_bit_offset = 0;
2212   elt_type = ada_check_typedef (value_type (arr));
2213   for (i = 0; i < arity; i += 1)
2214     {
2215       if (elt_type->code () != TYPE_CODE_ARRAY
2216           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2217         error
2218           (_("attempt to do packed indexing of "
2219              "something other than a packed array"));
2220       else
2221         {
2222           struct type *range_type = elt_type->index_type ();
2223           LONGEST lowerbound, upperbound;
2224           LONGEST idx;
2225
2226           if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2227             {
2228               lim_warning (_("don't know bounds of array"));
2229               lowerbound = upperbound = 0;
2230             }
2231
2232           idx = pos_atr (ind[i]);
2233           if (idx < lowerbound || idx > upperbound)
2234             lim_warning (_("packed array index %ld out of bounds"),
2235                          (long) idx);
2236           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2237           elt_total_bit_offset += (idx - lowerbound) * bits;
2238           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2239         }
2240     }
2241   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2242   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2243
2244   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2245                                       bits, elt_type);
2246   return v;
2247 }
2248
2249 /* Non-zero iff TYPE includes negative integer values.  */
2250
2251 static int
2252 has_negatives (struct type *type)
2253 {
2254   switch (type->code ())
2255     {
2256     default:
2257       return 0;
2258     case TYPE_CODE_INT:
2259       return !type->is_unsigned ();
2260     case TYPE_CODE_RANGE:
2261       return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2262     }
2263 }
2264
2265 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2266    unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
2267    the unpacked buffer.
2268
2269    The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2270    enough to contain at least BIT_OFFSET bits.  If not, an error is raised.
2271
2272    IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2273    zero otherwise.
2274
2275    IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2276
2277    IS_SCALAR is nonzero if the data corresponds to a signed type.  */
2278
2279 static void
2280 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2281                           gdb_byte *unpacked, int unpacked_len,
2282                           int is_big_endian, int is_signed_type,
2283                           int is_scalar)
2284 {
2285   int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2286   int src_idx;                  /* Index into the source area */
2287   int src_bytes_left;           /* Number of source bytes left to process.  */
2288   int srcBitsLeft;              /* Number of source bits left to move */
2289   int unusedLS;                 /* Number of bits in next significant
2290                                    byte of source that are unused */
2291
2292   int unpacked_idx;             /* Index into the unpacked buffer */
2293   int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */
2294
2295   unsigned long accum;          /* Staging area for bits being transferred */
2296   int accumSize;                /* Number of meaningful bits in accum */
2297   unsigned char sign;
2298
2299   /* Transmit bytes from least to most significant; delta is the direction
2300      the indices move.  */
2301   int delta = is_big_endian ? -1 : 1;
2302
2303   /* Make sure that unpacked is large enough to receive the BIT_SIZE
2304      bits from SRC.  .*/
2305   if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2306     error (_("Cannot unpack %d bits into buffer of %d bytes"),
2307            bit_size, unpacked_len);
2308
2309   srcBitsLeft = bit_size;
2310   src_bytes_left = src_len;
2311   unpacked_bytes_left = unpacked_len;
2312   sign = 0;
2313
2314   if (is_big_endian)
2315     {
2316       src_idx = src_len - 1;
2317       if (is_signed_type
2318           && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2319         sign = ~0;
2320
2321       unusedLS =
2322         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2323         % HOST_CHAR_BIT;
2324
2325       if (is_scalar)
2326         {
2327           accumSize = 0;
2328           unpacked_idx = unpacked_len - 1;
2329         }
2330       else
2331         {
2332           /* Non-scalar values must be aligned at a byte boundary...  */
2333           accumSize =
2334             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2335           /* ... And are placed at the beginning (most-significant) bytes
2336              of the target.  */
2337           unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2338           unpacked_bytes_left = unpacked_idx + 1;
2339         }
2340     }
2341   else
2342     {
2343       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2344
2345       src_idx = unpacked_idx = 0;
2346       unusedLS = bit_offset;
2347       accumSize = 0;
2348
2349       if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2350         sign = ~0;
2351     }
2352
2353   accum = 0;
2354   while (src_bytes_left > 0)
2355     {
2356       /* Mask for removing bits of the next source byte that are not
2357          part of the value.  */
2358       unsigned int unusedMSMask =
2359         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2360         1;
2361       /* Sign-extend bits for this byte.  */
2362       unsigned int signMask = sign & ~unusedMSMask;
2363
2364       accum |=
2365         (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2366       accumSize += HOST_CHAR_BIT - unusedLS;
2367       if (accumSize >= HOST_CHAR_BIT)
2368         {
2369           unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2370           accumSize -= HOST_CHAR_BIT;
2371           accum >>= HOST_CHAR_BIT;
2372           unpacked_bytes_left -= 1;
2373           unpacked_idx += delta;
2374         }
2375       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2376       unusedLS = 0;
2377       src_bytes_left -= 1;
2378       src_idx += delta;
2379     }
2380   while (unpacked_bytes_left > 0)
2381     {
2382       accum |= sign << accumSize;
2383       unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2384       accumSize -= HOST_CHAR_BIT;
2385       if (accumSize < 0)
2386         accumSize = 0;
2387       accum >>= HOST_CHAR_BIT;
2388       unpacked_bytes_left -= 1;
2389       unpacked_idx += delta;
2390     }
2391 }
2392
2393 /* Create a new value of type TYPE from the contents of OBJ starting
2394    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2395    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2396    assigning through the result will set the field fetched from.
2397    VALADDR is ignored unless OBJ is NULL, in which case,
2398    VALADDR+OFFSET must address the start of storage containing the 
2399    packed value.  The value returned  in this case is never an lval.
2400    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2401
2402 struct value *
2403 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2404                                 long offset, int bit_offset, int bit_size,
2405                                 struct type *type)
2406 {
2407   struct value *v;
2408   const gdb_byte *src;                /* First byte containing data to unpack */
2409   gdb_byte *unpacked;
2410   const int is_scalar = is_scalar_type (type);
2411   const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2412   gdb::byte_vector staging;
2413
2414   type = ada_check_typedef (type);
2415
2416   if (obj == NULL)
2417     src = valaddr + offset;
2418   else
2419     src = value_contents (obj) + offset;
2420
2421   if (is_dynamic_type (type))
2422     {
2423       /* The length of TYPE might by dynamic, so we need to resolve
2424          TYPE in order to know its actual size, which we then use
2425          to create the contents buffer of the value we return.
2426          The difficulty is that the data containing our object is
2427          packed, and therefore maybe not at a byte boundary.  So, what
2428          we do, is unpack the data into a byte-aligned buffer, and then
2429          use that buffer as our object's value for resolving the type.  */
2430       int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2431       staging.resize (staging_len);
2432
2433       ada_unpack_from_contents (src, bit_offset, bit_size,
2434                                 staging.data (), staging.size (),
2435                                 is_big_endian, has_negatives (type),
2436                                 is_scalar);
2437       type = resolve_dynamic_type (type, staging, 0);
2438       if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2439         {
2440           /* This happens when the length of the object is dynamic,
2441              and is actually smaller than the space reserved for it.
2442              For instance, in an array of variant records, the bit_size
2443              we're given is the array stride, which is constant and
2444              normally equal to the maximum size of its element.
2445              But, in reality, each element only actually spans a portion
2446              of that stride.  */
2447           bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2448         }
2449     }
2450
2451   if (obj == NULL)
2452     {
2453       v = allocate_value (type);
2454       src = valaddr + offset;
2455     }
2456   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2457     {
2458       int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2459       gdb_byte *buf;
2460
2461       v = value_at (type, value_address (obj) + offset);
2462       buf = (gdb_byte *) alloca (src_len);
2463       read_memory (value_address (v), buf, src_len);
2464       src = buf;
2465     }
2466   else
2467     {
2468       v = allocate_value (type);
2469       src = value_contents (obj) + offset;
2470     }
2471
2472   if (obj != NULL)
2473     {
2474       long new_offset = offset;
2475
2476       set_value_component_location (v, obj);
2477       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2478       set_value_bitsize (v, bit_size);
2479       if (value_bitpos (v) >= HOST_CHAR_BIT)
2480         {
2481           ++new_offset;
2482           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2483         }
2484       set_value_offset (v, new_offset);
2485
2486       /* Also set the parent value.  This is needed when trying to
2487          assign a new value (in inferior memory).  */
2488       set_value_parent (v, obj);
2489     }
2490   else
2491     set_value_bitsize (v, bit_size);
2492   unpacked = value_contents_writeable (v);
2493
2494   if (bit_size == 0)
2495     {
2496       memset (unpacked, 0, TYPE_LENGTH (type));
2497       return v;
2498     }
2499
2500   if (staging.size () == TYPE_LENGTH (type))
2501     {
2502       /* Small short-cut: If we've unpacked the data into a buffer
2503          of the same size as TYPE's length, then we can reuse that,
2504          instead of doing the unpacking again.  */
2505       memcpy (unpacked, staging.data (), staging.size ());
2506     }
2507   else
2508     ada_unpack_from_contents (src, bit_offset, bit_size,
2509                               unpacked, TYPE_LENGTH (type),
2510                               is_big_endian, has_negatives (type), is_scalar);
2511
2512   return v;
2513 }
2514
2515 /* Store the contents of FROMVAL into the location of TOVAL.
2516    Return a new value with the location of TOVAL and contents of
2517    FROMVAL.   Handles assignment into packed fields that have
2518    floating-point or non-scalar types.  */
2519
2520 static struct value *
2521 ada_value_assign (struct value *toval, struct value *fromval)
2522 {
2523   struct type *type = value_type (toval);
2524   int bits = value_bitsize (toval);
2525
2526   toval = ada_coerce_ref (toval);
2527   fromval = ada_coerce_ref (fromval);
2528
2529   if (ada_is_direct_array_type (value_type (toval)))
2530     toval = ada_coerce_to_simple_array (toval);
2531   if (ada_is_direct_array_type (value_type (fromval)))
2532     fromval = ada_coerce_to_simple_array (fromval);
2533
2534   if (!deprecated_value_modifiable (toval))
2535     error (_("Left operand of assignment is not a modifiable lvalue."));
2536
2537   if (VALUE_LVAL (toval) == lval_memory
2538       && bits > 0
2539       && (type->code () == TYPE_CODE_FLT
2540           || type->code () == TYPE_CODE_STRUCT))
2541     {
2542       int len = (value_bitpos (toval)
2543                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2544       int from_size;
2545       gdb_byte *buffer = (gdb_byte *) alloca (len);
2546       struct value *val;
2547       CORE_ADDR to_addr = value_address (toval);
2548
2549       if (type->code () == TYPE_CODE_FLT)
2550         fromval = value_cast (type, fromval);
2551
2552       read_memory (to_addr, buffer, len);
2553       from_size = value_bitsize (fromval);
2554       if (from_size == 0)
2555         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2556
2557       const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2558       ULONGEST from_offset = 0;
2559       if (is_big_endian && is_scalar_type (value_type (fromval)))
2560         from_offset = from_size - bits;
2561       copy_bitwise (buffer, value_bitpos (toval),
2562                     value_contents (fromval), from_offset,
2563                     bits, is_big_endian);
2564       write_memory_with_notification (to_addr, buffer, len);
2565
2566       val = value_copy (toval);
2567       memcpy (value_contents_raw (val), value_contents (fromval),
2568               TYPE_LENGTH (type));
2569       deprecated_set_value_type (val, type);
2570
2571       return val;
2572     }
2573
2574   return value_assign (toval, fromval);
2575 }
2576
2577
2578 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2579    CONTAINER, assign the contents of VAL to COMPONENTS's place in
2580    CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2581    COMPONENT, and not the inferior's memory.  The current contents
2582    of COMPONENT are ignored.
2583
2584    Although not part of the initial design, this function also works
2585    when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2586    had a null address, and COMPONENT had an address which is equal to
2587    its offset inside CONTAINER.  */
2588
2589 static void
2590 value_assign_to_component (struct value *container, struct value *component,
2591                            struct value *val)
2592 {
2593   LONGEST offset_in_container =
2594     (LONGEST)  (value_address (component) - value_address (container));
2595   int bit_offset_in_container =
2596     value_bitpos (component) - value_bitpos (container);
2597   int bits;
2598
2599   val = value_cast (value_type (component), val);
2600
2601   if (value_bitsize (component) == 0)
2602     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2603   else
2604     bits = value_bitsize (component);
2605
2606   if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2607     {
2608       int src_offset;
2609
2610       if (is_scalar_type (check_typedef (value_type (component))))
2611         src_offset
2612           = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2613       else
2614         src_offset = 0;
2615       copy_bitwise (value_contents_writeable (container) + offset_in_container,
2616                     value_bitpos (container) + bit_offset_in_container,
2617                     value_contents (val), src_offset, bits, 1);
2618     }
2619   else
2620     copy_bitwise (value_contents_writeable (container) + offset_in_container,
2621                   value_bitpos (container) + bit_offset_in_container,
2622                   value_contents (val), 0, bits, 0);
2623 }
2624
2625 /* Determine if TYPE is an access to an unconstrained array.  */
2626
2627 bool
2628 ada_is_access_to_unconstrained_array (struct type *type)
2629 {
2630   return (type->code () == TYPE_CODE_TYPEDEF
2631           && is_thick_pntr (ada_typedef_target_type (type)));
2632 }
2633
2634 /* The value of the element of array ARR at the ARITY indices given in IND.
2635    ARR may be either a simple array, GNAT array descriptor, or pointer
2636    thereto.  */
2637
2638 struct value *
2639 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2640 {
2641   int k;
2642   struct value *elt;
2643   struct type *elt_type;
2644
2645   elt = ada_coerce_to_simple_array (arr);
2646
2647   elt_type = ada_check_typedef (value_type (elt));
2648   if (elt_type->code () == TYPE_CODE_ARRAY
2649       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2650     return value_subscript_packed (elt, arity, ind);
2651
2652   for (k = 0; k < arity; k += 1)
2653     {
2654       struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
2655
2656       if (elt_type->code () != TYPE_CODE_ARRAY)
2657         error (_("too many subscripts (%d expected)"), k);
2658
2659       elt = value_subscript (elt, pos_atr (ind[k]));
2660
2661       if (ada_is_access_to_unconstrained_array (saved_elt_type)
2662           && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
2663         {
2664           /* The element is a typedef to an unconstrained array,
2665              except that the value_subscript call stripped the
2666              typedef layer.  The typedef layer is GNAT's way to
2667              specify that the element is, at the source level, an
2668              access to the unconstrained array, rather than the
2669              unconstrained array.  So, we need to restore that
2670              typedef layer, which we can do by forcing the element's
2671              type back to its original type. Otherwise, the returned
2672              value is going to be printed as the array, rather
2673              than as an access.  Another symptom of the same issue
2674              would be that an expression trying to dereference the
2675              element would also be improperly rejected.  */
2676           deprecated_set_value_type (elt, saved_elt_type);
2677         }
2678
2679       elt_type = ada_check_typedef (value_type (elt));
2680     }
2681
2682   return elt;
2683 }
2684
2685 /* Assuming ARR is a pointer to a GDB array, the value of the element
2686    of *ARR at the ARITY indices given in IND.
2687    Does not read the entire array into memory.
2688
2689    Note: Unlike what one would expect, this function is used instead of
2690    ada_value_subscript for basically all non-packed array types.  The reason
2691    for this is that a side effect of doing our own pointer arithmetics instead
2692    of relying on value_subscript is that there is no implicit typedef peeling.
2693    This is important for arrays of array accesses, where it allows us to
2694    preserve the fact that the array's element is an array access, where the
2695    access part os encoded in a typedef layer.  */
2696
2697 static struct value *
2698 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2699 {
2700   int k;
2701   struct value *array_ind = ada_value_ind (arr);
2702   struct type *type
2703     = check_typedef (value_enclosing_type (array_ind));
2704
2705   if (type->code () == TYPE_CODE_ARRAY
2706       && TYPE_FIELD_BITSIZE (type, 0) > 0)
2707     return value_subscript_packed (array_ind, arity, ind);
2708
2709   for (k = 0; k < arity; k += 1)
2710     {
2711       LONGEST lwb, upb;
2712
2713       if (type->code () != TYPE_CODE_ARRAY)
2714         error (_("too many subscripts (%d expected)"), k);
2715       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2716                         value_copy (arr));
2717       get_discrete_bounds (type->index_type (), &lwb, &upb);
2718       arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
2719       type = TYPE_TARGET_TYPE (type);
2720     }
2721
2722   return value_ind (arr);
2723 }
2724
2725 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2726    actual type of ARRAY_PTR is ignored), returns the Ada slice of
2727    HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
2728    this array is LOW, as per Ada rules.  */
2729 static struct value *
2730 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2731                           int low, int high)
2732 {
2733   struct type *type0 = ada_check_typedef (type);
2734   struct type *base_index_type = TYPE_TARGET_TYPE (type0->index_type ());
2735   struct type *index_type
2736     = create_static_range_type (NULL, base_index_type, low, high);
2737   struct type *slice_type = create_array_type_with_stride
2738                               (NULL, TYPE_TARGET_TYPE (type0), index_type,
2739                                type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
2740                                TYPE_FIELD_BITSIZE (type0, 0));
2741   int base_low =  ada_discrete_type_low_bound (type0->index_type ());
2742   gdb::optional<LONGEST> base_low_pos, low_pos;
2743   CORE_ADDR base;
2744
2745   low_pos = discrete_position (base_index_type, low);
2746   base_low_pos = discrete_position (base_index_type, base_low);
2747
2748   if (!low_pos.has_value () || !base_low_pos.has_value ())
2749     {
2750       warning (_("unable to get positions in slice, use bounds instead"));
2751       low_pos = low;
2752       base_low_pos = base_low;
2753     }
2754
2755   ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
2756   if (stride == 0)
2757     stride = TYPE_LENGTH (TYPE_TARGET_TYPE (type0));
2758
2759   base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
2760   return value_at_lazy (slice_type, base);
2761 }
2762
2763
2764 static struct value *
2765 ada_value_slice (struct value *array, int low, int high)
2766 {
2767   struct type *type = ada_check_typedef (value_type (array));
2768   struct type *base_index_type = TYPE_TARGET_TYPE (type->index_type ());
2769   struct type *index_type
2770     = create_static_range_type (NULL, type->index_type (), low, high);
2771   struct type *slice_type = create_array_type_with_stride
2772                               (NULL, TYPE_TARGET_TYPE (type), index_type,
2773                                type->dyn_prop (DYN_PROP_BYTE_STRIDE),
2774                                TYPE_FIELD_BITSIZE (type, 0));
2775   gdb::optional<LONGEST> low_pos, high_pos;
2776
2777
2778   low_pos = discrete_position (base_index_type, low);
2779   high_pos = discrete_position (base_index_type, high);
2780
2781   if (!low_pos.has_value () || !high_pos.has_value ())
2782     {
2783       warning (_("unable to get positions in slice, use bounds instead"));
2784       low_pos = low;
2785       high_pos = high;
2786     }
2787
2788   return value_cast (slice_type,
2789                      value_slice (array, low, *high_pos - *low_pos + 1));
2790 }
2791
2792 /* If type is a record type in the form of a standard GNAT array
2793    descriptor, returns the number of dimensions for type.  If arr is a
2794    simple array, returns the number of "array of"s that prefix its
2795    type designation.  Otherwise, returns 0.  */
2796
2797 int
2798 ada_array_arity (struct type *type)
2799 {
2800   int arity;
2801
2802   if (type == NULL)
2803     return 0;
2804
2805   type = desc_base_type (type);
2806
2807   arity = 0;
2808   if (type->code () == TYPE_CODE_STRUCT)
2809     return desc_arity (desc_bounds_type (type));
2810   else
2811     while (type->code () == TYPE_CODE_ARRAY)
2812       {
2813         arity += 1;
2814         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2815       }
2816
2817   return arity;
2818 }
2819
2820 /* If TYPE is a record type in the form of a standard GNAT array
2821    descriptor or a simple array type, returns the element type for
2822    TYPE after indexing by NINDICES indices, or by all indices if
2823    NINDICES is -1.  Otherwise, returns NULL.  */
2824
2825 struct type *
2826 ada_array_element_type (struct type *type, int nindices)
2827 {
2828   type = desc_base_type (type);
2829
2830   if (type->code () == TYPE_CODE_STRUCT)
2831     {
2832       int k;
2833       struct type *p_array_type;
2834
2835       p_array_type = desc_data_target_type (type);
2836
2837       k = ada_array_arity (type);
2838       if (k == 0)
2839         return NULL;
2840
2841       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
2842       if (nindices >= 0 && k > nindices)
2843         k = nindices;
2844       while (k > 0 && p_array_type != NULL)
2845         {
2846           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2847           k -= 1;
2848         }
2849       return p_array_type;
2850     }
2851   else if (type->code () == TYPE_CODE_ARRAY)
2852     {
2853       while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
2854         {
2855           type = TYPE_TARGET_TYPE (type);
2856           nindices -= 1;
2857         }
2858       return type;
2859     }
2860
2861   return NULL;
2862 }
2863
2864 /* See ada-lang.h.  */
2865
2866 struct type *
2867 ada_index_type (struct type *type, int n, const char *name)
2868 {
2869   struct type *result_type;
2870
2871   type = desc_base_type (type);
2872
2873   if (n < 0 || n > ada_array_arity (type))
2874     error (_("invalid dimension number to '%s"), name);
2875
2876   if (ada_is_simple_array_type (type))
2877     {
2878       int i;
2879
2880       for (i = 1; i < n; i += 1)
2881         {
2882           type = ada_check_typedef (type);
2883           type = TYPE_TARGET_TYPE (type);
2884         }
2885       result_type = TYPE_TARGET_TYPE (ada_check_typedef (type)->index_type ());
2886       /* FIXME: The stabs type r(0,0);bound;bound in an array type
2887          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
2888          perhaps stabsread.c would make more sense.  */
2889       if (result_type && result_type->code () == TYPE_CODE_UNDEF)
2890         result_type = NULL;
2891     }
2892   else
2893     {
2894       result_type = desc_index_type (desc_bounds_type (type), n);
2895       if (result_type == NULL)
2896         error (_("attempt to take bound of something that is not an array"));
2897     }
2898
2899   return result_type;
2900 }
2901
2902 /* Given that arr is an array type, returns the lower bound of the
2903    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2904    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
2905    array-descriptor type.  It works for other arrays with bounds supplied
2906    by run-time quantities other than discriminants.  */
2907
2908 static LONGEST
2909 ada_array_bound_from_type (struct type *arr_type, int n, int which)
2910 {
2911   struct type *type, *index_type_desc, *index_type;
2912   int i;
2913
2914   gdb_assert (which == 0 || which == 1);
2915
2916   if (ada_is_constrained_packed_array_type (arr_type))
2917     arr_type = decode_constrained_packed_array_type (arr_type);
2918
2919   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2920     return (LONGEST) - which;
2921
2922   if (arr_type->code () == TYPE_CODE_PTR)
2923     type = TYPE_TARGET_TYPE (arr_type);
2924   else
2925     type = arr_type;
2926
2927   if (type->is_fixed_instance ())
2928     {
2929       /* The array has already been fixed, so we do not need to
2930          check the parallel ___XA type again.  That encoding has
2931          already been applied, so ignore it now.  */
2932       index_type_desc = NULL;
2933     }
2934   else
2935     {
2936       index_type_desc = ada_find_parallel_type (type, "___XA");
2937       ada_fixup_array_indexes_type (index_type_desc);
2938     }
2939
2940   if (index_type_desc != NULL)
2941     index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
2942                                       NULL);
2943   else
2944     {
2945       struct type *elt_type = check_typedef (type);
2946
2947       for (i = 1; i < n; i++)
2948         elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
2949
2950       index_type = elt_type->index_type ();
2951     }
2952
2953   return
2954     (LONGEST) (which == 0
2955                ? ada_discrete_type_low_bound (index_type)
2956                : ada_discrete_type_high_bound (index_type));
2957 }
2958
2959 /* Given that arr is an array value, returns the lower bound of the
2960    nth index (numbering from 1) if WHICH is 0, and the upper bound if
2961    WHICH is 1.  This routine will also work for arrays with bounds
2962    supplied by run-time quantities other than discriminants.  */
2963
2964 static LONGEST
2965 ada_array_bound (struct value *arr, int n, int which)
2966 {
2967   struct type *arr_type;
2968
2969   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2970     arr = value_ind (arr);
2971   arr_type = value_enclosing_type (arr);
2972
2973   if (ada_is_constrained_packed_array_type (arr_type))
2974     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
2975   else if (ada_is_simple_array_type (arr_type))
2976     return ada_array_bound_from_type (arr_type, n, which);
2977   else
2978     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
2979 }
2980
2981 /* Given that arr is an array value, returns the length of the
2982    nth index.  This routine will also work for arrays with bounds
2983    supplied by run-time quantities other than discriminants.
2984    Does not work for arrays indexed by enumeration types with representation
2985    clauses at the moment.  */
2986
2987 static LONGEST
2988 ada_array_length (struct value *arr, int n)
2989 {
2990   struct type *arr_type, *index_type;
2991   int low, high;
2992
2993   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2994     arr = value_ind (arr);
2995   arr_type = value_enclosing_type (arr);
2996
2997   if (ada_is_constrained_packed_array_type (arr_type))
2998     return ada_array_length (decode_constrained_packed_array (arr), n);
2999
3000   if (ada_is_simple_array_type (arr_type))
3001     {
3002       low = ada_array_bound_from_type (arr_type, n, 0);
3003       high = ada_array_bound_from_type (arr_type, n, 1);
3004     }
3005   else
3006     {
3007       low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3008       high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3009     }
3010
3011   arr_type = check_typedef (arr_type);
3012   index_type = ada_index_type (arr_type, n, "length");
3013   if (index_type != NULL)
3014     {
3015       struct type *base_type;
3016       if (index_type->code () == TYPE_CODE_RANGE)
3017         base_type = TYPE_TARGET_TYPE (index_type);
3018       else
3019         base_type = index_type;
3020
3021       low = pos_atr (value_from_longest (base_type, low));
3022       high = pos_atr (value_from_longest (base_type, high));
3023     }
3024   return high - low + 1;
3025 }
3026
3027 /* An array whose type is that of ARR_TYPE (an array type), with
3028    bounds LOW to HIGH, but whose contents are unimportant.  If HIGH is
3029    less than LOW, then LOW-1 is used.  */
3030
3031 static struct value *
3032 empty_array (struct type *arr_type, int low, int high)
3033 {
3034   struct type *arr_type0 = ada_check_typedef (arr_type);
3035   struct type *index_type
3036     = create_static_range_type
3037         (NULL, TYPE_TARGET_TYPE (arr_type0->index_type ()), low,
3038          high < low ? low - 1 : high);
3039   struct type *elt_type = ada_array_element_type (arr_type0, 1);
3040
3041   return allocate_value (create_array_type (NULL, elt_type, index_type));
3042 }
3043 \f
3044
3045                                 /* Name resolution */
3046
3047 /* The "decoded" name for the user-definable Ada operator corresponding
3048    to OP.  */
3049
3050 static const char *
3051 ada_decoded_op_name (enum exp_opcode op)
3052 {
3053   int i;
3054
3055   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3056     {
3057       if (ada_opname_table[i].op == op)
3058         return ada_opname_table[i].decoded;
3059     }
3060   error (_("Could not find operator name for opcode"));
3061 }
3062
3063 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3064    in a listing of choices during disambiguation (see sort_choices, below).
3065    The idea is that overloadings of a subprogram name from the
3066    same package should sort in their source order.  We settle for ordering
3067    such symbols by their trailing number (__N  or $N).  */
3068
3069 static int
3070 encoded_ordered_before (const char *N0, const char *N1)
3071 {
3072   if (N1 == NULL)
3073     return 0;
3074   else if (N0 == NULL)
3075     return 1;
3076   else
3077     {
3078       int k0, k1;
3079
3080       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3081         ;
3082       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3083         ;
3084       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3085           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3086         {
3087           int n0, n1;
3088
3089           n0 = k0;
3090           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3091             n0 -= 1;
3092           n1 = k1;
3093           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3094             n1 -= 1;
3095           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3096             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3097         }
3098       return (strcmp (N0, N1) < 0);
3099     }
3100 }
3101
3102 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3103    encoded names.  */
3104
3105 static void
3106 sort_choices (struct block_symbol syms[], int nsyms)
3107 {
3108   int i;
3109
3110   for (i = 1; i < nsyms; i += 1)
3111     {
3112       struct block_symbol sym = syms[i];
3113       int j;
3114
3115       for (j = i - 1; j >= 0; j -= 1)
3116         {
3117           if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3118                                       sym.symbol->linkage_name ()))
3119             break;
3120           syms[j + 1] = syms[j];
3121         }
3122       syms[j + 1] = sym;
3123     }
3124 }
3125
3126 /* Whether GDB should display formals and return types for functions in the
3127    overloads selection menu.  */
3128 static bool print_signatures = true;
3129
3130 /* Print the signature for SYM on STREAM according to the FLAGS options.  For
3131    all but functions, the signature is just the name of the symbol.  For
3132    functions, this is the name of the function, the list of types for formals
3133    and the return type (if any).  */
3134
3135 static void
3136 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3137                             const struct type_print_options *flags)
3138 {
3139   struct type *type = SYMBOL_TYPE (sym);
3140
3141   fprintf_filtered (stream, "%s", sym->print_name ());
3142   if (!print_signatures
3143       || type == NULL
3144       || type->code () != TYPE_CODE_FUNC)
3145     return;
3146
3147   if (type->num_fields () > 0)
3148     {
3149       int i;
3150
3151       fprintf_filtered (stream, " (");
3152       for (i = 0; i < type->num_fields (); ++i)
3153         {
3154           if (i > 0)
3155             fprintf_filtered (stream, "; ");
3156           ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3157                           flags);
3158         }
3159       fprintf_filtered (stream, ")");
3160     }
3161   if (TYPE_TARGET_TYPE (type) != NULL
3162       && TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_VOID)
3163     {
3164       fprintf_filtered (stream, " return ");
3165       ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3166     }
3167 }
3168
3169 /* Read and validate a set of numeric choices from the user in the
3170    range 0 .. N_CHOICES-1.  Place the results in increasing
3171    order in CHOICES[0 .. N-1], and return N.
3172
3173    The user types choices as a sequence of numbers on one line
3174    separated by blanks, encoding them as follows:
3175
3176      + A choice of 0 means to cancel the selection, throwing an error.
3177      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3178      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3179
3180    The user is not allowed to choose more than MAX_RESULTS values.
3181
3182    ANNOTATION_SUFFIX, if present, is used to annotate the input
3183    prompts (for use with the -f switch).  */
3184
3185 static int
3186 get_selections (int *choices, int n_choices, int max_results,
3187                 int is_all_choice, const char *annotation_suffix)
3188 {
3189   const char *args;
3190   const char *prompt;
3191   int n_chosen;
3192   int first_choice = is_all_choice ? 2 : 1;
3193
3194   prompt = getenv ("PS2");
3195   if (prompt == NULL)
3196     prompt = "> ";
3197
3198   args = command_line_input (prompt, annotation_suffix);
3199
3200   if (args == NULL)
3201     error_no_arg (_("one or more choice numbers"));
3202
3203   n_chosen = 0;
3204
3205   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3206      order, as given in args.  Choices are validated.  */
3207   while (1)
3208     {
3209       char *args2;
3210       int choice, j;
3211
3212       args = skip_spaces (args);
3213       if (*args == '\0' && n_chosen == 0)
3214         error_no_arg (_("one or more choice numbers"));
3215       else if (*args == '\0')
3216         break;
3217
3218       choice = strtol (args, &args2, 10);
3219       if (args == args2 || choice < 0
3220           || choice > n_choices + first_choice - 1)
3221         error (_("Argument must be choice number"));
3222       args = args2;
3223
3224       if (choice == 0)
3225         error (_("cancelled"));
3226
3227       if (choice < first_choice)
3228         {
3229           n_chosen = n_choices;
3230           for (j = 0; j < n_choices; j += 1)
3231             choices[j] = j;
3232           break;
3233         }
3234       choice -= first_choice;
3235
3236       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3237         {
3238         }
3239
3240       if (j < 0 || choice != choices[j])
3241         {
3242           int k;
3243
3244           for (k = n_chosen - 1; k > j; k -= 1)
3245             choices[k + 1] = choices[k];
3246           choices[j + 1] = choice;
3247           n_chosen += 1;
3248         }
3249     }
3250
3251   if (n_chosen > max_results)
3252     error (_("Select no more than %d of the above"), max_results);
3253
3254   return n_chosen;
3255 }
3256
3257 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3258    by asking the user (if necessary), returning the number selected,
3259    and setting the first elements of SYMS items.  Error if no symbols
3260    selected.  */
3261
3262 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3263    to be re-integrated one of these days.  */
3264
3265 static int
3266 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3267 {
3268   int i;
3269   int *chosen = XALLOCAVEC (int , nsyms);
3270   int n_chosen;
3271   int first_choice = (max_results == 1) ? 1 : 2;
3272   const char *select_mode = multiple_symbols_select_mode ();
3273
3274   if (max_results < 1)
3275     error (_("Request to select 0 symbols!"));
3276   if (nsyms <= 1)
3277     return nsyms;
3278
3279   if (select_mode == multiple_symbols_cancel)
3280     error (_("\
3281 canceled because the command is ambiguous\n\
3282 See set/show multiple-symbol."));
3283
3284   /* If select_mode is "all", then return all possible symbols.
3285      Only do that if more than one symbol can be selected, of course.
3286      Otherwise, display the menu as usual.  */
3287   if (select_mode == multiple_symbols_all && max_results > 1)
3288     return nsyms;
3289
3290   printf_filtered (_("[0] cancel\n"));
3291   if (max_results > 1)
3292     printf_filtered (_("[1] all\n"));
3293
3294   sort_choices (syms, nsyms);
3295
3296   for (i = 0; i < nsyms; i += 1)
3297     {
3298       if (syms[i].symbol == NULL)
3299         continue;
3300
3301       if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
3302         {
3303           struct symtab_and_line sal =
3304             find_function_start_sal (syms[i].symbol, 1);
3305
3306           printf_filtered ("[%d] ", i + first_choice);
3307           ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3308                                       &type_print_raw_options);
3309           if (sal.symtab == NULL)
3310             printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3311                              metadata_style.style ().ptr (), nullptr, sal.line);
3312           else
3313             printf_filtered
3314               (_(" at %ps:%d\n"),
3315                styled_string (file_name_style.style (),
3316                               symtab_to_filename_for_display (sal.symtab)),
3317                sal.line);
3318           continue;
3319         }
3320       else
3321         {
3322           int is_enumeral =
3323             (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3324              && SYMBOL_TYPE (syms[i].symbol) != NULL
3325              && SYMBOL_TYPE (syms[i].symbol)->code () == TYPE_CODE_ENUM);
3326           struct symtab *symtab = NULL;
3327
3328           if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3329             symtab = symbol_symtab (syms[i].symbol);
3330
3331           if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
3332             {
3333               printf_filtered ("[%d] ", i + first_choice);
3334               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3335                                           &type_print_raw_options);
3336               printf_filtered (_(" at %s:%d\n"),
3337                                symtab_to_filename_for_display (symtab),
3338                                SYMBOL_LINE (syms[i].symbol));
3339             }
3340           else if (is_enumeral
3341                    && SYMBOL_TYPE (syms[i].symbol)->name () != NULL)
3342             {
3343               printf_filtered (("[%d] "), i + first_choice);
3344               ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
3345                               gdb_stdout, -1, 0, &type_print_raw_options);
3346               printf_filtered (_("'(%s) (enumeral)\n"),
3347                                syms[i].symbol->print_name ());
3348             }
3349           else
3350             {
3351               printf_filtered ("[%d] ", i + first_choice);
3352               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3353                                           &type_print_raw_options);
3354
3355               if (symtab != NULL)
3356                 printf_filtered (is_enumeral
3357                                  ? _(" in %s (enumeral)\n")
3358                                  : _(" at %s:?\n"),
3359                                  symtab_to_filename_for_display (symtab));
3360               else
3361                 printf_filtered (is_enumeral
3362                                  ? _(" (enumeral)\n")
3363                                  : _(" at ?\n"));
3364             }
3365         }
3366     }
3367
3368   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3369                              "overload-choice");
3370
3371   for (i = 0; i < n_chosen; i += 1)
3372     syms[i] = syms[chosen[i]];
3373
3374   return n_chosen;
3375 }
3376
3377 /* See ada-lang.h.  */
3378
3379 block_symbol
3380 ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
3381                           int nargs, value *argvec[])
3382 {
3383   if (possible_user_operator_p (op, argvec))
3384     {
3385       std::vector<struct block_symbol> candidates
3386         = ada_lookup_symbol_list (ada_decoded_op_name (op),
3387                                   NULL, VAR_DOMAIN);
3388
3389       int i = ada_resolve_function (candidates, argvec,
3390                                     nargs, ada_decoded_op_name (op), NULL,
3391                                     parse_completion);
3392       if (i >= 0)
3393         return candidates[i];
3394     }
3395   return {};
3396 }
3397
3398 /* See ada-lang.h.  */
3399
3400 block_symbol
3401 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3402                      struct type *context_type,
3403                      bool parse_completion,
3404                      int nargs, value *argvec[],
3405                      innermost_block_tracker *tracker)
3406 {
3407   std::vector<struct block_symbol> candidates
3408     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3409
3410   int i;
3411   if (candidates.size () == 1)
3412     i = 0;
3413   else
3414     {
3415       i = ada_resolve_function
3416         (candidates,
3417          argvec, nargs,
3418          sym->linkage_name (),
3419          context_type, parse_completion);
3420       if (i < 0)
3421         error (_("Could not find a match for %s"), sym->print_name ());
3422     }
3423
3424   tracker->update (candidates[i]);
3425   return candidates[i];
3426 }
3427
3428 /* See ada-lang.h.  */
3429
3430 block_symbol
3431 ada_resolve_variable (struct symbol *sym, const struct block *block,
3432                       struct type *context_type,
3433                       bool parse_completion,
3434                       int deprocedure_p,
3435                       innermost_block_tracker *tracker)
3436 {
3437   std::vector<struct block_symbol> candidates
3438     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3439
3440   if (std::any_of (candidates.begin (),
3441                    candidates.end (),
3442                    [] (block_symbol &bsym)
3443                    {
3444                      switch (SYMBOL_CLASS (bsym.symbol))
3445                        {
3446                        case LOC_REGISTER:
3447                        case LOC_ARG:
3448                        case LOC_REF_ARG:
3449                        case LOC_REGPARM_ADDR:
3450                        case LOC_LOCAL:
3451                        case LOC_COMPUTED:
3452                          return true;
3453                        default:
3454                          return false;
3455                        }
3456                    }))
3457     {
3458       /* Types tend to get re-introduced locally, so if there
3459          are any local symbols that are not types, first filter
3460          out all types.  */
3461       candidates.erase
3462         (std::remove_if
3463          (candidates.begin (),
3464           candidates.end (),
3465           [] (block_symbol &bsym)
3466           {
3467             return SYMBOL_CLASS (bsym.symbol) == LOC_TYPEDEF;
3468           }),
3469          candidates.end ());
3470     }
3471
3472   int i;
3473   if (candidates.empty ())
3474     error (_("No definition found for %s"), sym->print_name ());
3475   else if (candidates.size () == 1)
3476     i = 0;
3477   else if (deprocedure_p && !is_nonfunction (candidates))
3478     {
3479       i = ada_resolve_function
3480         (candidates, NULL, 0,
3481          sym->linkage_name (),
3482          context_type, parse_completion);
3483       if (i < 0)
3484         error (_("Could not find a match for %s"), sym->print_name ());
3485     }
3486   else
3487     {
3488       printf_filtered (_("Multiple matches for %s\n"), sym->print_name ());
3489       user_select_syms (candidates.data (), candidates.size (), 1);
3490       i = 0;
3491     }
3492
3493   tracker->update (candidates[i]);
3494   return candidates[i];
3495 }
3496
3497 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  */
3498 /* The term "match" here is rather loose.  The match is heuristic and
3499    liberal.  */
3500
3501 static int
3502 ada_type_match (struct type *ftype, struct type *atype)
3503 {
3504   ftype = ada_check_typedef (ftype);
3505   atype = ada_check_typedef (atype);
3506
3507   if (ftype->code () == TYPE_CODE_REF)
3508     ftype = TYPE_TARGET_TYPE (ftype);
3509   if (atype->code () == TYPE_CODE_REF)
3510     atype = TYPE_TARGET_TYPE (atype);
3511
3512   switch (ftype->code ())
3513     {
3514     default:
3515       return ftype->code () == atype->code ();
3516     case TYPE_CODE_PTR:
3517       if (atype->code () != TYPE_CODE_PTR)
3518         return 0;
3519       atype = TYPE_TARGET_TYPE (atype);
3520       /* This can only happen if the actual argument is 'null'.  */
3521       if (atype->code () == TYPE_CODE_INT && TYPE_LENGTH (atype) == 0)
3522         return 1;
3523       return ada_type_match (TYPE_TARGET_TYPE (ftype), atype);
3524     case TYPE_CODE_INT:
3525     case TYPE_CODE_ENUM:
3526     case TYPE_CODE_RANGE:
3527       switch (atype->code ())
3528         {
3529         case TYPE_CODE_INT:
3530         case TYPE_CODE_ENUM:
3531         case TYPE_CODE_RANGE:
3532           return 1;
3533         default:
3534           return 0;
3535         }
3536
3537     case TYPE_CODE_ARRAY:
3538       return (atype->code () == TYPE_CODE_ARRAY
3539               || ada_is_array_descriptor_type (atype));
3540
3541     case TYPE_CODE_STRUCT:
3542       if (ada_is_array_descriptor_type (ftype))
3543         return (atype->code () == TYPE_CODE_ARRAY
3544                 || ada_is_array_descriptor_type (atype));
3545       else
3546         return (atype->code () == TYPE_CODE_STRUCT
3547                 && !ada_is_array_descriptor_type (atype));
3548
3549     case TYPE_CODE_UNION:
3550     case TYPE_CODE_FLT:
3551       return (atype->code () == ftype->code ());
3552     }
3553 }
3554
3555 /* Return non-zero if the formals of FUNC "sufficiently match" the
3556    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3557    may also be an enumeral, in which case it is treated as a 0-
3558    argument function.  */
3559
3560 static int
3561 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3562 {
3563   int i;
3564   struct type *func_type = SYMBOL_TYPE (func);
3565
3566   if (SYMBOL_CLASS (func) == LOC_CONST
3567       && func_type->code () == TYPE_CODE_ENUM)
3568     return (n_actuals == 0);
3569   else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3570     return 0;
3571
3572   if (func_type->num_fields () != n_actuals)
3573     return 0;
3574
3575   for (i = 0; i < n_actuals; i += 1)
3576     {
3577       if (actuals[i] == NULL)
3578         return 0;
3579       else
3580         {
3581           struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3582           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3583
3584           if (!ada_type_match (ftype, atype))
3585             return 0;
3586         }
3587     }
3588   return 1;
3589 }
3590
3591 /* False iff function type FUNC_TYPE definitely does not produce a value
3592    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3593    FUNC_TYPE is not a valid function type with a non-null return type
3594    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3595
3596 static int
3597 return_match (struct type *func_type, struct type *context_type)
3598 {
3599   struct type *return_type;
3600
3601   if (func_type == NULL)
3602     return 1;
3603
3604   if (func_type->code () == TYPE_CODE_FUNC)
3605     return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3606   else
3607     return_type = get_base_type (func_type);
3608   if (return_type == NULL)
3609     return 1;
3610
3611   context_type = get_base_type (context_type);
3612
3613   if (return_type->code () == TYPE_CODE_ENUM)
3614     return context_type == NULL || return_type == context_type;
3615   else if (context_type == NULL)
3616     return return_type->code () != TYPE_CODE_VOID;
3617   else
3618     return return_type->code () == context_type->code ();
3619 }
3620
3621
3622 /* Returns the index in SYMS that contains the symbol for the
3623    function (if any) that matches the types of the NARGS arguments in
3624    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
3625    that returns that type, then eliminate matches that don't.  If
3626    CONTEXT_TYPE is void and there is at least one match that does not
3627    return void, eliminate all matches that do.
3628
3629    Asks the user if there is more than one match remaining.  Returns -1
3630    if there is no such symbol or none is selected.  NAME is used
3631    solely for messages.  May re-arrange and modify SYMS in
3632    the process; the index returned is for the modified vector.  */
3633
3634 static int
3635 ada_resolve_function (std::vector<struct block_symbol> &syms,
3636                       struct value **args, int nargs,
3637                       const char *name, struct type *context_type,
3638                       bool parse_completion)
3639 {
3640   int fallback;
3641   int k;
3642   int m;                        /* Number of hits */
3643
3644   m = 0;
3645   /* In the first pass of the loop, we only accept functions matching
3646      context_type.  If none are found, we add a second pass of the loop
3647      where every function is accepted.  */
3648   for (fallback = 0; m == 0 && fallback < 2; fallback++)
3649     {
3650       for (k = 0; k < syms.size (); k += 1)
3651         {
3652           struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
3653
3654           if (ada_args_match (syms[k].symbol, args, nargs)
3655               && (fallback || return_match (type, context_type)))
3656             {
3657               syms[m] = syms[k];
3658               m += 1;
3659             }
3660         }
3661     }
3662
3663   /* If we got multiple matches, ask the user which one to use.  Don't do this
3664      interactive thing during completion, though, as the purpose of the
3665      completion is providing a list of all possible matches.  Prompting the
3666      user to filter it down would be completely unexpected in this case.  */
3667   if (m == 0)
3668     return -1;
3669   else if (m > 1 && !parse_completion)
3670     {
3671       printf_filtered (_("Multiple matches for %s\n"), name);
3672       user_select_syms (syms.data (), m, 1);
3673       return 0;
3674     }
3675   return 0;
3676 }
3677
3678 /* Type-class predicates */
3679
3680 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3681    or FLOAT).  */
3682
3683 static int
3684 numeric_type_p (struct type *type)
3685 {
3686   if (type == NULL)
3687     return 0;
3688   else
3689     {
3690       switch (type->code ())
3691         {
3692         case TYPE_CODE_INT:
3693         case TYPE_CODE_FLT:
3694         case TYPE_CODE_FIXED_POINT:
3695           return 1;
3696         case TYPE_CODE_RANGE:
3697           return (type == TYPE_TARGET_TYPE (type)
3698                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
3699         default:
3700           return 0;
3701         }
3702     }
3703 }
3704
3705 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
3706
3707 static int
3708 integer_type_p (struct type *type)
3709 {
3710   if (type == NULL)
3711     return 0;
3712   else
3713     {
3714       switch (type->code ())
3715         {
3716         case TYPE_CODE_INT:
3717           return 1;
3718         case TYPE_CODE_RANGE:
3719           return (type == TYPE_TARGET_TYPE (type)
3720                   || integer_type_p (TYPE_TARGET_TYPE (type)));
3721         default:
3722           return 0;
3723         }
3724     }
3725 }
3726
3727 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
3728
3729 static int
3730 scalar_type_p (struct type *type)
3731 {
3732   if (type == NULL)
3733     return 0;
3734   else
3735     {
3736       switch (type->code ())
3737         {
3738         case TYPE_CODE_INT:
3739         case TYPE_CODE_RANGE:
3740         case TYPE_CODE_ENUM:
3741         case TYPE_CODE_FLT:
3742         case TYPE_CODE_FIXED_POINT:
3743           return 1;
3744         default:
3745           return 0;
3746         }
3747     }
3748 }
3749
3750 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
3751
3752 static int
3753 discrete_type_p (struct type *type)
3754 {
3755   if (type == NULL)
3756     return 0;
3757   else
3758     {
3759       switch (type->code ())
3760         {
3761         case TYPE_CODE_INT:
3762         case TYPE_CODE_RANGE:
3763         case TYPE_CODE_ENUM:
3764         case TYPE_CODE_BOOL:
3765           return 1;
3766         default:
3767           return 0;
3768         }
3769     }
3770 }
3771
3772 /* Returns non-zero if OP with operands in the vector ARGS could be
3773    a user-defined function.  Errs on the side of pre-defined operators
3774    (i.e., result 0).  */
3775
3776 static int
3777 possible_user_operator_p (enum exp_opcode op, struct value *args[])
3778 {
3779   struct type *type0 =
3780     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
3781   struct type *type1 =
3782     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
3783
3784   if (type0 == NULL)
3785     return 0;
3786
3787   switch (op)
3788     {
3789     default:
3790       return 0;
3791
3792     case BINOP_ADD:
3793     case BINOP_SUB:
3794     case BINOP_MUL:
3795     case BINOP_DIV:
3796       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
3797
3798     case BINOP_REM:
3799     case BINOP_MOD:
3800     case BINOP_BITWISE_AND:
3801     case BINOP_BITWISE_IOR:
3802     case BINOP_BITWISE_XOR:
3803       return (!(integer_type_p (type0) && integer_type_p (type1)));
3804
3805     case BINOP_EQUAL:
3806     case BINOP_NOTEQUAL:
3807     case BINOP_LESS:
3808     case BINOP_GTR:
3809     case BINOP_LEQ:
3810     case BINOP_GEQ:
3811       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
3812
3813     case BINOP_CONCAT:
3814       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
3815
3816     case BINOP_EXP:
3817       return (!(numeric_type_p (type0) && integer_type_p (type1)));
3818
3819     case UNOP_NEG:
3820     case UNOP_PLUS:
3821     case UNOP_LOGICAL_NOT:
3822     case UNOP_ABS:
3823       return (!numeric_type_p (type0));
3824
3825     }
3826 }
3827 \f
3828                                 /* Renaming */
3829
3830 /* NOTES: 
3831
3832    1. In the following, we assume that a renaming type's name may
3833       have an ___XD suffix.  It would be nice if this went away at some
3834       point.
3835    2. We handle both the (old) purely type-based representation of 
3836       renamings and the (new) variable-based encoding.  At some point,
3837       it is devoutly to be hoped that the former goes away 
3838       (FIXME: hilfinger-2007-07-09).
3839    3. Subprogram renamings are not implemented, although the XRS
3840       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
3841
3842 /* If SYM encodes a renaming, 
3843
3844        <renaming> renames <renamed entity>,
3845
3846    sets *LEN to the length of the renamed entity's name,
3847    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3848    the string describing the subcomponent selected from the renamed
3849    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3850    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3851    are undefined).  Otherwise, returns a value indicating the category
3852    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3853    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3854    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
3855    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3856    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3857    may be NULL, in which case they are not assigned.
3858
3859    [Currently, however, GCC does not generate subprogram renamings.]  */
3860
3861 enum ada_renaming_category
3862 ada_parse_renaming (struct symbol *sym,
3863                     const char **renamed_entity, int *len, 
3864                     const char **renaming_expr)
3865 {
3866   enum ada_renaming_category kind;
3867   const char *info;
3868   const char *suffix;
3869
3870   if (sym == NULL)
3871     return ADA_NOT_RENAMING;
3872   switch (SYMBOL_CLASS (sym)) 
3873     {
3874     default:
3875       return ADA_NOT_RENAMING;
3876     case LOC_LOCAL:
3877     case LOC_STATIC:
3878     case LOC_COMPUTED:
3879     case LOC_OPTIMIZED_OUT:
3880       info = strstr (sym->linkage_name (), "___XR");
3881       if (info == NULL)
3882         return ADA_NOT_RENAMING;
3883       switch (info[5])
3884         {
3885         case '_':
3886           kind = ADA_OBJECT_RENAMING;
3887           info += 6;
3888           break;
3889         case 'E':
3890           kind = ADA_EXCEPTION_RENAMING;
3891           info += 7;
3892           break;
3893         case 'P':
3894           kind = ADA_PACKAGE_RENAMING;
3895           info += 7;
3896           break;
3897         case 'S':
3898           kind = ADA_SUBPROGRAM_RENAMING;
3899           info += 7;
3900           break;
3901         default:
3902           return ADA_NOT_RENAMING;
3903         }
3904     }
3905
3906   if (renamed_entity != NULL)
3907     *renamed_entity = info;
3908   suffix = strstr (info, "___XE");
3909   if (suffix == NULL || suffix == info)
3910     return ADA_NOT_RENAMING;
3911   if (len != NULL)
3912     *len = strlen (info) - strlen (suffix);
3913   suffix += 5;
3914   if (renaming_expr != NULL)
3915     *renaming_expr = suffix;
3916   return kind;
3917 }
3918
3919 /* Compute the value of the given RENAMING_SYM, which is expected to
3920    be a symbol encoding a renaming expression.  BLOCK is the block
3921    used to evaluate the renaming.  */
3922
3923 static struct value *
3924 ada_read_renaming_var_value (struct symbol *renaming_sym,
3925                              const struct block *block)
3926 {
3927   const char *sym_name;
3928
3929   sym_name = renaming_sym->linkage_name ();
3930   expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
3931   return evaluate_expression (expr.get ());
3932 }
3933 \f
3934
3935                                 /* Evaluation: Function Calls */
3936
3937 /* Return an lvalue containing the value VAL.  This is the identity on
3938    lvalues, and otherwise has the side-effect of allocating memory
3939    in the inferior where a copy of the value contents is copied.  */
3940
3941 static struct value *
3942 ensure_lval (struct value *val)
3943 {
3944   if (VALUE_LVAL (val) == not_lval
3945       || VALUE_LVAL (val) == lval_internalvar)
3946     {
3947       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
3948       const CORE_ADDR addr =
3949         value_as_long (value_allocate_space_in_inferior (len));
3950
3951       VALUE_LVAL (val) = lval_memory;
3952       set_value_address (val, addr);
3953       write_memory (addr, value_contents (val), len);
3954     }
3955
3956   return val;
3957 }
3958
3959 /* Given ARG, a value of type (pointer or reference to a)*
3960    structure/union, extract the component named NAME from the ultimate
3961    target structure/union and return it as a value with its
3962    appropriate type.
3963
3964    The routine searches for NAME among all members of the structure itself
3965    and (recursively) among all members of any wrapper members
3966    (e.g., '_parent').
3967
3968    If NO_ERR, then simply return NULL in case of error, rather than
3969    calling error.  */
3970
3971 static struct value *
3972 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
3973 {
3974   struct type *t, *t1;
3975   struct value *v;
3976   int check_tag;
3977
3978   v = NULL;
3979   t1 = t = ada_check_typedef (value_type (arg));
3980   if (t->code () == TYPE_CODE_REF)
3981     {
3982       t1 = TYPE_TARGET_TYPE (t);
3983       if (t1 == NULL)
3984         goto BadValue;
3985       t1 = ada_check_typedef (t1);
3986       if (t1->code () == TYPE_CODE_PTR)
3987         {
3988           arg = coerce_ref (arg);
3989           t = t1;
3990         }
3991     }
3992
3993   while (t->code () == TYPE_CODE_PTR)
3994     {
3995       t1 = TYPE_TARGET_TYPE (t);
3996       if (t1 == NULL)
3997         goto BadValue;
3998       t1 = ada_check_typedef (t1);
3999       if (t1->code () == TYPE_CODE_PTR)
4000         {
4001           arg = value_ind (arg);
4002           t = t1;
4003         }
4004       else
4005         break;
4006     }
4007
4008   if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4009     goto BadValue;
4010
4011   if (t1 == t)
4012     v = ada_search_struct_field (name, arg, 0, t);
4013   else
4014     {
4015       int bit_offset, bit_size, byte_offset;
4016       struct type *field_type;
4017       CORE_ADDR address;
4018
4019       if (t->code () == TYPE_CODE_PTR)
4020         address = value_address (ada_value_ind (arg));
4021       else
4022         address = value_address (ada_coerce_ref (arg));
4023
4024       /* Check to see if this is a tagged type.  We also need to handle
4025          the case where the type is a reference to a tagged type, but
4026          we have to be careful to exclude pointers to tagged types.
4027          The latter should be shown as usual (as a pointer), whereas
4028          a reference should mostly be transparent to the user.  */
4029
4030       if (ada_is_tagged_type (t1, 0)
4031           || (t1->code () == TYPE_CODE_REF
4032               && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
4033         {
4034           /* We first try to find the searched field in the current type.
4035              If not found then let's look in the fixed type.  */
4036
4037           if (!find_struct_field (name, t1, 0,
4038                                   &field_type, &byte_offset, &bit_offset,
4039                                   &bit_size, NULL))
4040             check_tag = 1;
4041           else
4042             check_tag = 0;
4043         }
4044       else
4045         check_tag = 0;
4046
4047       /* Convert to fixed type in all cases, so that we have proper
4048          offsets to each field in unconstrained record types.  */
4049       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4050                               address, NULL, check_tag);
4051
4052       /* Resolve the dynamic type as well.  */
4053       arg = value_from_contents_and_address (t1, nullptr, address);
4054       t1 = value_type (arg);
4055
4056       if (find_struct_field (name, t1, 0,
4057                              &field_type, &byte_offset, &bit_offset,
4058                              &bit_size, NULL))
4059         {
4060           if (bit_size != 0)
4061             {
4062               if (t->code () == TYPE_CODE_REF)
4063                 arg = ada_coerce_ref (arg);
4064               else
4065                 arg = ada_value_ind (arg);
4066               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4067                                                   bit_offset, bit_size,
4068                                                   field_type);
4069             }
4070           else
4071             v = value_at_lazy (field_type, address + byte_offset);
4072         }
4073     }
4074
4075   if (v != NULL || no_err)
4076     return v;
4077   else
4078     error (_("There is no member named %s."), name);
4079
4080  BadValue:
4081   if (no_err)
4082     return NULL;
4083   else
4084     error (_("Attempt to extract a component of "
4085              "a value that is not a record."));
4086 }
4087
4088 /* Return the value ACTUAL, converted to be an appropriate value for a
4089    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4090    allocating any necessary descriptors (fat pointers), or copies of
4091    values not residing in memory, updating it as needed.  */
4092
4093 struct value *
4094 ada_convert_actual (struct value *actual, struct type *formal_type0)
4095 {
4096   struct type *actual_type = ada_check_typedef (value_type (actual));
4097   struct type *formal_type = ada_check_typedef (formal_type0);
4098   struct type *formal_target =
4099     formal_type->code () == TYPE_CODE_PTR
4100     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4101   struct type *actual_target =
4102     actual_type->code () == TYPE_CODE_PTR
4103     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4104
4105   if (ada_is_array_descriptor_type (formal_target)
4106       && actual_target->code () == TYPE_CODE_ARRAY)
4107     return make_array_descriptor (formal_type, actual);
4108   else if (formal_type->code () == TYPE_CODE_PTR
4109            || formal_type->code () == TYPE_CODE_REF)
4110     {
4111       struct value *result;
4112
4113       if (formal_target->code () == TYPE_CODE_ARRAY
4114           && ada_is_array_descriptor_type (actual_target))
4115         result = desc_data (actual);
4116       else if (formal_type->code () != TYPE_CODE_PTR)
4117         {
4118           if (VALUE_LVAL (actual) != lval_memory)
4119             {
4120               struct value *val;
4121
4122               actual_type = ada_check_typedef (value_type (actual));
4123               val = allocate_value (actual_type);
4124               memcpy ((char *) value_contents_raw (val),
4125                       (char *) value_contents (actual),
4126                       TYPE_LENGTH (actual_type));
4127               actual = ensure_lval (val);
4128             }
4129           result = value_addr (actual);
4130         }
4131       else
4132         return actual;
4133       return value_cast_pointers (formal_type, result, 0);
4134     }
4135   else if (actual_type->code () == TYPE_CODE_PTR)
4136     return ada_value_ind (actual);
4137   else if (ada_is_aligner_type (formal_type))
4138     {
4139       /* We need to turn this parameter into an aligner type
4140          as well.  */
4141       struct value *aligner = allocate_value (formal_type);
4142       struct value *component = ada_value_struct_elt (aligner, "F", 0);
4143
4144       value_assign_to_component (aligner, component, actual);
4145       return aligner;
4146     }
4147
4148   return actual;
4149 }
4150
4151 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4152    type TYPE.  This is usually an inefficient no-op except on some targets
4153    (such as AVR) where the representation of a pointer and an address
4154    differs.  */
4155
4156 static CORE_ADDR
4157 value_pointer (struct value *value, struct type *type)
4158 {
4159   unsigned len = TYPE_LENGTH (type);
4160   gdb_byte *buf = (gdb_byte *) alloca (len);
4161   CORE_ADDR addr;
4162
4163   addr = value_address (value);
4164   gdbarch_address_to_pointer (type->arch (), type, buf, addr);
4165   addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4166   return addr;
4167 }
4168
4169
4170 /* Push a descriptor of type TYPE for array value ARR on the stack at
4171    *SP, updating *SP to reflect the new descriptor.  Return either
4172    an lvalue representing the new descriptor, or (if TYPE is a pointer-
4173    to-descriptor type rather than a descriptor type), a struct value *
4174    representing a pointer to this descriptor.  */
4175
4176 static struct value *
4177 make_array_descriptor (struct type *type, struct value *arr)
4178 {
4179   struct type *bounds_type = desc_bounds_type (type);
4180   struct type *desc_type = desc_base_type (type);
4181   struct value *descriptor = allocate_value (desc_type);
4182   struct value *bounds = allocate_value (bounds_type);
4183   int i;
4184
4185   for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4186        i > 0; i -= 1)
4187     {
4188       modify_field (value_type (bounds), value_contents_writeable (bounds),
4189                     ada_array_bound (arr, i, 0),
4190                     desc_bound_bitpos (bounds_type, i, 0),
4191                     desc_bound_bitsize (bounds_type, i, 0));
4192       modify_field (value_type (bounds), value_contents_writeable (bounds),
4193                     ada_array_bound (arr, i, 1),
4194                     desc_bound_bitpos (bounds_type, i, 1),
4195                     desc_bound_bitsize (bounds_type, i, 1));
4196     }
4197
4198   bounds = ensure_lval (bounds);
4199
4200   modify_field (value_type (descriptor),
4201                 value_contents_writeable (descriptor),
4202                 value_pointer (ensure_lval (arr),
4203                                desc_type->field (0).type ()),
4204                 fat_pntr_data_bitpos (desc_type),
4205                 fat_pntr_data_bitsize (desc_type));
4206
4207   modify_field (value_type (descriptor),
4208                 value_contents_writeable (descriptor),
4209                 value_pointer (bounds,
4210                                desc_type->field (1).type ()),
4211                 fat_pntr_bounds_bitpos (desc_type),
4212                 fat_pntr_bounds_bitsize (desc_type));
4213
4214   descriptor = ensure_lval (descriptor);
4215
4216   if (type->code () == TYPE_CODE_PTR)
4217     return value_addr (descriptor);
4218   else
4219     return descriptor;
4220 }
4221 \f
4222                                 /* Symbol Cache Module */
4223
4224 /* Performance measurements made as of 2010-01-15 indicate that
4225    this cache does bring some noticeable improvements.  Depending
4226    on the type of entity being printed, the cache can make it as much
4227    as an order of magnitude faster than without it.
4228
4229    The descriptive type DWARF extension has significantly reduced
4230    the need for this cache, at least when DWARF is being used.  However,
4231    even in this case, some expensive name-based symbol searches are still
4232    sometimes necessary - to find an XVZ variable, mostly.  */
4233
4234 /* Return the symbol cache associated to the given program space PSPACE.
4235    If not allocated for this PSPACE yet, allocate and initialize one.  */
4236
4237 static struct ada_symbol_cache *
4238 ada_get_symbol_cache (struct program_space *pspace)
4239 {
4240   struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4241
4242   if (pspace_data->sym_cache == nullptr)
4243     pspace_data->sym_cache.reset (new ada_symbol_cache);
4244
4245   return pspace_data->sym_cache.get ();
4246 }
4247
4248 /* Clear all entries from the symbol cache.  */
4249
4250 static void
4251 ada_clear_symbol_cache ()
4252 {
4253   struct ada_pspace_data *pspace_data
4254     = get_ada_pspace_data (current_program_space);
4255
4256   if (pspace_data->sym_cache != nullptr)
4257     pspace_data->sym_cache.reset ();
4258 }
4259
4260 /* Search our cache for an entry matching NAME and DOMAIN.
4261    Return it if found, or NULL otherwise.  */
4262
4263 static struct cache_entry **
4264 find_entry (const char *name, domain_enum domain)
4265 {
4266   struct ada_symbol_cache *sym_cache
4267     = ada_get_symbol_cache (current_program_space);
4268   int h = msymbol_hash (name) % HASH_SIZE;
4269   struct cache_entry **e;
4270
4271   for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4272     {
4273       if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4274         return e;
4275     }
4276   return NULL;
4277 }
4278
4279 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4280    Return 1 if found, 0 otherwise.
4281
4282    If an entry was found and SYM is not NULL, set *SYM to the entry's
4283    SYM.  Same principle for BLOCK if not NULL.  */
4284
4285 static int
4286 lookup_cached_symbol (const char *name, domain_enum domain,
4287                       struct symbol **sym, const struct block **block)
4288 {
4289   struct cache_entry **e = find_entry (name, domain);
4290
4291   if (e == NULL)
4292     return 0;
4293   if (sym != NULL)
4294     *sym = (*e)->sym;
4295   if (block != NULL)
4296     *block = (*e)->block;
4297   return 1;
4298 }
4299
4300 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4301    in domain DOMAIN, save this result in our symbol cache.  */
4302
4303 static void
4304 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4305               const struct block *block)
4306 {
4307   struct ada_symbol_cache *sym_cache
4308     = ada_get_symbol_cache (current_program_space);
4309   int h;
4310   struct cache_entry *e;
4311
4312   /* Symbols for builtin types don't have a block.
4313      For now don't cache such symbols.  */
4314   if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4315     return;
4316
4317   /* If the symbol is a local symbol, then do not cache it, as a search
4318      for that symbol depends on the context.  To determine whether
4319      the symbol is local or not, we check the block where we found it
4320      against the global and static blocks of its associated symtab.  */
4321   if (sym
4322       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4323                             GLOBAL_BLOCK) != block
4324       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4325                             STATIC_BLOCK) != block)
4326     return;
4327
4328   h = msymbol_hash (name) % HASH_SIZE;
4329   e = XOBNEW (&sym_cache->cache_space, cache_entry);
4330   e->next = sym_cache->root[h];
4331   sym_cache->root[h] = e;
4332   e->name = obstack_strdup (&sym_cache->cache_space, name);
4333   e->sym = sym;
4334   e->domain = domain;
4335   e->block = block;
4336 }
4337 \f
4338                                 /* Symbol Lookup */
4339
4340 /* Return the symbol name match type that should be used used when
4341    searching for all symbols matching LOOKUP_NAME.
4342
4343    LOOKUP_NAME is expected to be a symbol name after transformation
4344    for Ada lookups.  */
4345
4346 static symbol_name_match_type
4347 name_match_type_from_name (const char *lookup_name)
4348 {
4349   return (strstr (lookup_name, "__") == NULL
4350           ? symbol_name_match_type::WILD
4351           : symbol_name_match_type::FULL);
4352 }
4353
4354 /* Return the result of a standard (literal, C-like) lookup of NAME in
4355    given DOMAIN, visible from lexical block BLOCK.  */
4356
4357 static struct symbol *
4358 standard_lookup (const char *name, const struct block *block,
4359                  domain_enum domain)
4360 {
4361   /* Initialize it just to avoid a GCC false warning.  */
4362   struct block_symbol sym = {};
4363
4364   if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4365     return sym.symbol;
4366   ada_lookup_encoded_symbol (name, block, domain, &sym);
4367   cache_symbol (name, domain, sym.symbol, sym.block);
4368   return sym.symbol;
4369 }
4370
4371
4372 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4373    in the symbol fields of SYMS.  We treat enumerals as functions, 
4374    since they contend in overloading in the same way.  */
4375 static int
4376 is_nonfunction (const std::vector<struct block_symbol> &syms)
4377 {
4378   for (const block_symbol &sym : syms)
4379     if (SYMBOL_TYPE (sym.symbol)->code () != TYPE_CODE_FUNC
4380         && (SYMBOL_TYPE (sym.symbol)->code () != TYPE_CODE_ENUM
4381             || SYMBOL_CLASS (sym.symbol) != LOC_CONST))
4382       return 1;
4383
4384   return 0;
4385 }
4386
4387 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4388    struct types.  Otherwise, they may not.  */
4389
4390 static int
4391 equiv_types (struct type *type0, struct type *type1)
4392 {
4393   if (type0 == type1)
4394     return 1;
4395   if (type0 == NULL || type1 == NULL
4396       || type0->code () != type1->code ())
4397     return 0;
4398   if ((type0->code () == TYPE_CODE_STRUCT
4399        || type0->code () == TYPE_CODE_ENUM)
4400       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4401       && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4402     return 1;
4403
4404   return 0;
4405 }
4406
4407 /* True iff SYM0 represents the same entity as SYM1, or one that is
4408    no more defined than that of SYM1.  */
4409
4410 static int
4411 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4412 {
4413   if (sym0 == sym1)
4414     return 1;
4415   if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4416       || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4417     return 0;
4418
4419   switch (SYMBOL_CLASS (sym0))
4420     {
4421     case LOC_UNDEF:
4422       return 1;
4423     case LOC_TYPEDEF:
4424       {
4425         struct type *type0 = SYMBOL_TYPE (sym0);
4426         struct type *type1 = SYMBOL_TYPE (sym1);
4427         const char *name0 = sym0->linkage_name ();
4428         const char *name1 = sym1->linkage_name ();
4429         int len0 = strlen (name0);
4430
4431         return
4432           type0->code () == type1->code ()
4433           && (equiv_types (type0, type1)
4434               || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4435                   && startswith (name1 + len0, "___XV")));
4436       }
4437     case LOC_CONST:
4438       return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4439         && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4440
4441     case LOC_STATIC:
4442       {
4443         const char *name0 = sym0->linkage_name ();
4444         const char *name1 = sym1->linkage_name ();
4445         return (strcmp (name0, name1) == 0
4446                 && SYMBOL_VALUE_ADDRESS (sym0) == SYMBOL_VALUE_ADDRESS (sym1));
4447       }
4448
4449     default:
4450       return 0;
4451     }
4452 }
4453
4454 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4455    records in RESULT.  Do nothing if SYM is a duplicate.  */
4456
4457 static void
4458 add_defn_to_vec (std::vector<struct block_symbol> &result,
4459                  struct symbol *sym,
4460                  const struct block *block)
4461 {
4462   /* Do not try to complete stub types, as the debugger is probably
4463      already scanning all symbols matching a certain name at the
4464      time when this function is called.  Trying to replace the stub
4465      type by its associated full type will cause us to restart a scan
4466      which may lead to an infinite recursion.  Instead, the client
4467      collecting the matching symbols will end up collecting several
4468      matches, with at least one of them complete.  It can then filter
4469      out the stub ones if needed.  */
4470
4471   for (int i = result.size () - 1; i >= 0; i -= 1)
4472     {
4473       if (lesseq_defined_than (sym, result[i].symbol))
4474         return;
4475       else if (lesseq_defined_than (result[i].symbol, sym))
4476         {
4477           result[i].symbol = sym;
4478           result[i].block = block;
4479           return;
4480         }
4481     }
4482
4483   struct block_symbol info;
4484   info.symbol = sym;
4485   info.block = block;
4486   result.push_back (info);
4487 }
4488
4489 /* Return a bound minimal symbol matching NAME according to Ada
4490    decoding rules.  Returns an invalid symbol if there is no such
4491    minimal symbol.  Names prefixed with "standard__" are handled
4492    specially: "standard__" is first stripped off, and only static and
4493    global symbols are searched.  */
4494
4495 struct bound_minimal_symbol
4496 ada_lookup_simple_minsym (const char *name)
4497 {
4498   struct bound_minimal_symbol result;
4499
4500   memset (&result, 0, sizeof (result));
4501
4502   symbol_name_match_type match_type = name_match_type_from_name (name);
4503   lookup_name_info lookup_name (name, match_type);
4504
4505   symbol_name_matcher_ftype *match_name
4506     = ada_get_symbol_name_matcher (lookup_name);
4507
4508   for (objfile *objfile : current_program_space->objfiles ())
4509     {
4510       for (minimal_symbol *msymbol : objfile->msymbols ())
4511         {
4512           if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4513               && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4514             {
4515               result.minsym = msymbol;
4516               result.objfile = objfile;
4517               break;
4518             }
4519         }
4520     }
4521
4522   return result;
4523 }
4524
4525 /* True if TYPE is definitely an artificial type supplied to a symbol
4526    for which no debugging information was given in the symbol file.  */
4527
4528 static int
4529 is_nondebugging_type (struct type *type)
4530 {
4531   const char *name = ada_type_name (type);
4532
4533   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4534 }
4535
4536 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4537    that are deemed "identical" for practical purposes.
4538
4539    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4540    types and that their number of enumerals is identical (in other
4541    words, type1->num_fields () == type2->num_fields ()).  */
4542
4543 static int
4544 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4545 {
4546   int i;
4547
4548   /* The heuristic we use here is fairly conservative.  We consider
4549      that 2 enumerate types are identical if they have the same
4550      number of enumerals and that all enumerals have the same
4551      underlying value and name.  */
4552
4553   /* All enums in the type should have an identical underlying value.  */
4554   for (i = 0; i < type1->num_fields (); i++)
4555     if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
4556       return 0;
4557
4558   /* All enumerals should also have the same name (modulo any numerical
4559      suffix).  */
4560   for (i = 0; i < type1->num_fields (); i++)
4561     {
4562       const char *name_1 = TYPE_FIELD_NAME (type1, i);
4563       const char *name_2 = TYPE_FIELD_NAME (type2, i);
4564       int len_1 = strlen (name_1);
4565       int len_2 = strlen (name_2);
4566
4567       ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4568       ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4569       if (len_1 != len_2
4570           || strncmp (TYPE_FIELD_NAME (type1, i),
4571                       TYPE_FIELD_NAME (type2, i),
4572                       len_1) != 0)
4573         return 0;
4574     }
4575
4576   return 1;
4577 }
4578
4579 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4580    that are deemed "identical" for practical purposes.  Sometimes,
4581    enumerals are not strictly identical, but their types are so similar
4582    that they can be considered identical.
4583
4584    For instance, consider the following code:
4585
4586       type Color is (Black, Red, Green, Blue, White);
4587       type RGB_Color is new Color range Red .. Blue;
4588
4589    Type RGB_Color is a subrange of an implicit type which is a copy
4590    of type Color. If we call that implicit type RGB_ColorB ("B" is
4591    for "Base Type"), then type RGB_ColorB is a copy of type Color.
4592    As a result, when an expression references any of the enumeral
4593    by name (Eg. "print green"), the expression is technically
4594    ambiguous and the user should be asked to disambiguate. But
4595    doing so would only hinder the user, since it wouldn't matter
4596    what choice he makes, the outcome would always be the same.
4597    So, for practical purposes, we consider them as the same.  */
4598
4599 static int
4600 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
4601 {
4602   int i;
4603
4604   /* Before performing a thorough comparison check of each type,
4605      we perform a series of inexpensive checks.  We expect that these
4606      checks will quickly fail in the vast majority of cases, and thus
4607      help prevent the unnecessary use of a more expensive comparison.
4608      Said comparison also expects us to make some of these checks
4609      (see ada_identical_enum_types_p).  */
4610
4611   /* Quick check: All symbols should have an enum type.  */
4612   for (i = 0; i < syms.size (); i++)
4613     if (SYMBOL_TYPE (syms[i].symbol)->code () != TYPE_CODE_ENUM)
4614       return 0;
4615
4616   /* Quick check: They should all have the same value.  */
4617   for (i = 1; i < syms.size (); i++)
4618     if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
4619       return 0;
4620
4621   /* Quick check: They should all have the same number of enumerals.  */
4622   for (i = 1; i < syms.size (); i++)
4623     if (SYMBOL_TYPE (syms[i].symbol)->num_fields ()
4624         != SYMBOL_TYPE (syms[0].symbol)->num_fields ())
4625       return 0;
4626
4627   /* All the sanity checks passed, so we might have a set of
4628      identical enumeration types.  Perform a more complete
4629      comparison of the type of each symbol.  */
4630   for (i = 1; i < syms.size (); i++)
4631     if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
4632                                      SYMBOL_TYPE (syms[0].symbol)))
4633       return 0;
4634
4635   return 1;
4636 }
4637
4638 /* Remove any non-debugging symbols in SYMS that definitely
4639    duplicate other symbols in the list (The only case I know of where
4640    this happens is when object files containing stabs-in-ecoff are
4641    linked with files containing ordinary ecoff debugging symbols (or no
4642    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.  */
4643
4644 static void
4645 remove_extra_symbols (std::vector<struct block_symbol> *syms)
4646 {
4647   int i, j;
4648
4649   /* We should never be called with less than 2 symbols, as there
4650      cannot be any extra symbol in that case.  But it's easy to
4651      handle, since we have nothing to do in that case.  */
4652   if (syms->size () < 2)
4653     return;
4654
4655   i = 0;
4656   while (i < syms->size ())
4657     {
4658       int remove_p = 0;
4659
4660       /* If two symbols have the same name and one of them is a stub type,
4661          the get rid of the stub.  */
4662
4663       if (SYMBOL_TYPE ((*syms)[i].symbol)->is_stub ()
4664           && (*syms)[i].symbol->linkage_name () != NULL)
4665         {
4666           for (j = 0; j < syms->size (); j++)
4667             {
4668               if (j != i
4669                   && !SYMBOL_TYPE ((*syms)[j].symbol)->is_stub ()
4670                   && (*syms)[j].symbol->linkage_name () != NULL
4671                   && strcmp ((*syms)[i].symbol->linkage_name (),
4672                              (*syms)[j].symbol->linkage_name ()) == 0)
4673                 remove_p = 1;
4674             }
4675         }
4676
4677       /* Two symbols with the same name, same class and same address
4678          should be identical.  */
4679
4680       else if ((*syms)[i].symbol->linkage_name () != NULL
4681           && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
4682           && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
4683         {
4684           for (j = 0; j < syms->size (); j += 1)
4685             {
4686               if (i != j
4687                   && (*syms)[j].symbol->linkage_name () != NULL
4688                   && strcmp ((*syms)[i].symbol->linkage_name (),
4689                              (*syms)[j].symbol->linkage_name ()) == 0
4690                   && SYMBOL_CLASS ((*syms)[i].symbol)
4691                        == SYMBOL_CLASS ((*syms)[j].symbol)
4692                   && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
4693                   == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
4694                 remove_p = 1;
4695             }
4696         }
4697       
4698       if (remove_p)
4699         syms->erase (syms->begin () + i);
4700       else
4701         i += 1;
4702     }
4703
4704   /* If all the remaining symbols are identical enumerals, then
4705      just keep the first one and discard the rest.
4706
4707      Unlike what we did previously, we do not discard any entry
4708      unless they are ALL identical.  This is because the symbol
4709      comparison is not a strict comparison, but rather a practical
4710      comparison.  If all symbols are considered identical, then
4711      we can just go ahead and use the first one and discard the rest.
4712      But if we cannot reduce the list to a single element, we have
4713      to ask the user to disambiguate anyways.  And if we have to
4714      present a multiple-choice menu, it's less confusing if the list
4715      isn't missing some choices that were identical and yet distinct.  */
4716   if (symbols_are_identical_enums (*syms))
4717     syms->resize (1);
4718 }
4719
4720 /* Given a type that corresponds to a renaming entity, use the type name
4721    to extract the scope (package name or function name, fully qualified,
4722    and following the GNAT encoding convention) where this renaming has been
4723    defined.  */
4724
4725 static std::string
4726 xget_renaming_scope (struct type *renaming_type)
4727 {
4728   /* The renaming types adhere to the following convention:
4729      <scope>__<rename>___<XR extension>.
4730      So, to extract the scope, we search for the "___XR" extension,
4731      and then backtrack until we find the first "__".  */
4732
4733   const char *name = renaming_type->name ();
4734   const char *suffix = strstr (name, "___XR");
4735   const char *last;
4736
4737   /* Now, backtrack a bit until we find the first "__".  Start looking
4738      at suffix - 3, as the <rename> part is at least one character long.  */
4739
4740   for (last = suffix - 3; last > name; last--)
4741     if (last[0] == '_' && last[1] == '_')
4742       break;
4743
4744   /* Make a copy of scope and return it.  */
4745   return std::string (name, last);
4746 }
4747
4748 /* Return nonzero if NAME corresponds to a package name.  */
4749
4750 static int
4751 is_package_name (const char *name)
4752 {
4753   /* Here, We take advantage of the fact that no symbols are generated
4754      for packages, while symbols are generated for each function.
4755      So the condition for NAME represent a package becomes equivalent
4756      to NAME not existing in our list of symbols.  There is only one
4757      small complication with library-level functions (see below).  */
4758
4759   /* If it is a function that has not been defined at library level,
4760      then we should be able to look it up in the symbols.  */
4761   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4762     return 0;
4763
4764   /* Library-level function names start with "_ada_".  See if function
4765      "_ada_" followed by NAME can be found.  */
4766
4767   /* Do a quick check that NAME does not contain "__", since library-level
4768      functions names cannot contain "__" in them.  */
4769   if (strstr (name, "__") != NULL)
4770     return 0;
4771
4772   std::string fun_name = string_printf ("_ada_%s", name);
4773
4774   return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
4775 }
4776
4777 /* Return nonzero if SYM corresponds to a renaming entity that is
4778    not visible from FUNCTION_NAME.  */
4779
4780 static int
4781 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
4782 {
4783   if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4784     return 0;
4785
4786   std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
4787
4788   /* If the rename has been defined in a package, then it is visible.  */
4789   if (is_package_name (scope.c_str ()))
4790     return 0;
4791
4792   /* Check that the rename is in the current function scope by checking
4793      that its name starts with SCOPE.  */
4794
4795   /* If the function name starts with "_ada_", it means that it is
4796      a library-level function.  Strip this prefix before doing the
4797      comparison, as the encoding for the renaming does not contain
4798      this prefix.  */
4799   if (startswith (function_name, "_ada_"))
4800     function_name += 5;
4801
4802   return !startswith (function_name, scope.c_str ());
4803 }
4804
4805 /* Remove entries from SYMS that corresponds to a renaming entity that
4806    is not visible from the function associated with CURRENT_BLOCK or
4807    that is superfluous due to the presence of more specific renaming
4808    information.  Places surviving symbols in the initial entries of
4809    SYMS.
4810
4811    Rationale:
4812    First, in cases where an object renaming is implemented as a
4813    reference variable, GNAT may produce both the actual reference
4814    variable and the renaming encoding.  In this case, we discard the
4815    latter.
4816
4817    Second, GNAT emits a type following a specified encoding for each renaming
4818    entity.  Unfortunately, STABS currently does not support the definition
4819    of types that are local to a given lexical block, so all renamings types
4820    are emitted at library level.  As a consequence, if an application
4821    contains two renaming entities using the same name, and a user tries to
4822    print the value of one of these entities, the result of the ada symbol
4823    lookup will also contain the wrong renaming type.
4824
4825    This function partially covers for this limitation by attempting to
4826    remove from the SYMS list renaming symbols that should be visible
4827    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
4828    method with the current information available.  The implementation
4829    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
4830    
4831       - When the user tries to print a rename in a function while there
4832         is another rename entity defined in a package:  Normally, the
4833         rename in the function has precedence over the rename in the
4834         package, so the latter should be removed from the list.  This is
4835         currently not the case.
4836         
4837       - This function will incorrectly remove valid renames if
4838         the CURRENT_BLOCK corresponds to a function which symbol name
4839         has been changed by an "Export" pragma.  As a consequence,
4840         the user will be unable to print such rename entities.  */
4841
4842 static void
4843 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
4844                              const struct block *current_block)
4845 {
4846   struct symbol *current_function;
4847   const char *current_function_name;
4848   int i;
4849   int is_new_style_renaming;
4850
4851   /* If there is both a renaming foo___XR... encoded as a variable and
4852      a simple variable foo in the same block, discard the latter.
4853      First, zero out such symbols, then compress.  */
4854   is_new_style_renaming = 0;
4855   for (i = 0; i < syms->size (); i += 1)
4856     {
4857       struct symbol *sym = (*syms)[i].symbol;
4858       const struct block *block = (*syms)[i].block;
4859       const char *name;
4860       const char *suffix;
4861
4862       if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4863         continue;
4864       name = sym->linkage_name ();
4865       suffix = strstr (name, "___XR");
4866
4867       if (suffix != NULL)
4868         {
4869           int name_len = suffix - name;
4870           int j;
4871
4872           is_new_style_renaming = 1;
4873           for (j = 0; j < syms->size (); j += 1)
4874             if (i != j && (*syms)[j].symbol != NULL
4875                 && strncmp (name, (*syms)[j].symbol->linkage_name (),
4876                             name_len) == 0
4877                 && block == (*syms)[j].block)
4878               (*syms)[j].symbol = NULL;
4879         }
4880     }
4881   if (is_new_style_renaming)
4882     {
4883       int j, k;
4884
4885       for (j = k = 0; j < syms->size (); j += 1)
4886         if ((*syms)[j].symbol != NULL)
4887             {
4888               (*syms)[k] = (*syms)[j];
4889               k += 1;
4890             }
4891       syms->resize (k);
4892       return;
4893     }
4894
4895   /* Extract the function name associated to CURRENT_BLOCK.
4896      Abort if unable to do so.  */
4897
4898   if (current_block == NULL)
4899     return;
4900
4901   current_function = block_linkage_function (current_block);
4902   if (current_function == NULL)
4903     return;
4904
4905   current_function_name = current_function->linkage_name ();
4906   if (current_function_name == NULL)
4907     return;
4908
4909   /* Check each of the symbols, and remove it from the list if it is
4910      a type corresponding to a renaming that is out of the scope of
4911      the current block.  */
4912
4913   i = 0;
4914   while (i < syms->size ())
4915     {
4916       if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
4917           == ADA_OBJECT_RENAMING
4918           && old_renaming_is_invisible ((*syms)[i].symbol,
4919                                         current_function_name))
4920         syms->erase (syms->begin () + i);
4921       else
4922         i += 1;
4923     }
4924 }
4925
4926 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
4927    whose name and domain match LOOKUP_NAME and DOMAIN respectively.
4928
4929    Note: This function assumes that RESULT is empty.  */
4930
4931 static void
4932 ada_add_local_symbols (std::vector<struct block_symbol> &result,
4933                        const lookup_name_info &lookup_name,
4934                        const struct block *block, domain_enum domain)
4935 {
4936   while (block != NULL)
4937     {
4938       ada_add_block_symbols (result, block, lookup_name, domain, NULL);
4939
4940       /* If we found a non-function match, assume that's the one.  */
4941       if (is_nonfunction (result))
4942         return;
4943
4944       block = BLOCK_SUPERBLOCK (block);
4945     }
4946 }
4947
4948 /* An object of this type is used as the callback argument when
4949    calling the map_matching_symbols method.  */
4950
4951 struct match_data
4952 {
4953   explicit match_data (std::vector<struct block_symbol> *rp)
4954     : resultp (rp)
4955   {
4956   }
4957   DISABLE_COPY_AND_ASSIGN (match_data);
4958
4959   bool operator() (struct block_symbol *bsym);
4960
4961   struct objfile *objfile = nullptr;
4962   std::vector<struct block_symbol> *resultp;
4963   struct symbol *arg_sym = nullptr;
4964   bool found_sym = false;
4965 };
4966
4967 /* A callback for add_nonlocal_symbols that adds symbol, found in
4968    BSYM, to a list of symbols.  */
4969
4970 bool
4971 match_data::operator() (struct block_symbol *bsym)
4972 {
4973   const struct block *block = bsym->block;
4974   struct symbol *sym = bsym->symbol;
4975
4976   if (sym == NULL)
4977     {
4978       if (!found_sym && arg_sym != NULL)
4979         add_defn_to_vec (*resultp,
4980                          fixup_symbol_section (arg_sym, objfile),
4981                          block);
4982       found_sym = false;
4983       arg_sym = NULL;
4984     }
4985   else 
4986     {
4987       if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
4988         return true;
4989       else if (SYMBOL_IS_ARGUMENT (sym))
4990         arg_sym = sym;
4991       else
4992         {
4993           found_sym = true;
4994           add_defn_to_vec (*resultp,
4995                            fixup_symbol_section (sym, objfile),
4996                            block);
4997         }
4998     }
4999   return true;
5000 }
5001
5002 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5003    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5004    symbols to RESULT.  Return whether we found such symbols.  */
5005
5006 static int
5007 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5008                          const struct block *block,
5009                          const lookup_name_info &lookup_name,
5010                          domain_enum domain)
5011 {
5012   struct using_direct *renaming;
5013   int defns_mark = result.size ();
5014
5015   symbol_name_matcher_ftype *name_match
5016     = ada_get_symbol_name_matcher (lookup_name);
5017
5018   for (renaming = block_using (block);
5019        renaming != NULL;
5020        renaming = renaming->next)
5021     {
5022       const char *r_name;
5023
5024       /* Avoid infinite recursions: skip this renaming if we are actually
5025          already traversing it.
5026
5027          Currently, symbol lookup in Ada don't use the namespace machinery from
5028          C++/Fortran support: skip namespace imports that use them.  */
5029       if (renaming->searched
5030           || (renaming->import_src != NULL
5031               && renaming->import_src[0] != '\0')
5032           || (renaming->import_dest != NULL
5033               && renaming->import_dest[0] != '\0'))
5034         continue;
5035       renaming->searched = 1;
5036
5037       /* TODO: here, we perform another name-based symbol lookup, which can
5038          pull its own multiple overloads.  In theory, we should be able to do
5039          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5040          not a simple name.  But in order to do this, we would need to enhance
5041          the DWARF reader to associate a symbol to this renaming, instead of a
5042          name.  So, for now, we do something simpler: re-use the C++/Fortran
5043          namespace machinery.  */
5044       r_name = (renaming->alias != NULL
5045                 ? renaming->alias
5046                 : renaming->declaration);
5047       if (name_match (r_name, lookup_name, NULL))
5048         {
5049           lookup_name_info decl_lookup_name (renaming->declaration,
5050                                              lookup_name.match_type ());
5051           ada_add_all_symbols (result, block, decl_lookup_name, domain,
5052                                1, NULL);
5053         }
5054       renaming->searched = 0;
5055     }
5056   return result.size () != defns_mark;
5057 }
5058
5059 /* Implements compare_names, but only applying the comparision using
5060    the given CASING.  */
5061
5062 static int
5063 compare_names_with_case (const char *string1, const char *string2,
5064                          enum case_sensitivity casing)
5065 {
5066   while (*string1 != '\0' && *string2 != '\0')
5067     {
5068       char c1, c2;
5069
5070       if (isspace (*string1) || isspace (*string2))
5071         return strcmp_iw_ordered (string1, string2);
5072
5073       if (casing == case_sensitive_off)
5074         {
5075           c1 = tolower (*string1);
5076           c2 = tolower (*string2);
5077         }
5078       else
5079         {
5080           c1 = *string1;
5081           c2 = *string2;
5082         }
5083       if (c1 != c2)
5084         break;
5085
5086       string1 += 1;
5087       string2 += 1;
5088     }
5089
5090   switch (*string1)
5091     {
5092     case '(':
5093       return strcmp_iw_ordered (string1, string2);
5094     case '_':
5095       if (*string2 == '\0')
5096         {
5097           if (is_name_suffix (string1))
5098             return 0;
5099           else
5100             return 1;
5101         }
5102       /* FALLTHROUGH */
5103     default:
5104       if (*string2 == '(')
5105         return strcmp_iw_ordered (string1, string2);
5106       else
5107         {
5108           if (casing == case_sensitive_off)
5109             return tolower (*string1) - tolower (*string2);
5110           else
5111             return *string1 - *string2;
5112         }
5113     }
5114 }
5115
5116 /* Compare STRING1 to STRING2, with results as for strcmp.
5117    Compatible with strcmp_iw_ordered in that...
5118
5119        strcmp_iw_ordered (STRING1, STRING2) <= 0
5120
5121    ... implies...
5122
5123        compare_names (STRING1, STRING2) <= 0
5124
5125    (they may differ as to what symbols compare equal).  */
5126
5127 static int
5128 compare_names (const char *string1, const char *string2)
5129 {
5130   int result;
5131
5132   /* Similar to what strcmp_iw_ordered does, we need to perform
5133      a case-insensitive comparison first, and only resort to
5134      a second, case-sensitive, comparison if the first one was
5135      not sufficient to differentiate the two strings.  */
5136
5137   result = compare_names_with_case (string1, string2, case_sensitive_off);
5138   if (result == 0)
5139     result = compare_names_with_case (string1, string2, case_sensitive_on);
5140
5141   return result;
5142 }
5143
5144 /* Convenience function to get at the Ada encoded lookup name for
5145    LOOKUP_NAME, as a C string.  */
5146
5147 static const char *
5148 ada_lookup_name (const lookup_name_info &lookup_name)
5149 {
5150   return lookup_name.ada ().lookup_name ().c_str ();
5151 }
5152
5153 /* A helper for add_nonlocal_symbols.  Call expand_matching_symbols
5154    for OBJFILE, then walk the objfile's symtabs and update the
5155    results.  */
5156
5157 static void
5158 map_matching_symbols (struct objfile *objfile,
5159                       const lookup_name_info &lookup_name,
5160                       bool is_wild_match,
5161                       domain_enum domain,
5162                       int global,
5163                       match_data &data)
5164 {
5165   data.objfile = objfile;
5166   objfile->expand_matching_symbols (lookup_name, domain, global,
5167                                     is_wild_match ? nullptr : compare_names);
5168
5169   const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5170   for (compunit_symtab *symtab : objfile->compunits ())
5171     {
5172       const struct block *block
5173         = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (symtab), block_kind);
5174       if (!iterate_over_symbols_terminated (block, lookup_name,
5175                                             domain, data))
5176         break;
5177     }
5178 }
5179
5180 /* Add to RESULT all non-local symbols whose name and domain match
5181    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5182    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5183    symbols otherwise.  */
5184
5185 static void
5186 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5187                       const lookup_name_info &lookup_name,
5188                       domain_enum domain, int global)
5189 {
5190   struct match_data data (&result);
5191
5192   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5193
5194   for (objfile *objfile : current_program_space->objfiles ())
5195     {
5196       map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5197                             global, data);
5198
5199       for (compunit_symtab *cu : objfile->compunits ())
5200         {
5201           const struct block *global_block
5202             = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5203
5204           if (ada_add_block_renamings (result, global_block, lookup_name,
5205                                        domain))
5206             data.found_sym = true;
5207         }
5208     }
5209
5210   if (result.empty () && global && !is_wild_match)
5211     {
5212       const char *name = ada_lookup_name (lookup_name);
5213       std::string bracket_name = std::string ("<_ada_") + name + '>';
5214       lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5215
5216       for (objfile *objfile : current_program_space->objfiles ())
5217         map_matching_symbols (objfile, name1, false, domain, global, data);
5218     }
5219 }
5220
5221 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5222    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5223    returning the number of matches.  Add these to RESULT.
5224
5225    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5226    symbol match within the nest of blocks whose innermost member is BLOCK,
5227    is the one match returned (no other matches in that or
5228    enclosing blocks is returned).  If there are any matches in or
5229    surrounding BLOCK, then these alone are returned.
5230
5231    Names prefixed with "standard__" are handled specially:
5232    "standard__" is first stripped off (by the lookup_name
5233    constructor), and only static and global symbols are searched.
5234
5235    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5236    to lookup global symbols.  */
5237
5238 static void
5239 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5240                      const struct block *block,
5241                      const lookup_name_info &lookup_name,
5242                      domain_enum domain,
5243                      int full_search,
5244                      int *made_global_lookup_p)
5245 {
5246   struct symbol *sym;
5247
5248   if (made_global_lookup_p)
5249     *made_global_lookup_p = 0;
5250
5251   /* Special case: If the user specifies a symbol name inside package
5252      Standard, do a non-wild matching of the symbol name without
5253      the "standard__" prefix.  This was primarily introduced in order
5254      to allow the user to specifically access the standard exceptions
5255      using, for instance, Standard.Constraint_Error when Constraint_Error
5256      is ambiguous (due to the user defining its own Constraint_Error
5257      entity inside its program).  */
5258   if (lookup_name.ada ().standard_p ())
5259     block = NULL;
5260
5261   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5262
5263   if (block != NULL)
5264     {
5265       if (full_search)
5266         ada_add_local_symbols (result, lookup_name, block, domain);
5267       else
5268         {
5269           /* In the !full_search case we're are being called by
5270              iterate_over_symbols, and we don't want to search
5271              superblocks.  */
5272           ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5273         }
5274       if (!result.empty () || !full_search)
5275         return;
5276     }
5277
5278   /* No non-global symbols found.  Check our cache to see if we have
5279      already performed this search before.  If we have, then return
5280      the same result.  */
5281
5282   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5283                             domain, &sym, &block))
5284     {
5285       if (sym != NULL)
5286         add_defn_to_vec (result, sym, block);
5287       return;
5288     }
5289
5290   if (made_global_lookup_p)
5291     *made_global_lookup_p = 1;
5292
5293   /* Search symbols from all global blocks.  */
5294  
5295   add_nonlocal_symbols (result, lookup_name, domain, 1);
5296
5297   /* Now add symbols from all per-file blocks if we've gotten no hits
5298      (not strictly correct, but perhaps better than an error).  */
5299
5300   if (result.empty ())
5301     add_nonlocal_symbols (result, lookup_name, domain, 0);
5302 }
5303
5304 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5305    is non-zero, enclosing scope and in global scopes.
5306
5307    Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5308    blocks and symbol tables (if any) in which they were found.
5309
5310    When full_search is non-zero, any non-function/non-enumeral
5311    symbol match within the nest of blocks whose innermost member is BLOCK,
5312    is the one match returned (no other matches in that or
5313    enclosing blocks is returned).  If there are any matches in or
5314    surrounding BLOCK, then these alone are returned.
5315
5316    Names prefixed with "standard__" are handled specially: "standard__"
5317    is first stripped off, and only static and global symbols are searched.  */
5318
5319 static std::vector<struct block_symbol>
5320 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5321                                const struct block *block,
5322                                domain_enum domain,
5323                                int full_search)
5324 {
5325   int syms_from_global_search;
5326   std::vector<struct block_symbol> results;
5327
5328   ada_add_all_symbols (results, block, lookup_name,
5329                        domain, full_search, &syms_from_global_search);
5330
5331   remove_extra_symbols (&results);
5332
5333   if (results.empty () && full_search && syms_from_global_search)
5334     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5335
5336   if (results.size () == 1 && full_search && syms_from_global_search)
5337     cache_symbol (ada_lookup_name (lookup_name), domain,
5338                   results[0].symbol, results[0].block);
5339
5340   remove_irrelevant_renamings (&results, block);
5341   return results;
5342 }
5343
5344 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5345    in global scopes, returning (SYM,BLOCK) tuples.
5346
5347    See ada_lookup_symbol_list_worker for further details.  */
5348
5349 std::vector<struct block_symbol>
5350 ada_lookup_symbol_list (const char *name, const struct block *block,
5351                         domain_enum domain)
5352 {
5353   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5354   lookup_name_info lookup_name (name, name_match_type);
5355
5356   return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5357 }
5358
5359 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5360    to 1, but choosing the first symbol found if there are multiple
5361    choices.
5362
5363    The result is stored in *INFO, which must be non-NULL.
5364    If no match is found, INFO->SYM is set to NULL.  */
5365
5366 void
5367 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5368                            domain_enum domain,
5369                            struct block_symbol *info)
5370 {
5371   /* Since we already have an encoded name, wrap it in '<>' to force a
5372      verbatim match.  Otherwise, if the name happens to not look like
5373      an encoded name (because it doesn't include a "__"),
5374      ada_lookup_name_info would re-encode/fold it again, and that
5375      would e.g., incorrectly lowercase object renaming names like
5376      "R28b" -> "r28b".  */
5377   std::string verbatim = add_angle_brackets (name);
5378
5379   gdb_assert (info != NULL);
5380   *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5381 }
5382
5383 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5384    scope and in global scopes, or NULL if none.  NAME is folded and
5385    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5386    choosing the first symbol if there are multiple choices.  */
5387
5388 struct block_symbol
5389 ada_lookup_symbol (const char *name, const struct block *block0,
5390                    domain_enum domain)
5391 {
5392   std::vector<struct block_symbol> candidates
5393     = ada_lookup_symbol_list (name, block0, domain);
5394
5395   if (candidates.empty ())
5396     return {};
5397
5398   block_symbol info = candidates[0];
5399   info.symbol = fixup_symbol_section (info.symbol, NULL);
5400   return info;
5401 }
5402
5403
5404 /* True iff STR is a possible encoded suffix of a normal Ada name
5405    that is to be ignored for matching purposes.  Suffixes of parallel
5406    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5407    are given by any of the regular expressions:
5408
5409    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5410    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5411    TKB              [subprogram suffix for task bodies]
5412    _E[0-9]+[bs]$    [protected object entry suffixes]
5413    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5414
5415    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5416    match is performed.  This sequence is used to differentiate homonyms,
5417    is an optional part of a valid name suffix.  */
5418
5419 static int
5420 is_name_suffix (const char *str)
5421 {
5422   int k;
5423   const char *matching;
5424   const int len = strlen (str);
5425
5426   /* Skip optional leading __[0-9]+.  */
5427
5428   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5429     {
5430       str += 3;
5431       while (isdigit (str[0]))
5432         str += 1;
5433     }
5434   
5435   /* [.$][0-9]+ */
5436
5437   if (str[0] == '.' || str[0] == '$')
5438     {
5439       matching = str + 1;
5440       while (isdigit (matching[0]))
5441         matching += 1;
5442       if (matching[0] == '\0')
5443         return 1;
5444     }
5445
5446   /* ___[0-9]+ */
5447
5448   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5449     {
5450       matching = str + 3;
5451       while (isdigit (matching[0]))
5452         matching += 1;
5453       if (matching[0] == '\0')
5454         return 1;
5455     }
5456
5457   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
5458
5459   if (strcmp (str, "TKB") == 0)
5460     return 1;
5461
5462 #if 0
5463   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5464      with a N at the end.  Unfortunately, the compiler uses the same
5465      convention for other internal types it creates.  So treating
5466      all entity names that end with an "N" as a name suffix causes
5467      some regressions.  For instance, consider the case of an enumerated
5468      type.  To support the 'Image attribute, it creates an array whose
5469      name ends with N.
5470      Having a single character like this as a suffix carrying some
5471      information is a bit risky.  Perhaps we should change the encoding
5472      to be something like "_N" instead.  In the meantime, do not do
5473      the following check.  */
5474   /* Protected Object Subprograms */
5475   if (len == 1 && str [0] == 'N')
5476     return 1;
5477 #endif
5478
5479   /* _E[0-9]+[bs]$ */
5480   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5481     {
5482       matching = str + 3;
5483       while (isdigit (matching[0]))
5484         matching += 1;
5485       if ((matching[0] == 'b' || matching[0] == 's')
5486           && matching [1] == '\0')
5487         return 1;
5488     }
5489
5490   /* ??? We should not modify STR directly, as we are doing below.  This
5491      is fine in this case, but may become problematic later if we find
5492      that this alternative did not work, and want to try matching
5493      another one from the begining of STR.  Since we modified it, we
5494      won't be able to find the begining of the string anymore!  */
5495   if (str[0] == 'X')
5496     {
5497       str += 1;
5498       while (str[0] != '_' && str[0] != '\0')
5499         {
5500           if (str[0] != 'n' && str[0] != 'b')
5501             return 0;
5502           str += 1;
5503         }
5504     }
5505
5506   if (str[0] == '\000')
5507     return 1;
5508
5509   if (str[0] == '_')
5510     {
5511       if (str[1] != '_' || str[2] == '\000')
5512         return 0;
5513       if (str[2] == '_')
5514         {
5515           if (strcmp (str + 3, "JM") == 0)
5516             return 1;
5517           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5518              the LJM suffix in favor of the JM one.  But we will
5519              still accept LJM as a valid suffix for a reasonable
5520              amount of time, just to allow ourselves to debug programs
5521              compiled using an older version of GNAT.  */
5522           if (strcmp (str + 3, "LJM") == 0)
5523             return 1;
5524           if (str[3] != 'X')
5525             return 0;
5526           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5527               || str[4] == 'U' || str[4] == 'P')
5528             return 1;
5529           if (str[4] == 'R' && str[5] != 'T')
5530             return 1;
5531           return 0;
5532         }
5533       if (!isdigit (str[2]))
5534         return 0;
5535       for (k = 3; str[k] != '\0'; k += 1)
5536         if (!isdigit (str[k]) && str[k] != '_')
5537           return 0;
5538       return 1;
5539     }
5540   if (str[0] == '$' && isdigit (str[1]))
5541     {
5542       for (k = 2; str[k] != '\0'; k += 1)
5543         if (!isdigit (str[k]) && str[k] != '_')
5544           return 0;
5545       return 1;
5546     }
5547   return 0;
5548 }
5549
5550 /* Return non-zero if the string starting at NAME and ending before
5551    NAME_END contains no capital letters.  */
5552
5553 static int
5554 is_valid_name_for_wild_match (const char *name0)
5555 {
5556   std::string decoded_name = ada_decode (name0);
5557   int i;
5558
5559   /* If the decoded name starts with an angle bracket, it means that
5560      NAME0 does not follow the GNAT encoding format.  It should then
5561      not be allowed as a possible wild match.  */
5562   if (decoded_name[0] == '<')
5563     return 0;
5564
5565   for (i=0; decoded_name[i] != '\0'; i++)
5566     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5567       return 0;
5568
5569   return 1;
5570 }
5571
5572 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5573    character which could start a simple name.  Assumes that *NAMEP points
5574    somewhere inside the string beginning at NAME0.  */
5575
5576 static int
5577 advance_wild_match (const char **namep, const char *name0, char target0)
5578 {
5579   const char *name = *namep;
5580
5581   while (1)
5582     {
5583       char t0, t1;
5584
5585       t0 = *name;
5586       if (t0 == '_')
5587         {
5588           t1 = name[1];
5589           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5590             {
5591               name += 1;
5592               if (name == name0 + 5 && startswith (name0, "_ada"))
5593                 break;
5594               else
5595                 name += 1;
5596             }
5597           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5598                                  || name[2] == target0))
5599             {
5600               name += 2;
5601               break;
5602             }
5603           else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
5604             {
5605               /* Names like "pkg__B_N__name", where N is a number, are
5606                  block-local.  We can handle these by simply skipping
5607                  the "B_" here.  */
5608               name += 4;
5609             }
5610           else
5611             return 0;
5612         }
5613       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5614         name += 1;
5615       else
5616         return 0;
5617     }
5618
5619   *namep = name;
5620   return 1;
5621 }
5622
5623 /* Return true iff NAME encodes a name of the form prefix.PATN.
5624    Ignores any informational suffixes of NAME (i.e., for which
5625    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
5626    simple name.  */
5627
5628 static bool
5629 wild_match (const char *name, const char *patn)
5630 {
5631   const char *p;
5632   const char *name0 = name;
5633
5634   while (1)
5635     {
5636       const char *match = name;
5637
5638       if (*name == *patn)
5639         {
5640           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5641             if (*p != *name)
5642               break;
5643           if (*p == '\0' && is_name_suffix (name))
5644             return match == name0 || is_valid_name_for_wild_match (name0);
5645
5646           if (name[-1] == '_')
5647             name -= 1;
5648         }
5649       if (!advance_wild_match (&name, name0, *patn))
5650         return false;
5651     }
5652 }
5653
5654 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
5655    necessary).  OBJFILE is the section containing BLOCK.  */
5656
5657 static void
5658 ada_add_block_symbols (std::vector<struct block_symbol> &result,
5659                        const struct block *block,
5660                        const lookup_name_info &lookup_name,
5661                        domain_enum domain, struct objfile *objfile)
5662 {
5663   struct block_iterator iter;
5664   /* A matching argument symbol, if any.  */
5665   struct symbol *arg_sym;
5666   /* Set true when we find a matching non-argument symbol.  */
5667   bool found_sym;
5668   struct symbol *sym;
5669
5670   arg_sym = NULL;
5671   found_sym = false;
5672   for (sym = block_iter_match_first (block, lookup_name, &iter);
5673        sym != NULL;
5674        sym = block_iter_match_next (lookup_name, &iter))
5675     {
5676       if (symbol_matches_domain (sym->language (), SYMBOL_DOMAIN (sym), domain))
5677         {
5678           if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5679             {
5680               if (SYMBOL_IS_ARGUMENT (sym))
5681                 arg_sym = sym;
5682               else
5683                 {
5684                   found_sym = true;
5685                   add_defn_to_vec (result,
5686                                    fixup_symbol_section (sym, objfile),
5687                                    block);
5688                 }
5689             }
5690         }
5691     }
5692
5693   /* Handle renamings.  */
5694
5695   if (ada_add_block_renamings (result, block, lookup_name, domain))
5696     found_sym = true;
5697
5698   if (!found_sym && arg_sym != NULL)
5699     {
5700       add_defn_to_vec (result,
5701                        fixup_symbol_section (arg_sym, objfile),
5702                        block);
5703     }
5704
5705   if (!lookup_name.ada ().wild_match_p ())
5706     {
5707       arg_sym = NULL;
5708       found_sym = false;
5709       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
5710       const char *name = ada_lookup_name.c_str ();
5711       size_t name_len = ada_lookup_name.size ();
5712
5713       ALL_BLOCK_SYMBOLS (block, iter, sym)
5714       {
5715         if (symbol_matches_domain (sym->language (),
5716                                    SYMBOL_DOMAIN (sym), domain))
5717           {
5718             int cmp;
5719
5720             cmp = (int) '_' - (int) sym->linkage_name ()[0];
5721             if (cmp == 0)
5722               {
5723                 cmp = !startswith (sym->linkage_name (), "_ada_");
5724                 if (cmp == 0)
5725                   cmp = strncmp (name, sym->linkage_name () + 5,
5726                                  name_len);
5727               }
5728
5729             if (cmp == 0
5730                 && is_name_suffix (sym->linkage_name () + name_len + 5))
5731               {
5732                 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5733                   {
5734                     if (SYMBOL_IS_ARGUMENT (sym))
5735                       arg_sym = sym;
5736                     else
5737                       {
5738                         found_sym = true;
5739                         add_defn_to_vec (result,
5740                                          fixup_symbol_section (sym, objfile),
5741                                          block);
5742                       }
5743                   }
5744               }
5745           }
5746       }
5747
5748       /* NOTE: This really shouldn't be needed for _ada_ symbols.
5749          They aren't parameters, right?  */
5750       if (!found_sym && arg_sym != NULL)
5751         {
5752           add_defn_to_vec (result,
5753                            fixup_symbol_section (arg_sym, objfile),
5754                            block);
5755         }
5756     }
5757 }
5758 \f
5759
5760                                 /* Symbol Completion */
5761
5762 /* See symtab.h.  */
5763
5764 bool
5765 ada_lookup_name_info::matches
5766   (const char *sym_name,
5767    symbol_name_match_type match_type,
5768    completion_match_result *comp_match_res) const
5769 {
5770   bool match = false;
5771   const char *text = m_encoded_name.c_str ();
5772   size_t text_len = m_encoded_name.size ();
5773
5774   /* First, test against the fully qualified name of the symbol.  */
5775
5776   if (strncmp (sym_name, text, text_len) == 0)
5777     match = true;
5778
5779   std::string decoded_name = ada_decode (sym_name);
5780   if (match && !m_encoded_p)
5781     {
5782       /* One needed check before declaring a positive match is to verify
5783          that iff we are doing a verbatim match, the decoded version
5784          of the symbol name starts with '<'.  Otherwise, this symbol name
5785          is not a suitable completion.  */
5786
5787       bool has_angle_bracket = (decoded_name[0] == '<');
5788       match = (has_angle_bracket == m_verbatim_p);
5789     }
5790
5791   if (match && !m_verbatim_p)
5792     {
5793       /* When doing non-verbatim match, another check that needs to
5794          be done is to verify that the potentially matching symbol name
5795          does not include capital letters, because the ada-mode would
5796          not be able to understand these symbol names without the
5797          angle bracket notation.  */
5798       const char *tmp;
5799
5800       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5801       if (*tmp != '\0')
5802         match = false;
5803     }
5804
5805   /* Second: Try wild matching...  */
5806
5807   if (!match && m_wild_match_p)
5808     {
5809       /* Since we are doing wild matching, this means that TEXT
5810          may represent an unqualified symbol name.  We therefore must
5811          also compare TEXT against the unqualified name of the symbol.  */
5812       sym_name = ada_unqualified_name (decoded_name.c_str ());
5813
5814       if (strncmp (sym_name, text, text_len) == 0)
5815         match = true;
5816     }
5817
5818   /* Finally: If we found a match, prepare the result to return.  */
5819
5820   if (!match)
5821     return false;
5822
5823   if (comp_match_res != NULL)
5824     {
5825       std::string &match_str = comp_match_res->match.storage ();
5826
5827       if (!m_encoded_p)
5828         match_str = ada_decode (sym_name);
5829       else
5830         {
5831           if (m_verbatim_p)
5832             match_str = add_angle_brackets (sym_name);
5833           else
5834             match_str = sym_name;
5835
5836         }
5837
5838       comp_match_res->set_match (match_str.c_str ());
5839     }
5840
5841   return true;
5842 }
5843
5844                                 /* Field Access */
5845
5846 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5847    for tagged types.  */
5848
5849 static int
5850 ada_is_dispatch_table_ptr_type (struct type *type)
5851 {
5852   const char *name;
5853
5854   if (type->code () != TYPE_CODE_PTR)
5855     return 0;
5856
5857   name = TYPE_TARGET_TYPE (type)->name ();
5858   if (name == NULL)
5859     return 0;
5860
5861   return (strcmp (name, "ada__tags__dispatch_table") == 0);
5862 }
5863
5864 /* Return non-zero if TYPE is an interface tag.  */
5865
5866 static int
5867 ada_is_interface_tag (struct type *type)
5868 {
5869   const char *name = type->name ();
5870
5871   if (name == NULL)
5872     return 0;
5873
5874   return (strcmp (name, "ada__tags__interface_tag") == 0);
5875 }
5876
5877 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5878    to be invisible to users.  */
5879
5880 int
5881 ada_is_ignored_field (struct type *type, int field_num)
5882 {
5883   if (field_num < 0 || field_num > type->num_fields ())
5884     return 1;
5885
5886   /* Check the name of that field.  */
5887   {
5888     const char *name = TYPE_FIELD_NAME (type, field_num);
5889
5890     /* Anonymous field names should not be printed.
5891        brobecker/2007-02-20: I don't think this can actually happen
5892        but we don't want to print the value of anonymous fields anyway.  */
5893     if (name == NULL)
5894       return 1;
5895
5896     /* Normally, fields whose name start with an underscore ("_")
5897        are fields that have been internally generated by the compiler,
5898        and thus should not be printed.  The "_parent" field is special,
5899        however: This is a field internally generated by the compiler
5900        for tagged types, and it contains the components inherited from
5901        the parent type.  This field should not be printed as is, but
5902        should not be ignored either.  */
5903     if (name[0] == '_' && !startswith (name, "_parent"))
5904       return 1;
5905   }
5906
5907   /* If this is the dispatch table of a tagged type or an interface tag,
5908      then ignore.  */
5909   if (ada_is_tagged_type (type, 1)
5910       && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
5911           || ada_is_interface_tag (type->field (field_num).type ())))
5912     return 1;
5913
5914   /* Not a special field, so it should not be ignored.  */
5915   return 0;
5916 }
5917
5918 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
5919    pointer or reference type whose ultimate target has a tag field.  */
5920
5921 int
5922 ada_is_tagged_type (struct type *type, int refok)
5923 {
5924   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
5925 }
5926
5927 /* True iff TYPE represents the type of X'Tag */
5928
5929 int
5930 ada_is_tag_type (struct type *type)
5931 {
5932   type = ada_check_typedef (type);
5933
5934   if (type == NULL || type->code () != TYPE_CODE_PTR)
5935     return 0;
5936   else
5937     {
5938       const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5939
5940       return (name != NULL
5941               && strcmp (name, "ada__tags__dispatch_table") == 0);
5942     }
5943 }
5944
5945 /* The type of the tag on VAL.  */
5946
5947 static struct type *
5948 ada_tag_type (struct value *val)
5949 {
5950   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
5951 }
5952
5953 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
5954    retired at Ada 05).  */
5955
5956 static int
5957 is_ada95_tag (struct value *tag)
5958 {
5959   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
5960 }
5961
5962 /* The value of the tag on VAL.  */
5963
5964 static struct value *
5965 ada_value_tag (struct value *val)
5966 {
5967   return ada_value_struct_elt (val, "_tag", 0);
5968 }
5969
5970 /* The value of the tag on the object of type TYPE whose contents are
5971    saved at VALADDR, if it is non-null, or is at memory address
5972    ADDRESS.  */
5973
5974 static struct value *
5975 value_tag_from_contents_and_address (struct type *type,
5976                                      const gdb_byte *valaddr,
5977                                      CORE_ADDR address)
5978 {
5979   int tag_byte_offset;
5980   struct type *tag_type;
5981
5982   if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
5983                          NULL, NULL, NULL))
5984     {
5985       const gdb_byte *valaddr1 = ((valaddr == NULL)
5986                                   ? NULL
5987                                   : valaddr + tag_byte_offset);
5988       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
5989
5990       return value_from_contents_and_address (tag_type, valaddr1, address1);
5991     }
5992   return NULL;
5993 }
5994
5995 static struct type *
5996 type_from_tag (struct value *tag)
5997 {
5998   gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
5999
6000   if (type_name != NULL)
6001     return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6002   return NULL;
6003 }
6004
6005 /* Given a value OBJ of a tagged type, return a value of this
6006    type at the base address of the object.  The base address, as
6007    defined in Ada.Tags, it is the address of the primary tag of
6008    the object, and therefore where the field values of its full
6009    view can be fetched.  */
6010
6011 struct value *
6012 ada_tag_value_at_base_address (struct value *obj)
6013 {
6014   struct value *val;
6015   LONGEST offset_to_top = 0;
6016   struct type *ptr_type, *obj_type;
6017   struct value *tag;
6018   CORE_ADDR base_address;
6019
6020   obj_type = value_type (obj);
6021
6022   /* It is the responsability of the caller to deref pointers.  */
6023
6024   if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6025     return obj;
6026
6027   tag = ada_value_tag (obj);
6028   if (!tag)
6029     return obj;
6030
6031   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6032
6033   if (is_ada95_tag (tag))
6034     return obj;
6035
6036   ptr_type = language_lookup_primitive_type
6037     (language_def (language_ada), target_gdbarch(), "storage_offset");
6038   ptr_type = lookup_pointer_type (ptr_type);
6039   val = value_cast (ptr_type, tag);
6040   if (!val)
6041     return obj;
6042
6043   /* It is perfectly possible that an exception be raised while
6044      trying to determine the base address, just like for the tag;
6045      see ada_tag_name for more details.  We do not print the error
6046      message for the same reason.  */
6047
6048   try
6049     {
6050       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6051     }
6052
6053   catch (const gdb_exception_error &e)
6054     {
6055       return obj;
6056     }
6057
6058   /* If offset is null, nothing to do.  */
6059
6060   if (offset_to_top == 0)
6061     return obj;
6062
6063   /* -1 is a special case in Ada.Tags; however, what should be done
6064      is not quite clear from the documentation.  So do nothing for
6065      now.  */
6066
6067   if (offset_to_top == -1)
6068     return obj;
6069
6070   /* OFFSET_TO_TOP used to be a positive value to be subtracted
6071      from the base address.  This was however incompatible with
6072      C++ dispatch table: C++ uses a *negative* value to *add*
6073      to the base address.  Ada's convention has therefore been
6074      changed in GNAT 19.0w 20171023: since then, C++ and Ada
6075      use the same convention.  Here, we support both cases by
6076      checking the sign of OFFSET_TO_TOP.  */
6077
6078   if (offset_to_top > 0)
6079     offset_to_top = -offset_to_top;
6080
6081   base_address = value_address (obj) + offset_to_top;
6082   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6083
6084   /* Make sure that we have a proper tag at the new address.
6085      Otherwise, offset_to_top is bogus (which can happen when
6086      the object is not initialized yet).  */
6087
6088   if (!tag)
6089     return obj;
6090
6091   obj_type = type_from_tag (tag);
6092
6093   if (!obj_type)
6094     return obj;
6095
6096   return value_from_contents_and_address (obj_type, NULL, base_address);
6097 }
6098
6099 /* Return the "ada__tags__type_specific_data" type.  */
6100
6101 static struct type *
6102 ada_get_tsd_type (struct inferior *inf)
6103 {
6104   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6105
6106   if (data->tsd_type == 0)
6107     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6108   return data->tsd_type;
6109 }
6110
6111 /* Return the TSD (type-specific data) associated to the given TAG.
6112    TAG is assumed to be the tag of a tagged-type entity.
6113
6114    May return NULL if we are unable to get the TSD.  */
6115
6116 static struct value *
6117 ada_get_tsd_from_tag (struct value *tag)
6118 {
6119   struct value *val;
6120   struct type *type;
6121
6122   /* First option: The TSD is simply stored as a field of our TAG.
6123      Only older versions of GNAT would use this format, but we have
6124      to test it first, because there are no visible markers for
6125      the current approach except the absence of that field.  */
6126
6127   val = ada_value_struct_elt (tag, "tsd", 1);
6128   if (val)
6129     return val;
6130
6131   /* Try the second representation for the dispatch table (in which
6132      there is no explicit 'tsd' field in the referent of the tag pointer,
6133      and instead the tsd pointer is stored just before the dispatch
6134      table.  */
6135
6136   type = ada_get_tsd_type (current_inferior());
6137   if (type == NULL)
6138     return NULL;
6139   type = lookup_pointer_type (lookup_pointer_type (type));
6140   val = value_cast (type, tag);
6141   if (val == NULL)
6142     return NULL;
6143   return value_ind (value_ptradd (val, -1));
6144 }
6145
6146 /* Given the TSD of a tag (type-specific data), return a string
6147    containing the name of the associated type.
6148
6149    May return NULL if we are unable to determine the tag name.  */
6150
6151 static gdb::unique_xmalloc_ptr<char>
6152 ada_tag_name_from_tsd (struct value *tsd)
6153 {
6154   char *p;
6155   struct value *val;
6156
6157   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6158   if (val == NULL)
6159     return NULL;
6160   gdb::unique_xmalloc_ptr<char> buffer
6161     = target_read_string (value_as_address (val), INT_MAX);
6162   if (buffer == nullptr)
6163     return nullptr;
6164
6165   for (p = buffer.get (); *p != '\0'; ++p)
6166     {
6167       if (isalpha (*p))
6168         *p = tolower (*p);
6169     }
6170
6171   return buffer;
6172 }
6173
6174 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6175    a C string.
6176
6177    Return NULL if the TAG is not an Ada tag, or if we were unable to
6178    determine the name of that tag.  */
6179
6180 gdb::unique_xmalloc_ptr<char>
6181 ada_tag_name (struct value *tag)
6182 {
6183   gdb::unique_xmalloc_ptr<char> name;
6184
6185   if (!ada_is_tag_type (value_type (tag)))
6186     return NULL;
6187
6188   /* It is perfectly possible that an exception be raised while trying
6189      to determine the TAG's name, even under normal circumstances:
6190      The associated variable may be uninitialized or corrupted, for
6191      instance. We do not let any exception propagate past this point.
6192      instead we return NULL.
6193
6194      We also do not print the error message either (which often is very
6195      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6196      the caller print a more meaningful message if necessary.  */
6197   try
6198     {
6199       struct value *tsd = ada_get_tsd_from_tag (tag);
6200
6201       if (tsd != NULL)
6202         name = ada_tag_name_from_tsd (tsd);
6203     }
6204   catch (const gdb_exception_error &e)
6205     {
6206     }
6207
6208   return name;
6209 }
6210
6211 /* The parent type of TYPE, or NULL if none.  */
6212
6213 struct type *
6214 ada_parent_type (struct type *type)
6215 {
6216   int i;
6217
6218   type = ada_check_typedef (type);
6219
6220   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6221     return NULL;
6222
6223   for (i = 0; i < type->num_fields (); i += 1)
6224     if (ada_is_parent_field (type, i))
6225       {
6226         struct type *parent_type = type->field (i).type ();
6227
6228         /* If the _parent field is a pointer, then dereference it.  */
6229         if (parent_type->code () == TYPE_CODE_PTR)
6230           parent_type = TYPE_TARGET_TYPE (parent_type);
6231         /* If there is a parallel XVS type, get the actual base type.  */
6232         parent_type = ada_get_base_type (parent_type);
6233
6234         return ada_check_typedef (parent_type);
6235       }
6236
6237   return NULL;
6238 }
6239
6240 /* True iff field number FIELD_NUM of structure type TYPE contains the
6241    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6242    a structure type with at least FIELD_NUM+1 fields.  */
6243
6244 int
6245 ada_is_parent_field (struct type *type, int field_num)
6246 {
6247   const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
6248
6249   return (name != NULL
6250           && (startswith (name, "PARENT")
6251               || startswith (name, "_parent")));
6252 }
6253
6254 /* True iff field number FIELD_NUM of structure type TYPE is a
6255    transparent wrapper field (which should be silently traversed when doing
6256    field selection and flattened when printing).  Assumes TYPE is a
6257    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6258    structures.  */
6259
6260 int
6261 ada_is_wrapper_field (struct type *type, int field_num)
6262 {
6263   const char *name = TYPE_FIELD_NAME (type, field_num);
6264
6265   if (name != NULL && strcmp (name, "RETVAL") == 0)
6266     {
6267       /* This happens in functions with "out" or "in out" parameters
6268          which are passed by copy.  For such functions, GNAT describes
6269          the function's return type as being a struct where the return
6270          value is in a field called RETVAL, and where the other "out"
6271          or "in out" parameters are fields of that struct.  This is not
6272          a wrapper.  */
6273       return 0;
6274     }
6275
6276   return (name != NULL
6277           && (startswith (name, "PARENT")
6278               || strcmp (name, "REP") == 0
6279               || startswith (name, "_parent")
6280               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6281 }
6282
6283 /* True iff field number FIELD_NUM of structure or union type TYPE
6284    is a variant wrapper.  Assumes TYPE is a structure type with at least
6285    FIELD_NUM+1 fields.  */
6286
6287 int
6288 ada_is_variant_part (struct type *type, int field_num)
6289 {
6290   /* Only Ada types are eligible.  */
6291   if (!ADA_TYPE_P (type))
6292     return 0;
6293
6294   struct type *field_type = type->field (field_num).type ();
6295
6296   return (field_type->code () == TYPE_CODE_UNION
6297           || (is_dynamic_field (type, field_num)
6298               && (TYPE_TARGET_TYPE (field_type)->code ()
6299                   == TYPE_CODE_UNION)));
6300 }
6301
6302 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6303    whose discriminants are contained in the record type OUTER_TYPE,
6304    returns the type of the controlling discriminant for the variant.
6305    May return NULL if the type could not be found.  */
6306
6307 struct type *
6308 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6309 {
6310   const char *name = ada_variant_discrim_name (var_type);
6311
6312   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6313 }
6314
6315 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6316    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6317    represents a 'when others' clause; otherwise 0.  */
6318
6319 static int
6320 ada_is_others_clause (struct type *type, int field_num)
6321 {
6322   const char *name = TYPE_FIELD_NAME (type, field_num);
6323
6324   return (name != NULL && name[0] == 'O');
6325 }
6326
6327 /* Assuming that TYPE0 is the type of the variant part of a record,
6328    returns the name of the discriminant controlling the variant.
6329    The value is valid until the next call to ada_variant_discrim_name.  */
6330
6331 const char *
6332 ada_variant_discrim_name (struct type *type0)
6333 {
6334   static std::string result;
6335   struct type *type;
6336   const char *name;
6337   const char *discrim_end;
6338   const char *discrim_start;
6339
6340   if (type0->code () == TYPE_CODE_PTR)
6341     type = TYPE_TARGET_TYPE (type0);
6342   else
6343     type = type0;
6344
6345   name = ada_type_name (type);
6346
6347   if (name == NULL || name[0] == '\000')
6348     return "";
6349
6350   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6351        discrim_end -= 1)
6352     {
6353       if (startswith (discrim_end, "___XVN"))
6354         break;
6355     }
6356   if (discrim_end == name)
6357     return "";
6358
6359   for (discrim_start = discrim_end; discrim_start != name + 3;
6360        discrim_start -= 1)
6361     {
6362       if (discrim_start == name + 1)
6363         return "";
6364       if ((discrim_start > name + 3
6365            && startswith (discrim_start - 3, "___"))
6366           || discrim_start[-1] == '.')
6367         break;
6368     }
6369
6370   result = std::string (discrim_start, discrim_end - discrim_start);
6371   return result.c_str ();
6372 }
6373
6374 /* Scan STR for a subtype-encoded number, beginning at position K.
6375    Put the position of the character just past the number scanned in
6376    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
6377    Return 1 if there was a valid number at the given position, and 0
6378    otherwise.  A "subtype-encoded" number consists of the absolute value
6379    in decimal, followed by the letter 'm' to indicate a negative number.
6380    Assumes 0m does not occur.  */
6381
6382 int
6383 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6384 {
6385   ULONGEST RU;
6386
6387   if (!isdigit (str[k]))
6388     return 0;
6389
6390   /* Do it the hard way so as not to make any assumption about
6391      the relationship of unsigned long (%lu scan format code) and
6392      LONGEST.  */
6393   RU = 0;
6394   while (isdigit (str[k]))
6395     {
6396       RU = RU * 10 + (str[k] - '0');
6397       k += 1;
6398     }
6399
6400   if (str[k] == 'm')
6401     {
6402       if (R != NULL)
6403         *R = (-(LONGEST) (RU - 1)) - 1;
6404       k += 1;
6405     }
6406   else if (R != NULL)
6407     *R = (LONGEST) RU;
6408
6409   /* NOTE on the above: Technically, C does not say what the results of
6410      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6411      number representable as a LONGEST (although either would probably work
6412      in most implementations).  When RU>0, the locution in the then branch
6413      above is always equivalent to the negative of RU.  */
6414
6415   if (new_k != NULL)
6416     *new_k = k;
6417   return 1;
6418 }
6419
6420 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6421    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6422    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
6423
6424 static int
6425 ada_in_variant (LONGEST val, struct type *type, int field_num)
6426 {
6427   const char *name = TYPE_FIELD_NAME (type, field_num);
6428   int p;
6429
6430   p = 0;
6431   while (1)
6432     {
6433       switch (name[p])
6434         {
6435         case '\0':
6436           return 0;
6437         case 'S':
6438           {
6439             LONGEST W;
6440
6441             if (!ada_scan_number (name, p + 1, &W, &p))
6442               return 0;
6443             if (val == W)
6444               return 1;
6445             break;
6446           }
6447         case 'R':
6448           {
6449             LONGEST L, U;
6450
6451             if (!ada_scan_number (name, p + 1, &L, &p)
6452                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6453               return 0;
6454             if (val >= L && val <= U)
6455               return 1;
6456             break;
6457           }
6458         case 'O':
6459           return 1;
6460         default:
6461           return 0;
6462         }
6463     }
6464 }
6465
6466 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
6467
6468 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6469    ARG_TYPE, extract and return the value of one of its (non-static)
6470    fields.  FIELDNO says which field.   Differs from value_primitive_field
6471    only in that it can handle packed values of arbitrary type.  */
6472
6473 struct value *
6474 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6475                            struct type *arg_type)
6476 {
6477   struct type *type;
6478
6479   arg_type = ada_check_typedef (arg_type);
6480   type = arg_type->field (fieldno).type ();
6481
6482   /* Handle packed fields.  It might be that the field is not packed
6483      relative to its containing structure, but the structure itself is
6484      packed; in this case we must take the bit-field path.  */
6485   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6486     {
6487       int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6488       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6489
6490       return ada_value_primitive_packed_val (arg1, value_contents (arg1),
6491                                              offset + bit_pos / 8,
6492                                              bit_pos % 8, bit_size, type);
6493     }
6494   else
6495     return value_primitive_field (arg1, offset, fieldno, arg_type);
6496 }
6497
6498 /* Find field with name NAME in object of type TYPE.  If found, 
6499    set the following for each argument that is non-null:
6500     - *FIELD_TYPE_P to the field's type; 
6501     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
6502       an object of that type;
6503     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
6504     - *BIT_SIZE_P to its size in bits if the field is packed, and 
6505       0 otherwise;
6506    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6507    fields up to but not including the desired field, or by the total
6508    number of fields if not found.   A NULL value of NAME never
6509    matches; the function just counts visible fields in this case.
6510    
6511    Notice that we need to handle when a tagged record hierarchy
6512    has some components with the same name, like in this scenario:
6513
6514       type Top_T is tagged record
6515          N : Integer := 1;
6516          U : Integer := 974;
6517          A : Integer := 48;
6518       end record;
6519
6520       type Middle_T is new Top.Top_T with record
6521          N : Character := 'a';
6522          C : Integer := 3;
6523       end record;
6524
6525      type Bottom_T is new Middle.Middle_T with record
6526         N : Float := 4.0;
6527         C : Character := '5';
6528         X : Integer := 6;
6529         A : Character := 'J';
6530      end record;
6531
6532    Let's say we now have a variable declared and initialized as follow:
6533
6534      TC : Top_A := new Bottom_T;
6535
6536    And then we use this variable to call this function
6537
6538      procedure Assign (Obj: in out Top_T; TV : Integer);
6539
6540    as follow:
6541
6542       Assign (Top_T (B), 12);
6543
6544    Now, we're in the debugger, and we're inside that procedure
6545    then and we want to print the value of obj.c:
6546
6547    Usually, the tagged record or one of the parent type owns the
6548    component to print and there's no issue but in this particular
6549    case, what does it mean to ask for Obj.C? Since the actual
6550    type for object is type Bottom_T, it could mean two things: type
6551    component C from the Middle_T view, but also component C from
6552    Bottom_T.  So in that "undefined" case, when the component is
6553    not found in the non-resolved type (which includes all the
6554    components of the parent type), then resolve it and see if we
6555    get better luck once expanded.
6556
6557    In the case of homonyms in the derived tagged type, we don't
6558    guaranty anything, and pick the one that's easiest for us
6559    to program.
6560
6561    Returns 1 if found, 0 otherwise.  */
6562
6563 static int
6564 find_struct_field (const char *name, struct type *type, int offset,
6565                    struct type **field_type_p,
6566                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6567                    int *index_p)
6568 {
6569   int i;
6570   int parent_offset = -1;
6571
6572   type = ada_check_typedef (type);
6573
6574   if (field_type_p != NULL)
6575     *field_type_p = NULL;
6576   if (byte_offset_p != NULL)
6577     *byte_offset_p = 0;
6578   if (bit_offset_p != NULL)
6579     *bit_offset_p = 0;
6580   if (bit_size_p != NULL)
6581     *bit_size_p = 0;
6582
6583   for (i = 0; i < type->num_fields (); i += 1)
6584     {
6585       int bit_pos = TYPE_FIELD_BITPOS (type, i);
6586       int fld_offset = offset + bit_pos / 8;
6587       const char *t_field_name = TYPE_FIELD_NAME (type, i);
6588
6589       if (t_field_name == NULL)
6590         continue;
6591
6592       else if (ada_is_parent_field (type, i))
6593         {
6594           /* This is a field pointing us to the parent type of a tagged
6595              type.  As hinted in this function's documentation, we give
6596              preference to fields in the current record first, so what
6597              we do here is just record the index of this field before
6598              we skip it.  If it turns out we couldn't find our field
6599              in the current record, then we'll get back to it and search
6600              inside it whether the field might exist in the parent.  */
6601
6602           parent_offset = i;
6603           continue;
6604         }
6605
6606       else if (name != NULL && field_name_match (t_field_name, name))
6607         {
6608           int bit_size = TYPE_FIELD_BITSIZE (type, i);
6609
6610           if (field_type_p != NULL)
6611             *field_type_p = type->field (i).type ();
6612           if (byte_offset_p != NULL)
6613             *byte_offset_p = fld_offset;
6614           if (bit_offset_p != NULL)
6615             *bit_offset_p = bit_pos % 8;
6616           if (bit_size_p != NULL)
6617             *bit_size_p = bit_size;
6618           return 1;
6619         }
6620       else if (ada_is_wrapper_field (type, i))
6621         {
6622           if (find_struct_field (name, type->field (i).type (), fld_offset,
6623                                  field_type_p, byte_offset_p, bit_offset_p,
6624                                  bit_size_p, index_p))
6625             return 1;
6626         }
6627       else if (ada_is_variant_part (type, i))
6628         {
6629           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
6630              fixed type?? */
6631           int j;
6632           struct type *field_type
6633             = ada_check_typedef (type->field (i).type ());
6634
6635           for (j = 0; j < field_type->num_fields (); j += 1)
6636             {
6637               if (find_struct_field (name, field_type->field (j).type (),
6638                                      fld_offset
6639                                      + TYPE_FIELD_BITPOS (field_type, j) / 8,
6640                                      field_type_p, byte_offset_p,
6641                                      bit_offset_p, bit_size_p, index_p))
6642                 return 1;
6643             }
6644         }
6645       else if (index_p != NULL)
6646         *index_p += 1;
6647     }
6648
6649   /* Field not found so far.  If this is a tagged type which
6650      has a parent, try finding that field in the parent now.  */
6651
6652   if (parent_offset != -1)
6653     {
6654       int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
6655       int fld_offset = offset + bit_pos / 8;
6656
6657       if (find_struct_field (name, type->field (parent_offset).type (),
6658                              fld_offset, field_type_p, byte_offset_p,
6659                              bit_offset_p, bit_size_p, index_p))
6660         return 1;
6661     }
6662
6663   return 0;
6664 }
6665
6666 /* Number of user-visible fields in record type TYPE.  */
6667
6668 static int
6669 num_visible_fields (struct type *type)
6670 {
6671   int n;
6672
6673   n = 0;
6674   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6675   return n;
6676 }
6677
6678 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
6679    and search in it assuming it has (class) type TYPE.
6680    If found, return value, else return NULL.
6681
6682    Searches recursively through wrapper fields (e.g., '_parent').
6683
6684    In the case of homonyms in the tagged types, please refer to the
6685    long explanation in find_struct_field's function documentation.  */
6686
6687 static struct value *
6688 ada_search_struct_field (const char *name, struct value *arg, int offset,
6689                          struct type *type)
6690 {
6691   int i;
6692   int parent_offset = -1;
6693
6694   type = ada_check_typedef (type);
6695   for (i = 0; i < type->num_fields (); i += 1)
6696     {
6697       const char *t_field_name = TYPE_FIELD_NAME (type, i);
6698
6699       if (t_field_name == NULL)
6700         continue;
6701
6702       else if (ada_is_parent_field (type, i))
6703         {
6704           /* This is a field pointing us to the parent type of a tagged
6705              type.  As hinted in this function's documentation, we give
6706              preference to fields in the current record first, so what
6707              we do here is just record the index of this field before
6708              we skip it.  If it turns out we couldn't find our field
6709              in the current record, then we'll get back to it and search
6710              inside it whether the field might exist in the parent.  */
6711
6712           parent_offset = i;
6713           continue;
6714         }
6715
6716       else if (field_name_match (t_field_name, name))
6717         return ada_value_primitive_field (arg, offset, i, type);
6718
6719       else if (ada_is_wrapper_field (type, i))
6720         {
6721           struct value *v =     /* Do not let indent join lines here.  */
6722             ada_search_struct_field (name, arg,
6723                                      offset + TYPE_FIELD_BITPOS (type, i) / 8,
6724                                      type->field (i).type ());
6725
6726           if (v != NULL)
6727             return v;
6728         }
6729
6730       else if (ada_is_variant_part (type, i))
6731         {
6732           /* PNH: Do we ever get here?  See find_struct_field.  */
6733           int j;
6734           struct type *field_type = ada_check_typedef (type->field (i).type ());
6735           int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6736
6737           for (j = 0; j < field_type->num_fields (); j += 1)
6738             {
6739               struct value *v = ada_search_struct_field /* Force line
6740                                                            break.  */
6741                 (name, arg,
6742                  var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6743                  field_type->field (j).type ());
6744
6745               if (v != NULL)
6746                 return v;
6747             }
6748         }
6749     }
6750
6751   /* Field not found so far.  If this is a tagged type which
6752      has a parent, try finding that field in the parent now.  */
6753
6754   if (parent_offset != -1)
6755     {
6756       struct value *v = ada_search_struct_field (
6757         name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
6758         type->field (parent_offset).type ());
6759
6760       if (v != NULL)
6761         return v;
6762     }
6763
6764   return NULL;
6765 }
6766
6767 static struct value *ada_index_struct_field_1 (int *, struct value *,
6768                                                int, struct type *);
6769
6770
6771 /* Return field #INDEX in ARG, where the index is that returned by
6772  * find_struct_field through its INDEX_P argument.  Adjust the address
6773  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6774  * If found, return value, else return NULL.  */
6775
6776 static struct value *
6777 ada_index_struct_field (int index, struct value *arg, int offset,
6778                         struct type *type)
6779 {
6780   return ada_index_struct_field_1 (&index, arg, offset, type);
6781 }
6782
6783
6784 /* Auxiliary function for ada_index_struct_field.  Like
6785  * ada_index_struct_field, but takes index from *INDEX_P and modifies
6786  * *INDEX_P.  */
6787
6788 static struct value *
6789 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6790                           struct type *type)
6791 {
6792   int i;
6793   type = ada_check_typedef (type);
6794
6795   for (i = 0; i < type->num_fields (); i += 1)
6796     {
6797       if (TYPE_FIELD_NAME (type, i) == NULL)
6798         continue;
6799       else if (ada_is_wrapper_field (type, i))
6800         {
6801           struct value *v =     /* Do not let indent join lines here.  */
6802             ada_index_struct_field_1 (index_p, arg,
6803                                       offset + TYPE_FIELD_BITPOS (type, i) / 8,
6804                                       type->field (i).type ());
6805
6806           if (v != NULL)
6807             return v;
6808         }
6809
6810       else if (ada_is_variant_part (type, i))
6811         {
6812           /* PNH: Do we ever get here?  See ada_search_struct_field,
6813              find_struct_field.  */
6814           error (_("Cannot assign this kind of variant record"));
6815         }
6816       else if (*index_p == 0)
6817         return ada_value_primitive_field (arg, offset, i, type);
6818       else
6819         *index_p -= 1;
6820     }
6821   return NULL;
6822 }
6823
6824 /* Return a string representation of type TYPE.  */
6825
6826 static std::string
6827 type_as_string (struct type *type)
6828 {
6829   string_file tmp_stream;
6830
6831   type_print (type, "", &tmp_stream, -1);
6832
6833   return std::move (tmp_stream.string ());
6834 }
6835
6836 /* Given a type TYPE, look up the type of the component of type named NAME.
6837    If DISPP is non-null, add its byte displacement from the beginning of a
6838    structure (pointed to by a value) of type TYPE to *DISPP (does not
6839    work for packed fields).
6840
6841    Matches any field whose name has NAME as a prefix, possibly
6842    followed by "___".
6843
6844    TYPE can be either a struct or union.  If REFOK, TYPE may also 
6845    be a (pointer or reference)+ to a struct or union, and the
6846    ultimate target type will be searched.
6847
6848    Looks recursively into variant clauses and parent types.
6849
6850    In the case of homonyms in the tagged types, please refer to the
6851    long explanation in find_struct_field's function documentation.
6852
6853    If NOERR is nonzero, return NULL if NAME is not suitably defined or
6854    TYPE is not a type of the right kind.  */
6855
6856 static struct type *
6857 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
6858                             int noerr)
6859 {
6860   int i;
6861   int parent_offset = -1;
6862
6863   if (name == NULL)
6864     goto BadName;
6865
6866   if (refok && type != NULL)
6867     while (1)
6868       {
6869         type = ada_check_typedef (type);
6870         if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
6871           break;
6872         type = TYPE_TARGET_TYPE (type);
6873       }
6874
6875   if (type == NULL
6876       || (type->code () != TYPE_CODE_STRUCT
6877           && type->code () != TYPE_CODE_UNION))
6878     {
6879       if (noerr)
6880         return NULL;
6881
6882       error (_("Type %s is not a structure or union type"),
6883              type != NULL ? type_as_string (type).c_str () : _("(null)"));
6884     }
6885
6886   type = to_static_fixed_type (type);
6887
6888   for (i = 0; i < type->num_fields (); i += 1)
6889     {
6890       const char *t_field_name = TYPE_FIELD_NAME (type, i);
6891       struct type *t;
6892
6893       if (t_field_name == NULL)
6894         continue;
6895
6896       else if (ada_is_parent_field (type, i))
6897         {
6898           /* This is a field pointing us to the parent type of a tagged
6899              type.  As hinted in this function's documentation, we give
6900              preference to fields in the current record first, so what
6901              we do here is just record the index of this field before
6902              we skip it.  If it turns out we couldn't find our field
6903              in the current record, then we'll get back to it and search
6904              inside it whether the field might exist in the parent.  */
6905
6906           parent_offset = i;
6907           continue;
6908         }
6909
6910       else if (field_name_match (t_field_name, name))
6911         return type->field (i).type ();
6912
6913       else if (ada_is_wrapper_field (type, i))
6914         {
6915           t = ada_lookup_struct_elt_type (type->field (i).type (), name,
6916                                           0, 1);
6917           if (t != NULL)
6918             return t;
6919         }
6920
6921       else if (ada_is_variant_part (type, i))
6922         {
6923           int j;
6924           struct type *field_type = ada_check_typedef (type->field (i).type ());
6925
6926           for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
6927             {
6928               /* FIXME pnh 2008/01/26: We check for a field that is
6929                  NOT wrapped in a struct, since the compiler sometimes
6930                  generates these for unchecked variant types.  Revisit
6931                  if the compiler changes this practice.  */
6932               const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
6933
6934               if (v_field_name != NULL 
6935                   && field_name_match (v_field_name, name))
6936                 t = field_type->field (j).type ();
6937               else
6938                 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
6939                                                 name, 0, 1);
6940
6941               if (t != NULL)
6942                 return t;
6943             }
6944         }
6945
6946     }
6947
6948     /* Field not found so far.  If this is a tagged type which
6949        has a parent, try finding that field in the parent now.  */
6950
6951     if (parent_offset != -1)
6952       {
6953         struct type *t;
6954
6955         t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
6956                                         name, 0, 1);
6957         if (t != NULL)
6958           return t;
6959       }
6960
6961 BadName:
6962   if (!noerr)
6963     {
6964       const char *name_str = name != NULL ? name : _("<null>");
6965
6966       error (_("Type %s has no component named %s"),
6967              type_as_string (type).c_str (), name_str);
6968     }
6969
6970   return NULL;
6971 }
6972
6973 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6974    within a value of type OUTER_TYPE, return true iff VAR_TYPE
6975    represents an unchecked union (that is, the variant part of a
6976    record that is named in an Unchecked_Union pragma).  */
6977
6978 static int
6979 is_unchecked_variant (struct type *var_type, struct type *outer_type)
6980 {
6981   const char *discrim_name = ada_variant_discrim_name (var_type);
6982
6983   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
6984 }
6985
6986
6987 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6988    within OUTER, determine which variant clause (field number in VAR_TYPE,
6989    numbering from 0) is applicable.  Returns -1 if none are.  */
6990
6991 int
6992 ada_which_variant_applies (struct type *var_type, struct value *outer)
6993 {
6994   int others_clause;
6995   int i;
6996   const char *discrim_name = ada_variant_discrim_name (var_type);
6997   struct value *discrim;
6998   LONGEST discrim_val;
6999
7000   /* Using plain value_from_contents_and_address here causes problems
7001      because we will end up trying to resolve a type that is currently
7002      being constructed.  */
7003   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7004   if (discrim == NULL)
7005     return -1;
7006   discrim_val = value_as_long (discrim);
7007
7008   others_clause = -1;
7009   for (i = 0; i < var_type->num_fields (); i += 1)
7010     {
7011       if (ada_is_others_clause (var_type, i))
7012         others_clause = i;
7013       else if (ada_in_variant (discrim_val, var_type, i))
7014         return i;
7015     }
7016
7017   return others_clause;
7018 }
7019 \f
7020
7021
7022                                 /* Dynamic-Sized Records */
7023
7024 /* Strategy: The type ostensibly attached to a value with dynamic size
7025    (i.e., a size that is not statically recorded in the debugging
7026    data) does not accurately reflect the size or layout of the value.
7027    Our strategy is to convert these values to values with accurate,
7028    conventional types that are constructed on the fly.  */
7029
7030 /* There is a subtle and tricky problem here.  In general, we cannot
7031    determine the size of dynamic records without its data.  However,
7032    the 'struct value' data structure, which GDB uses to represent
7033    quantities in the inferior process (the target), requires the size
7034    of the type at the time of its allocation in order to reserve space
7035    for GDB's internal copy of the data.  That's why the
7036    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7037    rather than struct value*s.
7038
7039    However, GDB's internal history variables ($1, $2, etc.) are
7040    struct value*s containing internal copies of the data that are not, in
7041    general, the same as the data at their corresponding addresses in
7042    the target.  Fortunately, the types we give to these values are all
7043    conventional, fixed-size types (as per the strategy described
7044    above), so that we don't usually have to perform the
7045    'to_fixed_xxx_type' conversions to look at their values.
7046    Unfortunately, there is one exception: if one of the internal
7047    history variables is an array whose elements are unconstrained
7048    records, then we will need to create distinct fixed types for each
7049    element selected.  */
7050
7051 /* The upshot of all of this is that many routines take a (type, host
7052    address, target address) triple as arguments to represent a value.
7053    The host address, if non-null, is supposed to contain an internal
7054    copy of the relevant data; otherwise, the program is to consult the
7055    target at the target address.  */
7056
7057 /* Assuming that VAL0 represents a pointer value, the result of
7058    dereferencing it.  Differs from value_ind in its treatment of
7059    dynamic-sized types.  */
7060
7061 struct value *
7062 ada_value_ind (struct value *val0)
7063 {
7064   struct value *val = value_ind (val0);
7065
7066   if (ada_is_tagged_type (value_type (val), 0))
7067     val = ada_tag_value_at_base_address (val);
7068
7069   return ada_to_fixed_value (val);
7070 }
7071
7072 /* The value resulting from dereferencing any "reference to"
7073    qualifiers on VAL0.  */
7074
7075 static struct value *
7076 ada_coerce_ref (struct value *val0)
7077 {
7078   if (value_type (val0)->code () == TYPE_CODE_REF)
7079     {
7080       struct value *val = val0;
7081
7082       val = coerce_ref (val);
7083
7084       if (ada_is_tagged_type (value_type (val), 0))
7085         val = ada_tag_value_at_base_address (val);
7086
7087       return ada_to_fixed_value (val);
7088     }
7089   else
7090     return val0;
7091 }
7092
7093 /* Return the bit alignment required for field #F of template type TYPE.  */
7094
7095 static unsigned int
7096 field_alignment (struct type *type, int f)
7097 {
7098   const char *name = TYPE_FIELD_NAME (type, f);
7099   int len;
7100   int align_offset;
7101
7102   /* The field name should never be null, unless the debugging information
7103      is somehow malformed.  In this case, we assume the field does not
7104      require any alignment.  */
7105   if (name == NULL)
7106     return 1;
7107
7108   len = strlen (name);
7109
7110   if (!isdigit (name[len - 1]))
7111     return 1;
7112
7113   if (isdigit (name[len - 2]))
7114     align_offset = len - 2;
7115   else
7116     align_offset = len - 1;
7117
7118   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7119     return TARGET_CHAR_BIT;
7120
7121   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7122 }
7123
7124 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7125
7126 static struct symbol *
7127 ada_find_any_type_symbol (const char *name)
7128 {
7129   struct symbol *sym;
7130
7131   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7132   if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7133     return sym;
7134
7135   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7136   return sym;
7137 }
7138
7139 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7140    solely for types defined by debug info, it will not search the GDB
7141    primitive types.  */
7142
7143 static struct type *
7144 ada_find_any_type (const char *name)
7145 {
7146   struct symbol *sym = ada_find_any_type_symbol (name);
7147
7148   if (sym != NULL)
7149     return SYMBOL_TYPE (sym);
7150
7151   return NULL;
7152 }
7153
7154 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7155    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
7156    symbol, in which case it is returned.  Otherwise, this looks for
7157    symbols whose name is that of NAME_SYM suffixed with  "___XR".
7158    Return symbol if found, and NULL otherwise.  */
7159
7160 static bool
7161 ada_is_renaming_symbol (struct symbol *name_sym)
7162 {
7163   const char *name = name_sym->linkage_name ();
7164   return strstr (name, "___XR") != NULL;
7165 }
7166
7167 /* Because of GNAT encoding conventions, several GDB symbols may match a
7168    given type name.  If the type denoted by TYPE0 is to be preferred to
7169    that of TYPE1 for purposes of type printing, return non-zero;
7170    otherwise return 0.  */
7171
7172 int
7173 ada_prefer_type (struct type *type0, struct type *type1)
7174 {
7175   if (type1 == NULL)
7176     return 1;
7177   else if (type0 == NULL)
7178     return 0;
7179   else if (type1->code () == TYPE_CODE_VOID)
7180     return 1;
7181   else if (type0->code () == TYPE_CODE_VOID)
7182     return 0;
7183   else if (type1->name () == NULL && type0->name () != NULL)
7184     return 1;
7185   else if (ada_is_constrained_packed_array_type (type0))
7186     return 1;
7187   else if (ada_is_array_descriptor_type (type0)
7188            && !ada_is_array_descriptor_type (type1))
7189     return 1;
7190   else
7191     {
7192       const char *type0_name = type0->name ();
7193       const char *type1_name = type1->name ();
7194
7195       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7196           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7197         return 1;
7198     }
7199   return 0;
7200 }
7201
7202 /* The name of TYPE, which is its TYPE_NAME.  Null if TYPE is
7203    null.  */
7204
7205 const char *
7206 ada_type_name (struct type *type)
7207 {
7208   if (type == NULL)
7209     return NULL;
7210   return type->name ();
7211 }
7212
7213 /* Search the list of "descriptive" types associated to TYPE for a type
7214    whose name is NAME.  */
7215
7216 static struct type *
7217 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7218 {
7219   struct type *result, *tmp;
7220
7221   if (ada_ignore_descriptive_types_p)
7222     return NULL;
7223
7224   /* If there no descriptive-type info, then there is no parallel type
7225      to be found.  */
7226   if (!HAVE_GNAT_AUX_INFO (type))
7227     return NULL;
7228
7229   result = TYPE_DESCRIPTIVE_TYPE (type);
7230   while (result != NULL)
7231     {
7232       const char *result_name = ada_type_name (result);
7233
7234       if (result_name == NULL)
7235         {
7236           warning (_("unexpected null name on descriptive type"));
7237           return NULL;
7238         }
7239
7240       /* If the names match, stop.  */
7241       if (strcmp (result_name, name) == 0)
7242         break;
7243
7244       /* Otherwise, look at the next item on the list, if any.  */
7245       if (HAVE_GNAT_AUX_INFO (result))
7246         tmp = TYPE_DESCRIPTIVE_TYPE (result);
7247       else
7248         tmp = NULL;
7249
7250       /* If not found either, try after having resolved the typedef.  */
7251       if (tmp != NULL)
7252         result = tmp;
7253       else
7254         {
7255           result = check_typedef (result);
7256           if (HAVE_GNAT_AUX_INFO (result))
7257             result = TYPE_DESCRIPTIVE_TYPE (result);
7258           else
7259             result = NULL;
7260         }
7261     }
7262
7263   /* If we didn't find a match, see whether this is a packed array.  With
7264      older compilers, the descriptive type information is either absent or
7265      irrelevant when it comes to packed arrays so the above lookup fails.
7266      Fall back to using a parallel lookup by name in this case.  */
7267   if (result == NULL && ada_is_constrained_packed_array_type (type))
7268     return ada_find_any_type (name);
7269
7270   return result;
7271 }
7272
7273 /* Find a parallel type to TYPE with the specified NAME, using the
7274    descriptive type taken from the debugging information, if available,
7275    and otherwise using the (slower) name-based method.  */
7276
7277 static struct type *
7278 ada_find_parallel_type_with_name (struct type *type, const char *name)
7279 {
7280   struct type *result = NULL;
7281
7282   if (HAVE_GNAT_AUX_INFO (type))
7283     result = find_parallel_type_by_descriptive_type (type, name);
7284   else
7285     result = ada_find_any_type (name);
7286
7287   return result;
7288 }
7289
7290 /* Same as above, but specify the name of the parallel type by appending
7291    SUFFIX to the name of TYPE.  */
7292
7293 struct type *
7294 ada_find_parallel_type (struct type *type, const char *suffix)
7295 {
7296   char *name;
7297   const char *type_name = ada_type_name (type);
7298   int len;
7299
7300   if (type_name == NULL)
7301     return NULL;
7302
7303   len = strlen (type_name);
7304
7305   name = (char *) alloca (len + strlen (suffix) + 1);
7306
7307   strcpy (name, type_name);
7308   strcpy (name + len, suffix);
7309
7310   return ada_find_parallel_type_with_name (type, name);
7311 }
7312
7313 /* If TYPE is a variable-size record type, return the corresponding template
7314    type describing its fields.  Otherwise, return NULL.  */
7315
7316 static struct type *
7317 dynamic_template_type (struct type *type)
7318 {
7319   type = ada_check_typedef (type);
7320
7321   if (type == NULL || type->code () != TYPE_CODE_STRUCT
7322       || ada_type_name (type) == NULL)
7323     return NULL;
7324   else
7325     {
7326       int len = strlen (ada_type_name (type));
7327
7328       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7329         return type;
7330       else
7331         return ada_find_parallel_type (type, "___XVE");
7332     }
7333 }
7334
7335 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7336    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
7337
7338 static int
7339 is_dynamic_field (struct type *templ_type, int field_num)
7340 {
7341   const char *name = TYPE_FIELD_NAME (templ_type, field_num);
7342
7343   return name != NULL
7344     && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7345     && strstr (name, "___XVL") != NULL;
7346 }
7347
7348 /* The index of the variant field of TYPE, or -1 if TYPE does not
7349    represent a variant record type.  */
7350
7351 static int
7352 variant_field_index (struct type *type)
7353 {
7354   int f;
7355
7356   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7357     return -1;
7358
7359   for (f = 0; f < type->num_fields (); f += 1)
7360     {
7361       if (ada_is_variant_part (type, f))
7362         return f;
7363     }
7364   return -1;
7365 }
7366
7367 /* A record type with no fields.  */
7368
7369 static struct type *
7370 empty_record (struct type *templ)
7371 {
7372   struct type *type = alloc_type_copy (templ);
7373
7374   type->set_code (TYPE_CODE_STRUCT);
7375   INIT_NONE_SPECIFIC (type);
7376   type->set_name ("<empty>");
7377   TYPE_LENGTH (type) = 0;
7378   return type;
7379 }
7380
7381 /* An ordinary record type (with fixed-length fields) that describes
7382    the value of type TYPE at VALADDR or ADDRESS (see comments at
7383    the beginning of this section) VAL according to GNAT conventions.
7384    DVAL0 should describe the (portion of a) record that contains any
7385    necessary discriminants.  It should be NULL if value_type (VAL) is
7386    an outer-level type (i.e., as opposed to a branch of a variant.)  A
7387    variant field (unless unchecked) is replaced by a particular branch
7388    of the variant.
7389
7390    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7391    length are not statically known are discarded.  As a consequence,
7392    VALADDR, ADDRESS and DVAL0 are ignored.
7393
7394    NOTE: Limitations: For now, we assume that dynamic fields and
7395    variants occupy whole numbers of bytes.  However, they need not be
7396    byte-aligned.  */
7397
7398 struct type *
7399 ada_template_to_fixed_record_type_1 (struct type *type,
7400                                      const gdb_byte *valaddr,
7401                                      CORE_ADDR address, struct value *dval0,
7402                                      int keep_dynamic_fields)
7403 {
7404   struct value *mark = value_mark ();
7405   struct value *dval;
7406   struct type *rtype;
7407   int nfields, bit_len;
7408   int variant_field;
7409   long off;
7410   int fld_bit_len;
7411   int f;
7412
7413   /* Compute the number of fields in this record type that are going
7414      to be processed: unless keep_dynamic_fields, this includes only
7415      fields whose position and length are static will be processed.  */
7416   if (keep_dynamic_fields)
7417     nfields = type->num_fields ();
7418   else
7419     {
7420       nfields = 0;
7421       while (nfields < type->num_fields ()
7422              && !ada_is_variant_part (type, nfields)
7423              && !is_dynamic_field (type, nfields))
7424         nfields++;
7425     }
7426
7427   rtype = alloc_type_copy (type);
7428   rtype->set_code (TYPE_CODE_STRUCT);
7429   INIT_NONE_SPECIFIC (rtype);
7430   rtype->set_num_fields (nfields);
7431   rtype->set_fields
7432    ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7433   rtype->set_name (ada_type_name (type));
7434   rtype->set_is_fixed_instance (true);
7435
7436   off = 0;
7437   bit_len = 0;
7438   variant_field = -1;
7439
7440   for (f = 0; f < nfields; f += 1)
7441     {
7442       off = align_up (off, field_alignment (type, f))
7443         + TYPE_FIELD_BITPOS (type, f);
7444       SET_FIELD_BITPOS (rtype->field (f), off);
7445       TYPE_FIELD_BITSIZE (rtype, f) = 0;
7446
7447       if (ada_is_variant_part (type, f))
7448         {
7449           variant_field = f;
7450           fld_bit_len = 0;
7451         }
7452       else if (is_dynamic_field (type, f))
7453         {
7454           const gdb_byte *field_valaddr = valaddr;
7455           CORE_ADDR field_address = address;
7456           struct type *field_type =
7457             TYPE_TARGET_TYPE (type->field (f).type ());
7458
7459           if (dval0 == NULL)
7460             {
7461               /* rtype's length is computed based on the run-time
7462                  value of discriminants.  If the discriminants are not
7463                  initialized, the type size may be completely bogus and
7464                  GDB may fail to allocate a value for it.  So check the
7465                  size first before creating the value.  */
7466               ada_ensure_varsize_limit (rtype);
7467               /* Using plain value_from_contents_and_address here
7468                  causes problems because we will end up trying to
7469                  resolve a type that is currently being
7470                  constructed.  */
7471               dval = value_from_contents_and_address_unresolved (rtype,
7472                                                                  valaddr,
7473                                                                  address);
7474               rtype = value_type (dval);
7475             }
7476           else
7477             dval = dval0;
7478
7479           /* If the type referenced by this field is an aligner type, we need
7480              to unwrap that aligner type, because its size might not be set.
7481              Keeping the aligner type would cause us to compute the wrong
7482              size for this field, impacting the offset of the all the fields
7483              that follow this one.  */
7484           if (ada_is_aligner_type (field_type))
7485             {
7486               long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7487
7488               field_valaddr = cond_offset_host (field_valaddr, field_offset);
7489               field_address = cond_offset_target (field_address, field_offset);
7490               field_type = ada_aligned_type (field_type);
7491             }
7492
7493           field_valaddr = cond_offset_host (field_valaddr,
7494                                             off / TARGET_CHAR_BIT);
7495           field_address = cond_offset_target (field_address,
7496                                               off / TARGET_CHAR_BIT);
7497
7498           /* Get the fixed type of the field.  Note that, in this case,
7499              we do not want to get the real type out of the tag: if
7500              the current field is the parent part of a tagged record,
7501              we will get the tag of the object.  Clearly wrong: the real
7502              type of the parent is not the real type of the child.  We
7503              would end up in an infinite loop.  */
7504           field_type = ada_get_base_type (field_type);
7505           field_type = ada_to_fixed_type (field_type, field_valaddr,
7506                                           field_address, dval, 0);
7507           /* If the field size is already larger than the maximum
7508              object size, then the record itself will necessarily
7509              be larger than the maximum object size.  We need to make
7510              this check now, because the size might be so ridiculously
7511              large (due to an uninitialized variable in the inferior)
7512              that it would cause an overflow when adding it to the
7513              record size.  */
7514           ada_ensure_varsize_limit (field_type);
7515
7516           rtype->field (f).set_type (field_type);
7517           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7518           /* The multiplication can potentially overflow.  But because
7519              the field length has been size-checked just above, and
7520              assuming that the maximum size is a reasonable value,
7521              an overflow should not happen in practice.  So rather than
7522              adding overflow recovery code to this already complex code,
7523              we just assume that it's not going to happen.  */
7524           fld_bit_len =
7525             TYPE_LENGTH (rtype->field (f).type ()) * TARGET_CHAR_BIT;
7526         }
7527       else
7528         {
7529           /* Note: If this field's type is a typedef, it is important
7530              to preserve the typedef layer.
7531
7532              Otherwise, we might be transforming a typedef to a fat
7533              pointer (encoding a pointer to an unconstrained array),
7534              into a basic fat pointer (encoding an unconstrained
7535              array).  As both types are implemented using the same
7536              structure, the typedef is the only clue which allows us
7537              to distinguish between the two options.  Stripping it
7538              would prevent us from printing this field appropriately.  */
7539           rtype->field (f).set_type (type->field (f).type ());
7540           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7541           if (TYPE_FIELD_BITSIZE (type, f) > 0)
7542             fld_bit_len =
7543               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7544           else
7545             {
7546               struct type *field_type = type->field (f).type ();
7547
7548               /* We need to be careful of typedefs when computing
7549                  the length of our field.  If this is a typedef,
7550                  get the length of the target type, not the length
7551                  of the typedef.  */
7552               if (field_type->code () == TYPE_CODE_TYPEDEF)
7553                 field_type = ada_typedef_target_type (field_type);
7554
7555               fld_bit_len =
7556                 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7557             }
7558         }
7559       if (off + fld_bit_len > bit_len)
7560         bit_len = off + fld_bit_len;
7561       off += fld_bit_len;
7562       TYPE_LENGTH (rtype) =
7563         align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7564     }
7565
7566   /* We handle the variant part, if any, at the end because of certain
7567      odd cases in which it is re-ordered so as NOT to be the last field of
7568      the record.  This can happen in the presence of representation
7569      clauses.  */
7570   if (variant_field >= 0)
7571     {
7572       struct type *branch_type;
7573
7574       off = TYPE_FIELD_BITPOS (rtype, variant_field);
7575
7576       if (dval0 == NULL)
7577         {
7578           /* Using plain value_from_contents_and_address here causes
7579              problems because we will end up trying to resolve a type
7580              that is currently being constructed.  */
7581           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
7582                                                              address);
7583           rtype = value_type (dval);
7584         }
7585       else
7586         dval = dval0;
7587
7588       branch_type =
7589         to_fixed_variant_branch_type
7590         (type->field (variant_field).type (),
7591          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7592          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7593       if (branch_type == NULL)
7594         {
7595           for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
7596             rtype->field (f - 1) = rtype->field (f);
7597           rtype->set_num_fields (rtype->num_fields () - 1);
7598         }
7599       else
7600         {
7601           rtype->field (variant_field).set_type (branch_type);
7602           TYPE_FIELD_NAME (rtype, variant_field) = "S";
7603           fld_bit_len =
7604             TYPE_LENGTH (rtype->field (variant_field).type ()) *
7605             TARGET_CHAR_BIT;
7606           if (off + fld_bit_len > bit_len)
7607             bit_len = off + fld_bit_len;
7608           TYPE_LENGTH (rtype) =
7609             align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7610         }
7611     }
7612
7613   /* According to exp_dbug.ads, the size of TYPE for variable-size records
7614      should contain the alignment of that record, which should be a strictly
7615      positive value.  If null or negative, then something is wrong, most
7616      probably in the debug info.  In that case, we don't round up the size
7617      of the resulting type.  If this record is not part of another structure,
7618      the current RTYPE length might be good enough for our purposes.  */
7619   if (TYPE_LENGTH (type) <= 0)
7620     {
7621       if (rtype->name ())
7622         warning (_("Invalid type size for `%s' detected: %s."),
7623                  rtype->name (), pulongest (TYPE_LENGTH (type)));
7624       else
7625         warning (_("Invalid type size for <unnamed> detected: %s."),
7626                  pulongest (TYPE_LENGTH (type)));
7627     }
7628   else
7629     {
7630       TYPE_LENGTH (rtype) = align_up (TYPE_LENGTH (rtype),
7631                                       TYPE_LENGTH (type));
7632     }
7633
7634   value_free_to_mark (mark);
7635   if (TYPE_LENGTH (rtype) > varsize_limit)
7636     error (_("record type with dynamic size is larger than varsize-limit"));
7637   return rtype;
7638 }
7639
7640 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7641    of 1.  */
7642
7643 static struct type *
7644 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
7645                                CORE_ADDR address, struct value *dval0)
7646 {
7647   return ada_template_to_fixed_record_type_1 (type, valaddr,
7648                                               address, dval0, 1);
7649 }
7650
7651 /* An ordinary record type in which ___XVL-convention fields and
7652    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7653    static approximations, containing all possible fields.  Uses
7654    no runtime values.  Useless for use in values, but that's OK,
7655    since the results are used only for type determinations.   Works on both
7656    structs and unions.  Representation note: to save space, we memorize
7657    the result of this function in the TYPE_TARGET_TYPE of the
7658    template type.  */
7659
7660 static struct type *
7661 template_to_static_fixed_type (struct type *type0)
7662 {
7663   struct type *type;
7664   int nfields;
7665   int f;
7666
7667   /* No need no do anything if the input type is already fixed.  */
7668   if (type0->is_fixed_instance ())
7669     return type0;
7670
7671   /* Likewise if we already have computed the static approximation.  */
7672   if (TYPE_TARGET_TYPE (type0) != NULL)
7673     return TYPE_TARGET_TYPE (type0);
7674
7675   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
7676   type = type0;
7677   nfields = type0->num_fields ();
7678
7679   /* Whether or not we cloned TYPE0, cache the result so that we don't do
7680      recompute all over next time.  */
7681   TYPE_TARGET_TYPE (type0) = type;
7682
7683   for (f = 0; f < nfields; f += 1)
7684     {
7685       struct type *field_type = type0->field (f).type ();
7686       struct type *new_type;
7687
7688       if (is_dynamic_field (type0, f))
7689         {
7690           field_type = ada_check_typedef (field_type);
7691           new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
7692         }
7693       else
7694         new_type = static_unwrap_type (field_type);
7695
7696       if (new_type != field_type)
7697         {
7698           /* Clone TYPE0 only the first time we get a new field type.  */
7699           if (type == type0)
7700             {
7701               TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
7702               type->set_code (type0->code ());
7703               INIT_NONE_SPECIFIC (type);
7704               type->set_num_fields (nfields);
7705
7706               field *fields =
7707                 ((struct field *)
7708                  TYPE_ALLOC (type, nfields * sizeof (struct field)));
7709               memcpy (fields, type0->fields (),
7710                       sizeof (struct field) * nfields);
7711               type->set_fields (fields);
7712
7713               type->set_name (ada_type_name (type0));
7714               type->set_is_fixed_instance (true);
7715               TYPE_LENGTH (type) = 0;
7716             }
7717           type->field (f).set_type (new_type);
7718           TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
7719         }
7720     }
7721
7722   return type;
7723 }
7724
7725 /* Given an object of type TYPE whose contents are at VALADDR and
7726    whose address in memory is ADDRESS, returns a revision of TYPE,
7727    which should be a non-dynamic-sized record, in which the variant
7728    part, if any, is replaced with the appropriate branch.  Looks
7729    for discriminant values in DVAL0, which can be NULL if the record
7730    contains the necessary discriminant values.  */
7731
7732 static struct type *
7733 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
7734                                    CORE_ADDR address, struct value *dval0)
7735 {
7736   struct value *mark = value_mark ();
7737   struct value *dval;
7738   struct type *rtype;
7739   struct type *branch_type;
7740   int nfields = type->num_fields ();
7741   int variant_field = variant_field_index (type);
7742
7743   if (variant_field == -1)
7744     return type;
7745
7746   if (dval0 == NULL)
7747     {
7748       dval = value_from_contents_and_address (type, valaddr, address);
7749       type = value_type (dval);
7750     }
7751   else
7752     dval = dval0;
7753
7754   rtype = alloc_type_copy (type);
7755   rtype->set_code (TYPE_CODE_STRUCT);
7756   INIT_NONE_SPECIFIC (rtype);
7757   rtype->set_num_fields (nfields);
7758
7759   field *fields =
7760     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7761   memcpy (fields, type->fields (), sizeof (struct field) * nfields);
7762   rtype->set_fields (fields);
7763
7764   rtype->set_name (ada_type_name (type));
7765   rtype->set_is_fixed_instance (true);
7766   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7767
7768   branch_type = to_fixed_variant_branch_type
7769     (type->field (variant_field).type (),
7770      cond_offset_host (valaddr,
7771                        TYPE_FIELD_BITPOS (type, variant_field)
7772                        / TARGET_CHAR_BIT),
7773      cond_offset_target (address,
7774                          TYPE_FIELD_BITPOS (type, variant_field)
7775                          / TARGET_CHAR_BIT), dval);
7776   if (branch_type == NULL)
7777     {
7778       int f;
7779
7780       for (f = variant_field + 1; f < nfields; f += 1)
7781         rtype->field (f - 1) = rtype->field (f);
7782       rtype->set_num_fields (rtype->num_fields () - 1);
7783     }
7784   else
7785     {
7786       rtype->field (variant_field).set_type (branch_type);
7787       TYPE_FIELD_NAME (rtype, variant_field) = "S";
7788       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
7789       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
7790     }
7791   TYPE_LENGTH (rtype) -= TYPE_LENGTH (type->field (variant_field).type ());
7792
7793   value_free_to_mark (mark);
7794   return rtype;
7795 }
7796
7797 /* An ordinary record type (with fixed-length fields) that describes
7798    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7799    beginning of this section].   Any necessary discriminants' values
7800    should be in DVAL, a record value; it may be NULL if the object
7801    at ADDR itself contains any necessary discriminant values.
7802    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7803    values from the record are needed.  Except in the case that DVAL,
7804    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7805    unchecked) is replaced by a particular branch of the variant.
7806
7807    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7808    is questionable and may be removed.  It can arise during the
7809    processing of an unconstrained-array-of-record type where all the
7810    variant branches have exactly the same size.  This is because in
7811    such cases, the compiler does not bother to use the XVS convention
7812    when encoding the record.  I am currently dubious of this
7813    shortcut and suspect the compiler should be altered.  FIXME.  */
7814
7815 static struct type *
7816 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
7817                       CORE_ADDR address, struct value *dval)
7818 {
7819   struct type *templ_type;
7820
7821   if (type0->is_fixed_instance ())
7822     return type0;
7823
7824   templ_type = dynamic_template_type (type0);
7825
7826   if (templ_type != NULL)
7827     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
7828   else if (variant_field_index (type0) >= 0)
7829     {
7830       if (dval == NULL && valaddr == NULL && address == 0)
7831         return type0;
7832       return to_record_with_fixed_variant_part (type0, valaddr, address,
7833                                                 dval);
7834     }
7835   else
7836     {
7837       type0->set_is_fixed_instance (true);
7838       return type0;
7839     }
7840
7841 }
7842
7843 /* An ordinary record type (with fixed-length fields) that describes
7844    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7845    union type.  Any necessary discriminants' values should be in DVAL,
7846    a record value.  That is, this routine selects the appropriate
7847    branch of the union at ADDR according to the discriminant value
7848    indicated in the union's type name.  Returns VAR_TYPE0 itself if
7849    it represents a variant subject to a pragma Unchecked_Union.  */
7850
7851 static struct type *
7852 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
7853                               CORE_ADDR address, struct value *dval)
7854 {
7855   int which;
7856   struct type *templ_type;
7857   struct type *var_type;
7858
7859   if (var_type0->code () == TYPE_CODE_PTR)
7860     var_type = TYPE_TARGET_TYPE (var_type0);
7861   else
7862     var_type = var_type0;
7863
7864   templ_type = ada_find_parallel_type (var_type, "___XVU");
7865
7866   if (templ_type != NULL)
7867     var_type = templ_type;
7868
7869   if (is_unchecked_variant (var_type, value_type (dval)))
7870       return var_type0;
7871   which = ada_which_variant_applies (var_type, dval);
7872
7873   if (which < 0)
7874     return empty_record (var_type);
7875   else if (is_dynamic_field (var_type, which))
7876     return to_fixed_record_type
7877       (TYPE_TARGET_TYPE (var_type->field (which).type ()),
7878        valaddr, address, dval);
7879   else if (variant_field_index (var_type->field (which).type ()) >= 0)
7880     return
7881       to_fixed_record_type
7882       (var_type->field (which).type (), valaddr, address, dval);
7883   else
7884     return var_type->field (which).type ();
7885 }
7886
7887 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
7888    ENCODING_TYPE, a type following the GNAT conventions for discrete
7889    type encodings, only carries redundant information.  */
7890
7891 static int
7892 ada_is_redundant_range_encoding (struct type *range_type,
7893                                  struct type *encoding_type)
7894 {
7895   const char *bounds_str;
7896   int n;
7897   LONGEST lo, hi;
7898
7899   gdb_assert (range_type->code () == TYPE_CODE_RANGE);
7900
7901   if (get_base_type (range_type)->code ()
7902       != get_base_type (encoding_type)->code ())
7903     {
7904       /* The compiler probably used a simple base type to describe
7905          the range type instead of the range's actual base type,
7906          expecting us to get the real base type from the encoding
7907          anyway.  In this situation, the encoding cannot be ignored
7908          as redundant.  */
7909       return 0;
7910     }
7911
7912   if (is_dynamic_type (range_type))
7913     return 0;
7914
7915   if (encoding_type->name () == NULL)
7916     return 0;
7917
7918   bounds_str = strstr (encoding_type->name (), "___XDLU_");
7919   if (bounds_str == NULL)
7920     return 0;
7921
7922   n = 8; /* Skip "___XDLU_".  */
7923   if (!ada_scan_number (bounds_str, n, &lo, &n))
7924     return 0;
7925   if (range_type->bounds ()->low.const_val () != lo)
7926     return 0;
7927
7928   n += 2; /* Skip the "__" separator between the two bounds.  */
7929   if (!ada_scan_number (bounds_str, n, &hi, &n))
7930     return 0;
7931   if (range_type->bounds ()->high.const_val () != hi)
7932     return 0;
7933
7934   return 1;
7935 }
7936
7937 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
7938    a type following the GNAT encoding for describing array type
7939    indices, only carries redundant information.  */
7940
7941 static int
7942 ada_is_redundant_index_type_desc (struct type *array_type,
7943                                   struct type *desc_type)
7944 {
7945   struct type *this_layer = check_typedef (array_type);
7946   int i;
7947
7948   for (i = 0; i < desc_type->num_fields (); i++)
7949     {
7950       if (!ada_is_redundant_range_encoding (this_layer->index_type (),
7951                                             desc_type->field (i).type ()))
7952         return 0;
7953       this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
7954     }
7955
7956   return 1;
7957 }
7958
7959 /* Assuming that TYPE0 is an array type describing the type of a value
7960    at ADDR, and that DVAL describes a record containing any
7961    discriminants used in TYPE0, returns a type for the value that
7962    contains no dynamic components (that is, no components whose sizes
7963    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
7964    true, gives an error message if the resulting type's size is over
7965    varsize_limit.  */
7966
7967 static struct type *
7968 to_fixed_array_type (struct type *type0, struct value *dval,
7969                      int ignore_too_big)
7970 {
7971   struct type *index_type_desc;
7972   struct type *result;
7973   int constrained_packed_array_p;
7974   static const char *xa_suffix = "___XA";
7975
7976   type0 = ada_check_typedef (type0);
7977   if (type0->is_fixed_instance ())
7978     return type0;
7979
7980   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
7981   if (constrained_packed_array_p)
7982     {
7983       type0 = decode_constrained_packed_array_type (type0);
7984       if (type0 == nullptr)
7985         error (_("could not decode constrained packed array type"));
7986     }
7987
7988   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
7989
7990   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
7991      encoding suffixed with 'P' may still be generated.  If so,
7992      it should be used to find the XA type.  */
7993
7994   if (index_type_desc == NULL)
7995     {
7996       const char *type_name = ada_type_name (type0);
7997
7998       if (type_name != NULL)
7999         {
8000           const int len = strlen (type_name);
8001           char *name = (char *) alloca (len + strlen (xa_suffix));
8002
8003           if (type_name[len - 1] == 'P')
8004             {
8005               strcpy (name, type_name);
8006               strcpy (name + len - 1, xa_suffix);
8007               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8008             }
8009         }
8010     }
8011
8012   ada_fixup_array_indexes_type (index_type_desc);
8013   if (index_type_desc != NULL
8014       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8015     {
8016       /* Ignore this ___XA parallel type, as it does not bring any
8017          useful information.  This allows us to avoid creating fixed
8018          versions of the array's index types, which would be identical
8019          to the original ones.  This, in turn, can also help avoid
8020          the creation of fixed versions of the array itself.  */
8021       index_type_desc = NULL;
8022     }
8023
8024   if (index_type_desc == NULL)
8025     {
8026       struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8027
8028       /* NOTE: elt_type---the fixed version of elt_type0---should never
8029          depend on the contents of the array in properly constructed
8030          debugging data.  */
8031       /* Create a fixed version of the array element type.
8032          We're not providing the address of an element here,
8033          and thus the actual object value cannot be inspected to do
8034          the conversion.  This should not be a problem, since arrays of
8035          unconstrained objects are not allowed.  In particular, all
8036          the elements of an array of a tagged type should all be of
8037          the same type specified in the debugging info.  No need to
8038          consult the object tag.  */
8039       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8040
8041       /* Make sure we always create a new array type when dealing with
8042          packed array types, since we're going to fix-up the array
8043          type length and element bitsize a little further down.  */
8044       if (elt_type0 == elt_type && !constrained_packed_array_p)
8045         result = type0;
8046       else
8047         result = create_array_type (alloc_type_copy (type0),
8048                                     elt_type, type0->index_type ());
8049     }
8050   else
8051     {
8052       int i;
8053       struct type *elt_type0;
8054
8055       elt_type0 = type0;
8056       for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8057         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8058
8059       /* NOTE: result---the fixed version of elt_type0---should never
8060          depend on the contents of the array in properly constructed
8061          debugging data.  */
8062       /* Create a fixed version of the array element type.
8063          We're not providing the address of an element here,
8064          and thus the actual object value cannot be inspected to do
8065          the conversion.  This should not be a problem, since arrays of
8066          unconstrained objects are not allowed.  In particular, all
8067          the elements of an array of a tagged type should all be of
8068          the same type specified in the debugging info.  No need to
8069          consult the object tag.  */
8070       result =
8071         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8072
8073       elt_type0 = type0;
8074       for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8075         {
8076           struct type *range_type =
8077             to_fixed_range_type (index_type_desc->field (i).type (), dval);
8078
8079           result = create_array_type (alloc_type_copy (elt_type0),
8080                                       result, range_type);
8081           elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8082         }
8083       if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
8084         error (_("array type with dynamic size is larger than varsize-limit"));
8085     }
8086
8087   /* We want to preserve the type name.  This can be useful when
8088      trying to get the type name of a value that has already been
8089      printed (for instance, if the user did "print VAR; whatis $".  */
8090   result->set_name (type0->name ());
8091
8092   if (constrained_packed_array_p)
8093     {
8094       /* So far, the resulting type has been created as if the original
8095          type was a regular (non-packed) array type.  As a result, the
8096          bitsize of the array elements needs to be set again, and the array
8097          length needs to be recomputed based on that bitsize.  */
8098       int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8099       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8100
8101       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8102       TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8103       if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8104         TYPE_LENGTH (result)++;
8105     }
8106
8107   result->set_is_fixed_instance (true);
8108   return result;
8109 }
8110
8111
8112 /* A standard type (containing no dynamically sized components)
8113    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8114    DVAL describes a record containing any discriminants used in TYPE0,
8115    and may be NULL if there are none, or if the object of type TYPE at
8116    ADDRESS or in VALADDR contains these discriminants.
8117    
8118    If CHECK_TAG is not null, in the case of tagged types, this function
8119    attempts to locate the object's tag and use it to compute the actual
8120    type.  However, when ADDRESS is null, we cannot use it to determine the
8121    location of the tag, and therefore compute the tagged type's actual type.
8122    So we return the tagged type without consulting the tag.  */
8123    
8124 static struct type *
8125 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8126                    CORE_ADDR address, struct value *dval, int check_tag)
8127 {
8128   type = ada_check_typedef (type);
8129
8130   /* Only un-fixed types need to be handled here.  */
8131   if (!HAVE_GNAT_AUX_INFO (type))
8132     return type;
8133
8134   switch (type->code ())
8135     {
8136     default:
8137       return type;
8138     case TYPE_CODE_STRUCT:
8139       {
8140         struct type *static_type = to_static_fixed_type (type);
8141         struct type *fixed_record_type =
8142           to_fixed_record_type (type, valaddr, address, NULL);
8143
8144         /* If STATIC_TYPE is a tagged type and we know the object's address,
8145            then we can determine its tag, and compute the object's actual
8146            type from there.  Note that we have to use the fixed record
8147            type (the parent part of the record may have dynamic fields
8148            and the way the location of _tag is expressed may depend on
8149            them).  */
8150
8151         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8152           {
8153             struct value *tag =
8154               value_tag_from_contents_and_address
8155               (fixed_record_type,
8156                valaddr,
8157                address);
8158             struct type *real_type = type_from_tag (tag);
8159             struct value *obj =
8160               value_from_contents_and_address (fixed_record_type,
8161                                                valaddr,
8162                                                address);
8163             fixed_record_type = value_type (obj);
8164             if (real_type != NULL)
8165               return to_fixed_record_type
8166                 (real_type, NULL,
8167                  value_address (ada_tag_value_at_base_address (obj)), NULL);
8168           }
8169
8170         /* Check to see if there is a parallel ___XVZ variable.
8171            If there is, then it provides the actual size of our type.  */
8172         else if (ada_type_name (fixed_record_type) != NULL)
8173           {
8174             const char *name = ada_type_name (fixed_record_type);
8175             char *xvz_name
8176               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8177             bool xvz_found = false;
8178             LONGEST size;
8179
8180             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8181             try
8182               {
8183                 xvz_found = get_int_var_value (xvz_name, size);
8184               }
8185             catch (const gdb_exception_error &except)
8186               {
8187                 /* We found the variable, but somehow failed to read
8188                    its value.  Rethrow the same error, but with a little
8189                    bit more information, to help the user understand
8190                    what went wrong (Eg: the variable might have been
8191                    optimized out).  */
8192                 throw_error (except.error,
8193                              _("unable to read value of %s (%s)"),
8194                              xvz_name, except.what ());
8195               }
8196
8197             if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8198               {
8199                 fixed_record_type = copy_type (fixed_record_type);
8200                 TYPE_LENGTH (fixed_record_type) = size;
8201
8202                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
8203                    observed this when the debugging info is STABS, and
8204                    apparently it is something that is hard to fix.
8205
8206                    In practice, we don't need the actual type definition
8207                    at all, because the presence of the XVZ variable allows us
8208                    to assume that there must be a XVS type as well, which we
8209                    should be able to use later, when we need the actual type
8210                    definition.
8211
8212                    In the meantime, pretend that the "fixed" type we are
8213                    returning is NOT a stub, because this can cause trouble
8214                    when using this type to create new types targeting it.
8215                    Indeed, the associated creation routines often check
8216                    whether the target type is a stub and will try to replace
8217                    it, thus using a type with the wrong size.  This, in turn,
8218                    might cause the new type to have the wrong size too.
8219                    Consider the case of an array, for instance, where the size
8220                    of the array is computed from the number of elements in
8221                    our array multiplied by the size of its element.  */
8222                 fixed_record_type->set_is_stub (false);
8223               }
8224           }
8225         return fixed_record_type;
8226       }
8227     case TYPE_CODE_ARRAY:
8228       return to_fixed_array_type (type, dval, 1);
8229     case TYPE_CODE_UNION:
8230       if (dval == NULL)
8231         return type;
8232       else
8233         return to_fixed_variant_branch_type (type, valaddr, address, dval);
8234     }
8235 }
8236
8237 /* The same as ada_to_fixed_type_1, except that it preserves the type
8238    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8239
8240    The typedef layer needs be preserved in order to differentiate between
8241    arrays and array pointers when both types are implemented using the same
8242    fat pointer.  In the array pointer case, the pointer is encoded as
8243    a typedef of the pointer type.  For instance, considering:
8244
8245           type String_Access is access String;
8246           S1 : String_Access := null;
8247
8248    To the debugger, S1 is defined as a typedef of type String.  But
8249    to the user, it is a pointer.  So if the user tries to print S1,
8250    we should not dereference the array, but print the array address
8251    instead.
8252
8253    If we didn't preserve the typedef layer, we would lose the fact that
8254    the type is to be presented as a pointer (needs de-reference before
8255    being printed).  And we would also use the source-level type name.  */
8256
8257 struct type *
8258 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8259                    CORE_ADDR address, struct value *dval, int check_tag)
8260
8261 {
8262   struct type *fixed_type =
8263     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8264
8265   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8266       then preserve the typedef layer.
8267
8268       Implementation note: We can only check the main-type portion of
8269       the TYPE and FIXED_TYPE, because eliminating the typedef layer
8270       from TYPE now returns a type that has the same instance flags
8271       as TYPE.  For instance, if TYPE is a "typedef const", and its
8272       target type is a "struct", then the typedef elimination will return
8273       a "const" version of the target type.  See check_typedef for more
8274       details about how the typedef layer elimination is done.
8275
8276       brobecker/2010-11-19: It seems to me that the only case where it is
8277       useful to preserve the typedef layer is when dealing with fat pointers.
8278       Perhaps, we could add a check for that and preserve the typedef layer
8279       only in that situation.  But this seems unnecessary so far, probably
8280       because we call check_typedef/ada_check_typedef pretty much everywhere.
8281       */
8282   if (type->code () == TYPE_CODE_TYPEDEF
8283       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8284           == TYPE_MAIN_TYPE (fixed_type)))
8285     return type;
8286
8287   return fixed_type;
8288 }
8289
8290 /* A standard (static-sized) type corresponding as well as possible to
8291    TYPE0, but based on no runtime data.  */
8292
8293 static struct type *
8294 to_static_fixed_type (struct type *type0)
8295 {
8296   struct type *type;
8297
8298   if (type0 == NULL)
8299     return NULL;
8300
8301   if (type0->is_fixed_instance ())
8302     return type0;
8303
8304   type0 = ada_check_typedef (type0);
8305
8306   switch (type0->code ())
8307     {
8308     default:
8309       return type0;
8310     case TYPE_CODE_STRUCT:
8311       type = dynamic_template_type (type0);
8312       if (type != NULL)
8313         return template_to_static_fixed_type (type);
8314       else
8315         return template_to_static_fixed_type (type0);
8316     case TYPE_CODE_UNION:
8317       type = ada_find_parallel_type (type0, "___XVU");
8318       if (type != NULL)
8319         return template_to_static_fixed_type (type);
8320       else
8321         return template_to_static_fixed_type (type0);
8322     }
8323 }
8324
8325 /* A static approximation of TYPE with all type wrappers removed.  */
8326
8327 static struct type *
8328 static_unwrap_type (struct type *type)
8329 {
8330   if (ada_is_aligner_type (type))
8331     {
8332       struct type *type1 = ada_check_typedef (type)->field (0).type ();
8333       if (ada_type_name (type1) == NULL)
8334         type1->set_name (ada_type_name (type));
8335
8336       return static_unwrap_type (type1);
8337     }
8338   else
8339     {
8340       struct type *raw_real_type = ada_get_base_type (type);
8341
8342       if (raw_real_type == type)
8343         return type;
8344       else
8345         return to_static_fixed_type (raw_real_type);
8346     }
8347 }
8348
8349 /* In some cases, incomplete and private types require
8350    cross-references that are not resolved as records (for example,
8351       type Foo;
8352       type FooP is access Foo;
8353       V: FooP;
8354       type Foo is array ...;
8355    ).  In these cases, since there is no mechanism for producing
8356    cross-references to such types, we instead substitute for FooP a
8357    stub enumeration type that is nowhere resolved, and whose tag is
8358    the name of the actual type.  Call these types "non-record stubs".  */
8359
8360 /* A type equivalent to TYPE that is not a non-record stub, if one
8361    exists, otherwise TYPE.  */
8362
8363 struct type *
8364 ada_check_typedef (struct type *type)
8365 {
8366   if (type == NULL)
8367     return NULL;
8368
8369   /* If our type is an access to an unconstrained array, which is encoded
8370      as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8371      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8372      what allows us to distinguish between fat pointers that represent
8373      array types, and fat pointers that represent array access types
8374      (in both cases, the compiler implements them as fat pointers).  */
8375   if (ada_is_access_to_unconstrained_array (type))
8376     return type;
8377
8378   type = check_typedef (type);
8379   if (type == NULL || type->code () != TYPE_CODE_ENUM
8380       || !type->is_stub ()
8381       || type->name () == NULL)
8382     return type;
8383   else
8384     {
8385       const char *name = type->name ();
8386       struct type *type1 = ada_find_any_type (name);
8387
8388       if (type1 == NULL)
8389         return type;
8390
8391       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8392          stubs pointing to arrays, as we don't create symbols for array
8393          types, only for the typedef-to-array types).  If that's the case,
8394          strip the typedef layer.  */
8395       if (type1->code () == TYPE_CODE_TYPEDEF)
8396         type1 = ada_check_typedef (type1);
8397
8398       return type1;
8399     }
8400 }
8401
8402 /* A value representing the data at VALADDR/ADDRESS as described by
8403    type TYPE0, but with a standard (static-sized) type that correctly
8404    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
8405    type, then return VAL0 [this feature is simply to avoid redundant
8406    creation of struct values].  */
8407
8408 static struct value *
8409 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8410                            struct value *val0)
8411 {
8412   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8413
8414   if (type == type0 && val0 != NULL)
8415     return val0;
8416
8417   if (VALUE_LVAL (val0) != lval_memory)
8418     {
8419       /* Our value does not live in memory; it could be a convenience
8420          variable, for instance.  Create a not_lval value using val0's
8421          contents.  */
8422       return value_from_contents (type, value_contents (val0));
8423     }
8424
8425   return value_from_contents_and_address (type, 0, address);
8426 }
8427
8428 /* A value representing VAL, but with a standard (static-sized) type
8429    that correctly describes it.  Does not necessarily create a new
8430    value.  */
8431
8432 struct value *
8433 ada_to_fixed_value (struct value *val)
8434 {
8435   val = unwrap_value (val);
8436   val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8437   return val;
8438 }
8439 \f
8440
8441 /* Attributes */
8442
8443 /* Table mapping attribute numbers to names.
8444    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
8445
8446 static const char * const attribute_names[] = {
8447   "<?>",
8448
8449   "first",
8450   "last",
8451   "length",
8452   "image",
8453   "max",
8454   "min",
8455   "modulus",
8456   "pos",
8457   "size",
8458   "tag",
8459   "val",
8460   0
8461 };
8462
8463 static const char *
8464 ada_attribute_name (enum exp_opcode n)
8465 {
8466   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8467     return attribute_names[n - OP_ATR_FIRST + 1];
8468   else
8469     return attribute_names[0];
8470 }
8471
8472 /* Evaluate the 'POS attribute applied to ARG.  */
8473
8474 static LONGEST
8475 pos_atr (struct value *arg)
8476 {
8477   struct value *val = coerce_ref (arg);
8478   struct type *type = value_type (val);
8479
8480   if (!discrete_type_p (type))
8481     error (_("'POS only defined on discrete types"));
8482
8483   gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8484   if (!result.has_value ())
8485     error (_("enumeration value is invalid: can't find 'POS"));
8486
8487   return *result;
8488 }
8489
8490 struct value *
8491 ada_pos_atr (struct type *expect_type,
8492              struct expression *exp,
8493              enum noside noside, enum exp_opcode op,
8494              struct value *arg)
8495 {
8496   struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8497   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8498     return value_zero (type, not_lval);
8499   return value_from_longest (type, pos_atr (arg));
8500 }
8501
8502 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
8503
8504 static struct value *
8505 val_atr (struct type *type, LONGEST val)
8506 {
8507   gdb_assert (discrete_type_p (type));
8508   if (type->code () == TYPE_CODE_RANGE)
8509     type = TYPE_TARGET_TYPE (type);
8510   if (type->code () == TYPE_CODE_ENUM)
8511     {
8512       if (val < 0 || val >= type->num_fields ())
8513         error (_("argument to 'VAL out of range"));
8514       val = TYPE_FIELD_ENUMVAL (type, val);
8515     }
8516   return value_from_longest (type, val);
8517 }
8518
8519 struct value *
8520 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8521 {
8522   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8523     return value_zero (type, not_lval);
8524
8525   if (!discrete_type_p (type))
8526     error (_("'VAL only defined on discrete types"));
8527   if (!integer_type_p (value_type (arg)))
8528     error (_("'VAL requires integral argument"));
8529
8530   return val_atr (type, value_as_long (arg));
8531 }
8532 \f
8533
8534                                 /* Evaluation */
8535
8536 /* True if TYPE appears to be an Ada character type.
8537    [At the moment, this is true only for Character and Wide_Character;
8538    It is a heuristic test that could stand improvement].  */
8539
8540 bool
8541 ada_is_character_type (struct type *type)
8542 {
8543   const char *name;
8544
8545   /* If the type code says it's a character, then assume it really is,
8546      and don't check any further.  */
8547   if (type->code () == TYPE_CODE_CHAR)
8548     return true;
8549   
8550   /* Otherwise, assume it's a character type iff it is a discrete type
8551      with a known character type name.  */
8552   name = ada_type_name (type);
8553   return (name != NULL
8554           && (type->code () == TYPE_CODE_INT
8555               || type->code () == TYPE_CODE_RANGE)
8556           && (strcmp (name, "character") == 0
8557               || strcmp (name, "wide_character") == 0
8558               || strcmp (name, "wide_wide_character") == 0
8559               || strcmp (name, "unsigned char") == 0));
8560 }
8561
8562 /* True if TYPE appears to be an Ada string type.  */
8563
8564 bool
8565 ada_is_string_type (struct type *type)
8566 {
8567   type = ada_check_typedef (type);
8568   if (type != NULL
8569       && type->code () != TYPE_CODE_PTR
8570       && (ada_is_simple_array_type (type)
8571           || ada_is_array_descriptor_type (type))
8572       && ada_array_arity (type) == 1)
8573     {
8574       struct type *elttype = ada_array_element_type (type, 1);
8575
8576       return ada_is_character_type (elttype);
8577     }
8578   else
8579     return false;
8580 }
8581
8582 /* The compiler sometimes provides a parallel XVS type for a given
8583    PAD type.  Normally, it is safe to follow the PAD type directly,
8584    but older versions of the compiler have a bug that causes the offset
8585    of its "F" field to be wrong.  Following that field in that case
8586    would lead to incorrect results, but this can be worked around
8587    by ignoring the PAD type and using the associated XVS type instead.
8588
8589    Set to True if the debugger should trust the contents of PAD types.
8590    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
8591 static bool trust_pad_over_xvs = true;
8592
8593 /* True if TYPE is a struct type introduced by the compiler to force the
8594    alignment of a value.  Such types have a single field with a
8595    distinctive name.  */
8596
8597 int
8598 ada_is_aligner_type (struct type *type)
8599 {
8600   type = ada_check_typedef (type);
8601
8602   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
8603     return 0;
8604
8605   return (type->code () == TYPE_CODE_STRUCT
8606           && type->num_fields () == 1
8607           && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
8608 }
8609
8610 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8611    the parallel type.  */
8612
8613 struct type *
8614 ada_get_base_type (struct type *raw_type)
8615 {
8616   struct type *real_type_namer;
8617   struct type *raw_real_type;
8618
8619   if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
8620     return raw_type;
8621
8622   if (ada_is_aligner_type (raw_type))
8623     /* The encoding specifies that we should always use the aligner type.
8624        So, even if this aligner type has an associated XVS type, we should
8625        simply ignore it.
8626
8627        According to the compiler gurus, an XVS type parallel to an aligner
8628        type may exist because of a stabs limitation.  In stabs, aligner
8629        types are empty because the field has a variable-sized type, and
8630        thus cannot actually be used as an aligner type.  As a result,
8631        we need the associated parallel XVS type to decode the type.
8632        Since the policy in the compiler is to not change the internal
8633        representation based on the debugging info format, we sometimes
8634        end up having a redundant XVS type parallel to the aligner type.  */
8635     return raw_type;
8636
8637   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
8638   if (real_type_namer == NULL
8639       || real_type_namer->code () != TYPE_CODE_STRUCT
8640       || real_type_namer->num_fields () != 1)
8641     return raw_type;
8642
8643   if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
8644     {
8645       /* This is an older encoding form where the base type needs to be
8646          looked up by name.  We prefer the newer encoding because it is
8647          more efficient.  */
8648       raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
8649       if (raw_real_type == NULL)
8650         return raw_type;
8651       else
8652         return raw_real_type;
8653     }
8654
8655   /* The field in our XVS type is a reference to the base type.  */
8656   return TYPE_TARGET_TYPE (real_type_namer->field (0).type ());
8657 }
8658
8659 /* The type of value designated by TYPE, with all aligners removed.  */
8660
8661 struct type *
8662 ada_aligned_type (struct type *type)
8663 {
8664   if (ada_is_aligner_type (type))
8665     return ada_aligned_type (type->field (0).type ());
8666   else
8667     return ada_get_base_type (type);
8668 }
8669
8670
8671 /* The address of the aligned value in an object at address VALADDR
8672    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
8673
8674 const gdb_byte *
8675 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
8676 {
8677   if (ada_is_aligner_type (type))
8678     return ada_aligned_value_addr (type->field (0).type (),
8679                                    valaddr +
8680                                    TYPE_FIELD_BITPOS (type,
8681                                                       0) / TARGET_CHAR_BIT);
8682   else
8683     return valaddr;
8684 }
8685
8686
8687
8688 /* The printed representation of an enumeration literal with encoded
8689    name NAME.  The value is good to the next call of ada_enum_name.  */
8690 const char *
8691 ada_enum_name (const char *name)
8692 {
8693   static std::string storage;
8694   const char *tmp;
8695
8696   /* First, unqualify the enumeration name:
8697      1. Search for the last '.' character.  If we find one, then skip
8698      all the preceding characters, the unqualified name starts
8699      right after that dot.
8700      2. Otherwise, we may be debugging on a target where the compiler
8701      translates dots into "__".  Search forward for double underscores,
8702      but stop searching when we hit an overloading suffix, which is
8703      of the form "__" followed by digits.  */
8704
8705   tmp = strrchr (name, '.');
8706   if (tmp != NULL)
8707     name = tmp + 1;
8708   else
8709     {
8710       while ((tmp = strstr (name, "__")) != NULL)
8711         {
8712           if (isdigit (tmp[2]))
8713             break;
8714           else
8715             name = tmp + 2;
8716         }
8717     }
8718
8719   if (name[0] == 'Q')
8720     {
8721       int v;
8722
8723       if (name[1] == 'U' || name[1] == 'W')
8724         {
8725           if (sscanf (name + 2, "%x", &v) != 1)
8726             return name;
8727         }
8728       else if (((name[1] >= '0' && name[1] <= '9')
8729                 || (name[1] >= 'a' && name[1] <= 'z'))
8730                && name[2] == '\0')
8731         {
8732           storage = string_printf ("'%c'", name[1]);
8733           return storage.c_str ();
8734         }
8735       else
8736         return name;
8737
8738       if (isascii (v) && isprint (v))
8739         storage = string_printf ("'%c'", v);
8740       else if (name[1] == 'U')
8741         storage = string_printf ("[\"%02x\"]", v);
8742       else
8743         storage = string_printf ("[\"%04x\"]", v);
8744
8745       return storage.c_str ();
8746     }
8747   else
8748     {
8749       tmp = strstr (name, "__");
8750       if (tmp == NULL)
8751         tmp = strstr (name, "$");
8752       if (tmp != NULL)
8753         {
8754           storage = std::string (name, tmp - name);
8755           return storage.c_str ();
8756         }
8757
8758       return name;
8759     }
8760 }
8761
8762 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8763    value it wraps.  */
8764
8765 static struct value *
8766 unwrap_value (struct value *val)
8767 {
8768   struct type *type = ada_check_typedef (value_type (val));
8769
8770   if (ada_is_aligner_type (type))
8771     {
8772       struct value *v = ada_value_struct_elt (val, "F", 0);
8773       struct type *val_type = ada_check_typedef (value_type (v));
8774
8775       if (ada_type_name (val_type) == NULL)
8776         val_type->set_name (ada_type_name (type));
8777
8778       return unwrap_value (v);
8779     }
8780   else
8781     {
8782       struct type *raw_real_type =
8783         ada_check_typedef (ada_get_base_type (type));
8784
8785       /* If there is no parallel XVS or XVE type, then the value is
8786          already unwrapped.  Return it without further modification.  */
8787       if ((type == raw_real_type)
8788           && ada_find_parallel_type (type, "___XVE") == NULL)
8789         return val;
8790
8791       return
8792         coerce_unspec_val_to_type
8793         (val, ada_to_fixed_type (raw_real_type, 0,
8794                                  value_address (val),
8795                                  NULL, 1));
8796     }
8797 }
8798
8799 /* Given two array types T1 and T2, return nonzero iff both arrays
8800    contain the same number of elements.  */
8801
8802 static int
8803 ada_same_array_size_p (struct type *t1, struct type *t2)
8804 {
8805   LONGEST lo1, hi1, lo2, hi2;
8806
8807   /* Get the array bounds in order to verify that the size of
8808      the two arrays match.  */
8809   if (!get_array_bounds (t1, &lo1, &hi1)
8810       || !get_array_bounds (t2, &lo2, &hi2))
8811     error (_("unable to determine array bounds"));
8812
8813   /* To make things easier for size comparison, normalize a bit
8814      the case of empty arrays by making sure that the difference
8815      between upper bound and lower bound is always -1.  */
8816   if (lo1 > hi1)
8817     hi1 = lo1 - 1;
8818   if (lo2 > hi2)
8819     hi2 = lo2 - 1;
8820
8821   return (hi1 - lo1 == hi2 - lo2);
8822 }
8823
8824 /* Assuming that VAL is an array of integrals, and TYPE represents
8825    an array with the same number of elements, but with wider integral
8826    elements, return an array "casted" to TYPE.  In practice, this
8827    means that the returned array is built by casting each element
8828    of the original array into TYPE's (wider) element type.  */
8829
8830 static struct value *
8831 ada_promote_array_of_integrals (struct type *type, struct value *val)
8832 {
8833   struct type *elt_type = TYPE_TARGET_TYPE (type);
8834   LONGEST lo, hi;
8835   struct value *res;
8836   LONGEST i;
8837
8838   /* Verify that both val and type are arrays of scalars, and
8839      that the size of val's elements is smaller than the size
8840      of type's element.  */
8841   gdb_assert (type->code () == TYPE_CODE_ARRAY);
8842   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
8843   gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
8844   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
8845   gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
8846               > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
8847
8848   if (!get_array_bounds (type, &lo, &hi))
8849     error (_("unable to determine array bounds"));
8850
8851   res = allocate_value (type);
8852
8853   /* Promote each array element.  */
8854   for (i = 0; i < hi - lo + 1; i++)
8855     {
8856       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
8857
8858       memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
8859               value_contents_all (elt), TYPE_LENGTH (elt_type));
8860     }
8861
8862   return res;
8863 }
8864
8865 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8866    return the converted value.  */
8867
8868 static struct value *
8869 coerce_for_assign (struct type *type, struct value *val)
8870 {
8871   struct type *type2 = value_type (val);
8872
8873   if (type == type2)
8874     return val;
8875
8876   type2 = ada_check_typedef (type2);
8877   type = ada_check_typedef (type);
8878
8879   if (type2->code () == TYPE_CODE_PTR
8880       && type->code () == TYPE_CODE_ARRAY)
8881     {
8882       val = ada_value_ind (val);
8883       type2 = value_type (val);
8884     }
8885
8886   if (type2->code () == TYPE_CODE_ARRAY
8887       && type->code () == TYPE_CODE_ARRAY)
8888     {
8889       if (!ada_same_array_size_p (type, type2))
8890         error (_("cannot assign arrays of different length"));
8891
8892       if (is_integral_type (TYPE_TARGET_TYPE (type))
8893           && is_integral_type (TYPE_TARGET_TYPE (type2))
8894           && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8895                < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8896         {
8897           /* Allow implicit promotion of the array elements to
8898              a wider type.  */
8899           return ada_promote_array_of_integrals (type, val);
8900         }
8901
8902       if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8903           != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8904         error (_("Incompatible types in assignment"));
8905       deprecated_set_value_type (val, type);
8906     }
8907   return val;
8908 }
8909
8910 static struct value *
8911 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
8912 {
8913   struct value *val;
8914   struct type *type1, *type2;
8915   LONGEST v, v1, v2;
8916
8917   arg1 = coerce_ref (arg1);
8918   arg2 = coerce_ref (arg2);
8919   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
8920   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
8921
8922   if (type1->code () != TYPE_CODE_INT
8923       || type2->code () != TYPE_CODE_INT)
8924     return value_binop (arg1, arg2, op);
8925
8926   switch (op)
8927     {
8928     case BINOP_MOD:
8929     case BINOP_DIV:
8930     case BINOP_REM:
8931       break;
8932     default:
8933       return value_binop (arg1, arg2, op);
8934     }
8935
8936   v2 = value_as_long (arg2);
8937   if (v2 == 0)
8938     {
8939       const char *name;
8940       if (op == BINOP_MOD)
8941         name = "mod";
8942       else if (op == BINOP_DIV)
8943         name = "/";
8944       else
8945         {
8946           gdb_assert (op == BINOP_REM);
8947           name = "rem";
8948         }
8949
8950       error (_("second operand of %s must not be zero."), name);
8951     }
8952
8953   if (type1->is_unsigned () || op == BINOP_MOD)
8954     return value_binop (arg1, arg2, op);
8955
8956   v1 = value_as_long (arg1);
8957   switch (op)
8958     {
8959     case BINOP_DIV:
8960       v = v1 / v2;
8961       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
8962         v += v > 0 ? -1 : 1;
8963       break;
8964     case BINOP_REM:
8965       v = v1 % v2;
8966       if (v * v1 < 0)
8967         v -= v2;
8968       break;
8969     default:
8970       /* Should not reach this point.  */
8971       v = 0;
8972     }
8973
8974   val = allocate_value (type1);
8975   store_unsigned_integer (value_contents_raw (val),
8976                           TYPE_LENGTH (value_type (val)),
8977                           type_byte_order (type1), v);
8978   return val;
8979 }
8980
8981 static int
8982 ada_value_equal (struct value *arg1, struct value *arg2)
8983 {
8984   if (ada_is_direct_array_type (value_type (arg1))
8985       || ada_is_direct_array_type (value_type (arg2)))
8986     {
8987       struct type *arg1_type, *arg2_type;
8988
8989       /* Automatically dereference any array reference before
8990          we attempt to perform the comparison.  */
8991       arg1 = ada_coerce_ref (arg1);
8992       arg2 = ada_coerce_ref (arg2);
8993
8994       arg1 = ada_coerce_to_simple_array (arg1);
8995       arg2 = ada_coerce_to_simple_array (arg2);
8996
8997       arg1_type = ada_check_typedef (value_type (arg1));
8998       arg2_type = ada_check_typedef (value_type (arg2));
8999
9000       if (arg1_type->code () != TYPE_CODE_ARRAY
9001           || arg2_type->code () != TYPE_CODE_ARRAY)
9002         error (_("Attempt to compare array with non-array"));
9003       /* FIXME: The following works only for types whose
9004          representations use all bits (no padding or undefined bits)
9005          and do not have user-defined equality.  */
9006       return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9007               && memcmp (value_contents (arg1), value_contents (arg2),
9008                          TYPE_LENGTH (arg1_type)) == 0);
9009     }
9010   return value_equal (arg1, arg2);
9011 }
9012
9013 namespace expr
9014 {
9015
9016 bool
9017 check_objfile (const std::unique_ptr<ada_component> &comp,
9018                struct objfile *objfile)
9019 {
9020   return comp->uses_objfile (objfile);
9021 }
9022
9023 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9024    component of LHS (a simple array or a record).  Does not modify the
9025    inferior's memory, nor does it modify LHS (unless LHS ==
9026    CONTAINER).  */
9027
9028 static void
9029 assign_component (struct value *container, struct value *lhs, LONGEST index,
9030                   struct expression *exp, operation_up &arg)
9031 {
9032   scoped_value_mark mark;
9033
9034   struct value *elt;
9035   struct type *lhs_type = check_typedef (value_type (lhs));
9036
9037   if (lhs_type->code () == TYPE_CODE_ARRAY)
9038     {
9039       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9040       struct value *index_val = value_from_longest (index_type, index);
9041
9042       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9043     }
9044   else
9045     {
9046       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9047       elt = ada_to_fixed_value (elt);
9048     }
9049
9050   ada_aggregate_operation *ag_op
9051     = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9052   if (ag_op != nullptr)
9053     ag_op->assign_aggregate (container, elt, exp);
9054   else
9055     value_assign_to_component (container, elt,
9056                                arg->evaluate (nullptr, exp,
9057                                               EVAL_NORMAL));
9058 }
9059
9060 bool
9061 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9062 {
9063   for (const auto &item : m_components)
9064     if (item->uses_objfile (objfile))
9065       return true;
9066   return false;
9067 }
9068
9069 void
9070 ada_aggregate_component::dump (ui_file *stream, int depth)
9071 {
9072   fprintf_filtered (stream, _("%*sAggregate\n"), depth, "");
9073   for (const auto &item : m_components)
9074     item->dump (stream, depth + 1);
9075 }
9076
9077 void
9078 ada_aggregate_component::assign (struct value *container,
9079                                  struct value *lhs, struct expression *exp,
9080                                  std::vector<LONGEST> &indices,
9081                                  LONGEST low, LONGEST high)
9082 {
9083   for (auto &item : m_components)
9084     item->assign (container, lhs, exp, indices, low, high);
9085 }
9086
9087 /* See ada-exp.h.  */
9088
9089 value *
9090 ada_aggregate_operation::assign_aggregate (struct value *container,
9091                                            struct value *lhs,
9092                                            struct expression *exp)
9093 {
9094   struct type *lhs_type;
9095   LONGEST low_index, high_index;
9096
9097   container = ada_coerce_ref (container);
9098   if (ada_is_direct_array_type (value_type (container)))
9099     container = ada_coerce_to_simple_array (container);
9100   lhs = ada_coerce_ref (lhs);
9101   if (!deprecated_value_modifiable (lhs))
9102     error (_("Left operand of assignment is not a modifiable lvalue."));
9103
9104   lhs_type = check_typedef (value_type (lhs));
9105   if (ada_is_direct_array_type (lhs_type))
9106     {
9107       lhs = ada_coerce_to_simple_array (lhs);
9108       lhs_type = check_typedef (value_type (lhs));
9109       low_index = lhs_type->bounds ()->low.const_val ();
9110       high_index = lhs_type->bounds ()->high.const_val ();
9111     }
9112   else if (lhs_type->code () == TYPE_CODE_STRUCT)
9113     {
9114       low_index = 0;
9115       high_index = num_visible_fields (lhs_type) - 1;
9116     }
9117   else
9118     error (_("Left-hand side must be array or record."));
9119
9120   std::vector<LONGEST> indices (4);
9121   indices[0] = indices[1] = low_index - 1;
9122   indices[2] = indices[3] = high_index + 1;
9123
9124   std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9125                                    low_index, high_index);
9126
9127   return container;
9128 }
9129
9130 bool
9131 ada_positional_component::uses_objfile (struct objfile *objfile)
9132 {
9133   return m_op->uses_objfile (objfile);
9134 }
9135
9136 void
9137 ada_positional_component::dump (ui_file *stream, int depth)
9138 {
9139   fprintf_filtered (stream, _("%*sPositional, index = %d\n"),
9140                     depth, "", m_index);
9141   m_op->dump (stream, depth + 1);
9142 }
9143
9144 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9145    construct, given that the positions are relative to lower bound
9146    LOW, where HIGH is the upper bound.  Record the position in
9147    INDICES.  CONTAINER is as for assign_aggregate.  */
9148 void
9149 ada_positional_component::assign (struct value *container,
9150                                   struct value *lhs, struct expression *exp,
9151                                   std::vector<LONGEST> &indices,
9152                                   LONGEST low, LONGEST high)
9153 {
9154   LONGEST ind = m_index + low;
9155
9156   if (ind - 1 == high)
9157     warning (_("Extra components in aggregate ignored."));
9158   if (ind <= high)
9159     {
9160       add_component_interval (ind, ind, indices);
9161       assign_component (container, lhs, ind, exp, m_op);
9162     }
9163 }
9164
9165 bool
9166 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9167 {
9168   return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9169 }
9170
9171 void
9172 ada_discrete_range_association::dump (ui_file *stream, int depth)
9173 {
9174   fprintf_filtered (stream, _("%*sDiscrete range:\n"), depth, "");
9175   m_low->dump (stream, depth + 1);
9176   m_high->dump (stream, depth + 1);
9177 }
9178
9179 void
9180 ada_discrete_range_association::assign (struct value *container,
9181                                         struct value *lhs,
9182                                         struct expression *exp,
9183                                         std::vector<LONGEST> &indices,
9184                                         LONGEST low, LONGEST high,
9185                                         operation_up &op)
9186 {
9187   LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9188   LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9189
9190   if (lower <= upper && (lower < low || upper > high))
9191     error (_("Index in component association out of bounds."));
9192
9193   add_component_interval (lower, upper, indices);
9194   while (lower <= upper)
9195     {
9196       assign_component (container, lhs, lower, exp, op);
9197       lower += 1;
9198     }
9199 }
9200
9201 bool
9202 ada_name_association::uses_objfile (struct objfile *objfile)
9203 {
9204   return m_val->uses_objfile (objfile);
9205 }
9206
9207 void
9208 ada_name_association::dump (ui_file *stream, int depth)
9209 {
9210   fprintf_filtered (stream, _("%*sName:\n"), depth, "");
9211   m_val->dump (stream, depth + 1);
9212 }
9213
9214 void
9215 ada_name_association::assign (struct value *container,
9216                               struct value *lhs,
9217                               struct expression *exp,
9218                               std::vector<LONGEST> &indices,
9219                               LONGEST low, LONGEST high,
9220                               operation_up &op)
9221 {
9222   int index;
9223
9224   if (ada_is_direct_array_type (value_type (lhs)))
9225     index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9226                                                             EVAL_NORMAL)));
9227   else
9228     {
9229       ada_string_operation *strop
9230         = dynamic_cast<ada_string_operation *> (m_val.get ());
9231
9232       const char *name;
9233       if (strop != nullptr)
9234         name = strop->get_name ();
9235       else
9236         {
9237           ada_var_value_operation *vvo
9238             = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9239           if (vvo != nullptr)
9240             error (_("Invalid record component association."));
9241           name = vvo->get_symbol ()->natural_name ();
9242         }
9243
9244       index = 0;
9245       if (! find_struct_field (name, value_type (lhs), 0,
9246                                NULL, NULL, NULL, NULL, &index))
9247         error (_("Unknown component name: %s."), name);
9248     }
9249
9250   add_component_interval (index, index, indices);
9251   assign_component (container, lhs, index, exp, op);
9252 }
9253
9254 bool
9255 ada_choices_component::uses_objfile (struct objfile *objfile)
9256 {
9257   if (m_op->uses_objfile (objfile))
9258     return true;
9259   for (const auto &item : m_assocs)
9260     if (item->uses_objfile (objfile))
9261       return true;
9262   return false;
9263 }
9264
9265 void
9266 ada_choices_component::dump (ui_file *stream, int depth)
9267 {
9268   fprintf_filtered (stream, _("%*sChoices:\n"), depth, "");
9269   m_op->dump (stream, depth + 1);
9270   for (const auto &item : m_assocs)
9271     item->dump (stream, depth + 1);
9272 }
9273
9274 /* Assign into the components of LHS indexed by the OP_CHOICES
9275    construct at *POS, updating *POS past the construct, given that
9276    the allowable indices are LOW..HIGH.  Record the indices assigned
9277    to in INDICES.  CONTAINER is as for assign_aggregate.  */
9278 void
9279 ada_choices_component::assign (struct value *container,
9280                                struct value *lhs, struct expression *exp,
9281                                std::vector<LONGEST> &indices,
9282                                LONGEST low, LONGEST high)
9283 {
9284   for (auto &item : m_assocs)
9285     item->assign (container, lhs, exp, indices, low, high, m_op);
9286 }
9287
9288 bool
9289 ada_others_component::uses_objfile (struct objfile *objfile)
9290 {
9291   return m_op->uses_objfile (objfile);
9292 }
9293
9294 void
9295 ada_others_component::dump (ui_file *stream, int depth)
9296 {
9297   fprintf_filtered (stream, _("%*sOthers:\n"), depth, "");
9298   m_op->dump (stream, depth + 1);
9299 }
9300
9301 /* Assign the value of the expression in the OP_OTHERS construct in
9302    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9303    have not been previously assigned.  The index intervals already assigned
9304    are in INDICES.  CONTAINER is as for assign_aggregate.  */
9305 void
9306 ada_others_component::assign (struct value *container,
9307                               struct value *lhs, struct expression *exp,
9308                               std::vector<LONGEST> &indices,
9309                               LONGEST low, LONGEST high)
9310 {
9311   int num_indices = indices.size ();
9312   for (int i = 0; i < num_indices - 2; i += 2)
9313     {
9314       for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9315         assign_component (container, lhs, ind, exp, m_op);
9316     }
9317 }
9318
9319 struct value *
9320 ada_assign_operation::evaluate (struct type *expect_type,
9321                                 struct expression *exp,
9322                                 enum noside noside)
9323 {
9324   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9325
9326   ada_aggregate_operation *ag_op
9327     = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9328   if (ag_op != nullptr)
9329     {
9330       if (noside != EVAL_NORMAL)
9331         return arg1;
9332
9333       arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9334       return ada_value_assign (arg1, arg1);
9335     }
9336   /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9337      except if the lhs of our assignment is a convenience variable.
9338      In the case of assigning to a convenience variable, the lhs
9339      should be exactly the result of the evaluation of the rhs.  */
9340   struct type *type = value_type (arg1);
9341   if (VALUE_LVAL (arg1) == lval_internalvar)
9342     type = NULL;
9343   value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9344   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9345     return arg1;
9346   if (VALUE_LVAL (arg1) == lval_internalvar)
9347     {
9348       /* Nothing.  */
9349     }
9350   else
9351     arg2 = coerce_for_assign (value_type (arg1), arg2);
9352   return ada_value_assign (arg1, arg2);
9353 }
9354
9355 } /* namespace expr */
9356
9357 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9358    [ INDICES[0] .. INDICES[1] ],...  The resulting intervals do not
9359    overlap.  */
9360 static void
9361 add_component_interval (LONGEST low, LONGEST high, 
9362                         std::vector<LONGEST> &indices)
9363 {
9364   int i, j;
9365
9366   int size = indices.size ();
9367   for (i = 0; i < size; i += 2) {
9368     if (high >= indices[i] && low <= indices[i + 1])
9369       {
9370         int kh;
9371
9372         for (kh = i + 2; kh < size; kh += 2)
9373           if (high < indices[kh])
9374             break;
9375         if (low < indices[i])
9376           indices[i] = low;
9377         indices[i + 1] = indices[kh - 1];
9378         if (high > indices[i + 1])
9379           indices[i + 1] = high;
9380         memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9381         indices.resize (kh - i - 2);
9382         return;
9383       }
9384     else if (high < indices[i])
9385       break;
9386   }
9387         
9388   indices.resize (indices.size () + 2);
9389   for (j = indices.size () - 1; j >= i + 2; j -= 1)
9390     indices[j] = indices[j - 2];
9391   indices[i] = low;
9392   indices[i + 1] = high;
9393 }
9394
9395 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9396    is different.  */
9397
9398 static struct value *
9399 ada_value_cast (struct type *type, struct value *arg2)
9400 {
9401   if (type == ada_check_typedef (value_type (arg2)))
9402     return arg2;
9403
9404   return value_cast (type, arg2);
9405 }
9406
9407 /*  Evaluating Ada expressions, and printing their result.
9408     ------------------------------------------------------
9409
9410     1. Introduction:
9411     ----------------
9412
9413     We usually evaluate an Ada expression in order to print its value.
9414     We also evaluate an expression in order to print its type, which
9415     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9416     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
9417     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9418     the evaluation compared to the EVAL_NORMAL, but is otherwise very
9419     similar.
9420
9421     Evaluating expressions is a little more complicated for Ada entities
9422     than it is for entities in languages such as C.  The main reason for
9423     this is that Ada provides types whose definition might be dynamic.
9424     One example of such types is variant records.  Or another example
9425     would be an array whose bounds can only be known at run time.
9426
9427     The following description is a general guide as to what should be
9428     done (and what should NOT be done) in order to evaluate an expression
9429     involving such types, and when.  This does not cover how the semantic
9430     information is encoded by GNAT as this is covered separatly.  For the
9431     document used as the reference for the GNAT encoding, see exp_dbug.ads
9432     in the GNAT sources.
9433
9434     Ideally, we should embed each part of this description next to its
9435     associated code.  Unfortunately, the amount of code is so vast right
9436     now that it's hard to see whether the code handling a particular
9437     situation might be duplicated or not.  One day, when the code is
9438     cleaned up, this guide might become redundant with the comments
9439     inserted in the code, and we might want to remove it.
9440
9441     2. ``Fixing'' an Entity, the Simple Case:
9442     -----------------------------------------
9443
9444     When evaluating Ada expressions, the tricky issue is that they may
9445     reference entities whose type contents and size are not statically
9446     known.  Consider for instance a variant record:
9447
9448        type Rec (Empty : Boolean := True) is record
9449           case Empty is
9450              when True => null;
9451              when False => Value : Integer;
9452           end case;
9453        end record;
9454        Yes : Rec := (Empty => False, Value => 1);
9455        No  : Rec := (empty => True);
9456
9457     The size and contents of that record depends on the value of the
9458     descriminant (Rec.Empty).  At this point, neither the debugging
9459     information nor the associated type structure in GDB are able to
9460     express such dynamic types.  So what the debugger does is to create
9461     "fixed" versions of the type that applies to the specific object.
9462     We also informally refer to this operation as "fixing" an object,
9463     which means creating its associated fixed type.
9464
9465     Example: when printing the value of variable "Yes" above, its fixed
9466     type would look like this:
9467
9468        type Rec is record
9469           Empty : Boolean;
9470           Value : Integer;
9471        end record;
9472
9473     On the other hand, if we printed the value of "No", its fixed type
9474     would become:
9475
9476        type Rec is record
9477           Empty : Boolean;
9478        end record;
9479
9480     Things become a little more complicated when trying to fix an entity
9481     with a dynamic type that directly contains another dynamic type,
9482     such as an array of variant records, for instance.  There are
9483     two possible cases: Arrays, and records.
9484
9485     3. ``Fixing'' Arrays:
9486     ---------------------
9487
9488     The type structure in GDB describes an array in terms of its bounds,
9489     and the type of its elements.  By design, all elements in the array
9490     have the same type and we cannot represent an array of variant elements
9491     using the current type structure in GDB.  When fixing an array,
9492     we cannot fix the array element, as we would potentially need one
9493     fixed type per element of the array.  As a result, the best we can do
9494     when fixing an array is to produce an array whose bounds and size
9495     are correct (allowing us to read it from memory), but without having
9496     touched its element type.  Fixing each element will be done later,
9497     when (if) necessary.
9498
9499     Arrays are a little simpler to handle than records, because the same
9500     amount of memory is allocated for each element of the array, even if
9501     the amount of space actually used by each element differs from element
9502     to element.  Consider for instance the following array of type Rec:
9503
9504        type Rec_Array is array (1 .. 2) of Rec;
9505
9506     The actual amount of memory occupied by each element might be different
9507     from element to element, depending on the value of their discriminant.
9508     But the amount of space reserved for each element in the array remains
9509     fixed regardless.  So we simply need to compute that size using
9510     the debugging information available, from which we can then determine
9511     the array size (we multiply the number of elements of the array by
9512     the size of each element).
9513
9514     The simplest case is when we have an array of a constrained element
9515     type. For instance, consider the following type declarations:
9516
9517         type Bounded_String (Max_Size : Integer) is
9518            Length : Integer;
9519            Buffer : String (1 .. Max_Size);
9520         end record;
9521         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9522
9523     In this case, the compiler describes the array as an array of
9524     variable-size elements (identified by its XVS suffix) for which
9525     the size can be read in the parallel XVZ variable.
9526
9527     In the case of an array of an unconstrained element type, the compiler
9528     wraps the array element inside a private PAD type.  This type should not
9529     be shown to the user, and must be "unwrap"'ed before printing.  Note
9530     that we also use the adjective "aligner" in our code to designate
9531     these wrapper types.
9532
9533     In some cases, the size allocated for each element is statically
9534     known.  In that case, the PAD type already has the correct size,
9535     and the array element should remain unfixed.
9536
9537     But there are cases when this size is not statically known.
9538     For instance, assuming that "Five" is an integer variable:
9539
9540         type Dynamic is array (1 .. Five) of Integer;
9541         type Wrapper (Has_Length : Boolean := False) is record
9542            Data : Dynamic;
9543            case Has_Length is
9544               when True => Length : Integer;
9545               when False => null;
9546            end case;
9547         end record;
9548         type Wrapper_Array is array (1 .. 2) of Wrapper;
9549
9550         Hello : Wrapper_Array := (others => (Has_Length => True,
9551                                              Data => (others => 17),
9552                                              Length => 1));
9553
9554
9555     The debugging info would describe variable Hello as being an
9556     array of a PAD type.  The size of that PAD type is not statically
9557     known, but can be determined using a parallel XVZ variable.
9558     In that case, a copy of the PAD type with the correct size should
9559     be used for the fixed array.
9560
9561     3. ``Fixing'' record type objects:
9562     ----------------------------------
9563
9564     Things are slightly different from arrays in the case of dynamic
9565     record types.  In this case, in order to compute the associated
9566     fixed type, we need to determine the size and offset of each of
9567     its components.  This, in turn, requires us to compute the fixed
9568     type of each of these components.
9569
9570     Consider for instance the example:
9571
9572         type Bounded_String (Max_Size : Natural) is record
9573            Str : String (1 .. Max_Size);
9574            Length : Natural;
9575         end record;
9576         My_String : Bounded_String (Max_Size => 10);
9577
9578     In that case, the position of field "Length" depends on the size
9579     of field Str, which itself depends on the value of the Max_Size
9580     discriminant.  In order to fix the type of variable My_String,
9581     we need to fix the type of field Str.  Therefore, fixing a variant
9582     record requires us to fix each of its components.
9583
9584     However, if a component does not have a dynamic size, the component
9585     should not be fixed.  In particular, fields that use a PAD type
9586     should not fixed.  Here is an example where this might happen
9587     (assuming type Rec above):
9588
9589        type Container (Big : Boolean) is record
9590           First : Rec;
9591           After : Integer;
9592           case Big is
9593              when True => Another : Integer;
9594              when False => null;
9595           end case;
9596        end record;
9597        My_Container : Container := (Big => False,
9598                                     First => (Empty => True),
9599                                     After => 42);
9600
9601     In that example, the compiler creates a PAD type for component First,
9602     whose size is constant, and then positions the component After just
9603     right after it.  The offset of component After is therefore constant
9604     in this case.
9605
9606     The debugger computes the position of each field based on an algorithm
9607     that uses, among other things, the actual position and size of the field
9608     preceding it.  Let's now imagine that the user is trying to print
9609     the value of My_Container.  If the type fixing was recursive, we would
9610     end up computing the offset of field After based on the size of the
9611     fixed version of field First.  And since in our example First has
9612     only one actual field, the size of the fixed type is actually smaller
9613     than the amount of space allocated to that field, and thus we would
9614     compute the wrong offset of field After.
9615
9616     To make things more complicated, we need to watch out for dynamic
9617     components of variant records (identified by the ___XVL suffix in
9618     the component name).  Even if the target type is a PAD type, the size
9619     of that type might not be statically known.  So the PAD type needs
9620     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
9621     we might end up with the wrong size for our component.  This can be
9622     observed with the following type declarations:
9623
9624         type Octal is new Integer range 0 .. 7;
9625         type Octal_Array is array (Positive range <>) of Octal;
9626         pragma Pack (Octal_Array);
9627
9628         type Octal_Buffer (Size : Positive) is record
9629            Buffer : Octal_Array (1 .. Size);
9630            Length : Integer;
9631         end record;
9632
9633     In that case, Buffer is a PAD type whose size is unset and needs
9634     to be computed by fixing the unwrapped type.
9635
9636     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9637     ----------------------------------------------------------
9638
9639     Lastly, when should the sub-elements of an entity that remained unfixed
9640     thus far, be actually fixed?
9641
9642     The answer is: Only when referencing that element.  For instance
9643     when selecting one component of a record, this specific component
9644     should be fixed at that point in time.  Or when printing the value
9645     of a record, each component should be fixed before its value gets
9646     printed.  Similarly for arrays, the element of the array should be
9647     fixed when printing each element of the array, or when extracting
9648     one element out of that array.  On the other hand, fixing should
9649     not be performed on the elements when taking a slice of an array!
9650
9651     Note that one of the side effects of miscomputing the offset and
9652     size of each field is that we end up also miscomputing the size
9653     of the containing type.  This can have adverse results when computing
9654     the value of an entity.  GDB fetches the value of an entity based
9655     on the size of its type, and thus a wrong size causes GDB to fetch
9656     the wrong amount of memory.  In the case where the computed size is
9657     too small, GDB fetches too little data to print the value of our
9658     entity.  Results in this case are unpredictable, as we usually read
9659     past the buffer containing the data =:-o.  */
9660
9661 /* A helper function for TERNOP_IN_RANGE.  */
9662
9663 static value *
9664 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
9665                       enum noside noside,
9666                       value *arg1, value *arg2, value *arg3)
9667 {
9668   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9669   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9670   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
9671   return
9672     value_from_longest (type,
9673                         (value_less (arg1, arg3)
9674                          || value_equal (arg1, arg3))
9675                         && (value_less (arg2, arg1)
9676                             || value_equal (arg2, arg1)));
9677 }
9678
9679 /* A helper function for UNOP_NEG.  */
9680
9681 value *
9682 ada_unop_neg (struct type *expect_type,
9683               struct expression *exp,
9684               enum noside noside, enum exp_opcode op,
9685               struct value *arg1)
9686 {
9687   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9688   return value_neg (arg1);
9689 }
9690
9691 /* A helper function for UNOP_IN_RANGE.  */
9692
9693 value *
9694 ada_unop_in_range (struct type *expect_type,
9695                    struct expression *exp,
9696                    enum noside noside, enum exp_opcode op,
9697                    struct value *arg1, struct type *type)
9698 {
9699   struct value *arg2, *arg3;
9700   switch (type->code ())
9701     {
9702     default:
9703       lim_warning (_("Membership test incompletely implemented; "
9704                      "always returns true"));
9705       type = language_bool_type (exp->language_defn, exp->gdbarch);
9706       return value_from_longest (type, (LONGEST) 1);
9707
9708     case TYPE_CODE_RANGE:
9709       arg2 = value_from_longest (type,
9710                                  type->bounds ()->low.const_val ());
9711       arg3 = value_from_longest (type,
9712                                  type->bounds ()->high.const_val ());
9713       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9714       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9715       type = language_bool_type (exp->language_defn, exp->gdbarch);
9716       return
9717         value_from_longest (type,
9718                             (value_less (arg1, arg3)
9719                              || value_equal (arg1, arg3))
9720                             && (value_less (arg2, arg1)
9721                                 || value_equal (arg2, arg1)));
9722     }
9723 }
9724
9725 /* A helper function for OP_ATR_TAG.  */
9726
9727 value *
9728 ada_atr_tag (struct type *expect_type,
9729              struct expression *exp,
9730              enum noside noside, enum exp_opcode op,
9731              struct value *arg1)
9732 {
9733   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9734     return value_zero (ada_tag_type (arg1), not_lval);
9735
9736   return ada_value_tag (arg1);
9737 }
9738
9739 /* A helper function for OP_ATR_SIZE.  */
9740
9741 value *
9742 ada_atr_size (struct type *expect_type,
9743               struct expression *exp,
9744               enum noside noside, enum exp_opcode op,
9745               struct value *arg1)
9746 {
9747   struct type *type = value_type (arg1);
9748
9749   /* If the argument is a reference, then dereference its type, since
9750      the user is really asking for the size of the actual object,
9751      not the size of the pointer.  */
9752   if (type->code () == TYPE_CODE_REF)
9753     type = TYPE_TARGET_TYPE (type);
9754
9755   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9756     return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
9757   else
9758     return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
9759                                TARGET_CHAR_BIT * TYPE_LENGTH (type));
9760 }
9761
9762 /* A helper function for UNOP_ABS.  */
9763
9764 value *
9765 ada_abs (struct type *expect_type,
9766          struct expression *exp,
9767          enum noside noside, enum exp_opcode op,
9768          struct value *arg1)
9769 {
9770   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9771   if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
9772     return value_neg (arg1);
9773   else
9774     return arg1;
9775 }
9776
9777 /* A helper function for BINOP_MUL.  */
9778
9779 value *
9780 ada_mult_binop (struct type *expect_type,
9781                 struct expression *exp,
9782                 enum noside noside, enum exp_opcode op,
9783                 struct value *arg1, struct value *arg2)
9784 {
9785   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9786     {
9787       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9788       return value_zero (value_type (arg1), not_lval);
9789     }
9790   else
9791     {
9792       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9793       return ada_value_binop (arg1, arg2, op);
9794     }
9795 }
9796
9797 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL.  */
9798
9799 value *
9800 ada_equal_binop (struct type *expect_type,
9801                  struct expression *exp,
9802                  enum noside noside, enum exp_opcode op,
9803                  struct value *arg1, struct value *arg2)
9804 {
9805   int tem;
9806   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9807     tem = 0;
9808   else
9809     {
9810       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9811       tem = ada_value_equal (arg1, arg2);
9812     }
9813   if (op == BINOP_NOTEQUAL)
9814     tem = !tem;
9815   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
9816   return value_from_longest (type, (LONGEST) tem);
9817 }
9818
9819 /* A helper function for TERNOP_SLICE.  */
9820
9821 value *
9822 ada_ternop_slice (struct expression *exp,
9823                   enum noside noside,
9824                   struct value *array, struct value *low_bound_val,
9825                   struct value *high_bound_val)
9826 {
9827   LONGEST low_bound;
9828   LONGEST high_bound;
9829
9830   low_bound_val = coerce_ref (low_bound_val);
9831   high_bound_val = coerce_ref (high_bound_val);
9832   low_bound = value_as_long (low_bound_val);
9833   high_bound = value_as_long (high_bound_val);
9834
9835   /* If this is a reference to an aligner type, then remove all
9836      the aligners.  */
9837   if (value_type (array)->code () == TYPE_CODE_REF
9838       && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
9839     TYPE_TARGET_TYPE (value_type (array)) =
9840       ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
9841
9842   if (ada_is_any_packed_array_type (value_type (array)))
9843     error (_("cannot slice a packed array"));
9844
9845   /* If this is a reference to an array or an array lvalue,
9846      convert to a pointer.  */
9847   if (value_type (array)->code () == TYPE_CODE_REF
9848       || (value_type (array)->code () == TYPE_CODE_ARRAY
9849           && VALUE_LVAL (array) == lval_memory))
9850     array = value_addr (array);
9851
9852   if (noside == EVAL_AVOID_SIDE_EFFECTS
9853       && ada_is_array_descriptor_type (ada_check_typedef
9854                                        (value_type (array))))
9855     return empty_array (ada_type_of_array (array, 0), low_bound,
9856                         high_bound);
9857
9858   array = ada_coerce_to_simple_array_ptr (array);
9859
9860   /* If we have more than one level of pointer indirection,
9861      dereference the value until we get only one level.  */
9862   while (value_type (array)->code () == TYPE_CODE_PTR
9863          && (TYPE_TARGET_TYPE (value_type (array))->code ()
9864              == TYPE_CODE_PTR))
9865     array = value_ind (array);
9866
9867   /* Make sure we really do have an array type before going further,
9868      to avoid a SEGV when trying to get the index type or the target
9869      type later down the road if the debug info generated by
9870      the compiler is incorrect or incomplete.  */
9871   if (!ada_is_simple_array_type (value_type (array)))
9872     error (_("cannot take slice of non-array"));
9873
9874   if (ada_check_typedef (value_type (array))->code ()
9875       == TYPE_CODE_PTR)
9876     {
9877       struct type *type0 = ada_check_typedef (value_type (array));
9878
9879       if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
9880         return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
9881       else
9882         {
9883           struct type *arr_type0 =
9884             to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
9885
9886           return ada_value_slice_from_ptr (array, arr_type0,
9887                                            longest_to_int (low_bound),
9888                                            longest_to_int (high_bound));
9889         }
9890     }
9891   else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9892     return array;
9893   else if (high_bound < low_bound)
9894     return empty_array (value_type (array), low_bound, high_bound);
9895   else
9896     return ada_value_slice (array, longest_to_int (low_bound),
9897                             longest_to_int (high_bound));
9898 }
9899
9900 /* A helper function for BINOP_IN_BOUNDS.  */
9901
9902 value *
9903 ada_binop_in_bounds (struct expression *exp, enum noside noside,
9904                      struct value *arg1, struct value *arg2, int n)
9905 {
9906   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9907     {
9908       struct type *type = language_bool_type (exp->language_defn,
9909                                               exp->gdbarch);
9910       return value_zero (type, not_lval);
9911     }
9912
9913   struct type *type = ada_index_type (value_type (arg2), n, "range");
9914   if (!type)
9915     type = value_type (arg1);
9916
9917   value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
9918   arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
9919
9920   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9921   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9922   type = language_bool_type (exp->language_defn, exp->gdbarch);
9923   return value_from_longest (type,
9924                              (value_less (arg1, arg3)
9925                               || value_equal (arg1, arg3))
9926                              && (value_less (arg2, arg1)
9927                                  || value_equal (arg2, arg1)));
9928 }
9929
9930 /* A helper function for some attribute operations.  */
9931
9932 static value *
9933 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
9934               struct value *arg1, struct type *type_arg, int tem)
9935 {
9936   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9937     {
9938       if (type_arg == NULL)
9939         type_arg = value_type (arg1);
9940
9941       if (ada_is_constrained_packed_array_type (type_arg))
9942         type_arg = decode_constrained_packed_array_type (type_arg);
9943
9944       if (!discrete_type_p (type_arg))
9945         {
9946           switch (op)
9947             {
9948             default:          /* Should never happen.  */
9949               error (_("unexpected attribute encountered"));
9950             case OP_ATR_FIRST:
9951             case OP_ATR_LAST:
9952               type_arg = ada_index_type (type_arg, tem,
9953                                          ada_attribute_name (op));
9954               break;
9955             case OP_ATR_LENGTH:
9956               type_arg = builtin_type (exp->gdbarch)->builtin_int;
9957               break;
9958             }
9959         }
9960
9961       return value_zero (type_arg, not_lval);
9962     }
9963   else if (type_arg == NULL)
9964     {
9965       arg1 = ada_coerce_ref (arg1);
9966
9967       if (ada_is_constrained_packed_array_type (value_type (arg1)))
9968         arg1 = ada_coerce_to_simple_array (arg1);
9969
9970       struct type *type;
9971       if (op == OP_ATR_LENGTH)
9972         type = builtin_type (exp->gdbarch)->builtin_int;
9973       else
9974         {
9975           type = ada_index_type (value_type (arg1), tem,
9976                                  ada_attribute_name (op));
9977           if (type == NULL)
9978             type = builtin_type (exp->gdbarch)->builtin_int;
9979         }
9980
9981       switch (op)
9982         {
9983         default:          /* Should never happen.  */
9984           error (_("unexpected attribute encountered"));
9985         case OP_ATR_FIRST:
9986           return value_from_longest
9987             (type, ada_array_bound (arg1, tem, 0));
9988         case OP_ATR_LAST:
9989           return value_from_longest
9990             (type, ada_array_bound (arg1, tem, 1));
9991         case OP_ATR_LENGTH:
9992           return value_from_longest
9993             (type, ada_array_length (arg1, tem));
9994         }
9995     }
9996   else if (discrete_type_p (type_arg))
9997     {
9998       struct type *range_type;
9999       const char *name = ada_type_name (type_arg);
10000
10001       range_type = NULL;
10002       if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10003         range_type = to_fixed_range_type (type_arg, NULL);
10004       if (range_type == NULL)
10005         range_type = type_arg;
10006       switch (op)
10007         {
10008         default:
10009           error (_("unexpected attribute encountered"));
10010         case OP_ATR_FIRST:
10011           return value_from_longest 
10012             (range_type, ada_discrete_type_low_bound (range_type));
10013         case OP_ATR_LAST:
10014           return value_from_longest
10015             (range_type, ada_discrete_type_high_bound (range_type));
10016         case OP_ATR_LENGTH:
10017           error (_("the 'length attribute applies only to array types"));
10018         }
10019     }
10020   else if (type_arg->code () == TYPE_CODE_FLT)
10021     error (_("unimplemented type attribute"));
10022   else
10023     {
10024       LONGEST low, high;
10025
10026       if (ada_is_constrained_packed_array_type (type_arg))
10027         type_arg = decode_constrained_packed_array_type (type_arg);
10028
10029       struct type *type;
10030       if (op == OP_ATR_LENGTH)
10031         type = builtin_type (exp->gdbarch)->builtin_int;
10032       else
10033         {
10034           type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10035           if (type == NULL)
10036             type = builtin_type (exp->gdbarch)->builtin_int;
10037         }
10038
10039       switch (op)
10040         {
10041         default:
10042           error (_("unexpected attribute encountered"));
10043         case OP_ATR_FIRST:
10044           low = ada_array_bound_from_type (type_arg, tem, 0);
10045           return value_from_longest (type, low);
10046         case OP_ATR_LAST:
10047           high = ada_array_bound_from_type (type_arg, tem, 1);
10048           return value_from_longest (type, high);
10049         case OP_ATR_LENGTH:
10050           low = ada_array_bound_from_type (type_arg, tem, 0);
10051           high = ada_array_bound_from_type (type_arg, tem, 1);
10052           return value_from_longest (type, high - low + 1);
10053         }
10054     }
10055 }
10056
10057 /* A helper function for OP_ATR_MIN and OP_ATR_MAX.  */
10058
10059 struct value *
10060 ada_binop_minmax (struct type *expect_type,
10061                   struct expression *exp,
10062                   enum noside noside, enum exp_opcode op,
10063                   struct value *arg1, struct value *arg2)
10064 {
10065   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10066     return value_zero (value_type (arg1), not_lval);
10067   else
10068     {
10069       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10070       return value_binop (arg1, arg2, op);
10071     }
10072 }
10073
10074 /* A helper function for BINOP_EXP.  */
10075
10076 struct value *
10077 ada_binop_exp (struct type *expect_type,
10078                struct expression *exp,
10079                enum noside noside, enum exp_opcode op,
10080                struct value *arg1, struct value *arg2)
10081 {
10082   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10083     return value_zero (value_type (arg1), not_lval);
10084   else
10085     {
10086       /* For integer exponentiation operations,
10087          only promote the first argument.  */
10088       if (is_integral_type (value_type (arg2)))
10089         unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10090       else
10091         binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10092
10093       return value_binop (arg1, arg2, op);
10094     }
10095 }
10096
10097 namespace expr
10098 {
10099
10100 /* See ada-exp.h.  */
10101
10102 operation_up
10103 ada_resolvable::replace (operation_up &&owner,
10104                          struct expression *exp,
10105                          bool deprocedure_p,
10106                          bool parse_completion,
10107                          innermost_block_tracker *tracker,
10108                          struct type *context_type)
10109 {
10110   if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10111     return (make_operation<ada_funcall_operation>
10112             (std::move (owner),
10113              std::vector<operation_up> ()));
10114   return std::move (owner);
10115 }
10116
10117 /* Convert the character literal whose ASCII value would be VAL to the
10118    appropriate value of type TYPE, if there is a translation.
10119    Otherwise return VAL.  Hence, in an enumeration type ('A', 'B'),
10120    the literal 'A' (VAL == 65), returns 0.  */
10121
10122 static LONGEST
10123 convert_char_literal (struct type *type, LONGEST val)
10124 {
10125   char name[7];
10126   int f;
10127
10128   if (type == NULL)
10129     return val;
10130   type = check_typedef (type);
10131   if (type->code () != TYPE_CODE_ENUM)
10132     return val;
10133
10134   if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10135     xsnprintf (name, sizeof (name), "Q%c", (int) val);
10136   else
10137     xsnprintf (name, sizeof (name), "QU%02x", (int) val);
10138   size_t len = strlen (name);
10139   for (f = 0; f < type->num_fields (); f += 1)
10140     {
10141       /* Check the suffix because an enum constant in a package will
10142          have a name like "pkg__QUxx".  This is safe enough because we
10143          already have the correct type, and because mangling means
10144          there can't be clashes.  */
10145       const char *ename = TYPE_FIELD_NAME (type, f);
10146       size_t elen = strlen (ename);
10147
10148       if (elen >= len && strcmp (name, ename + elen - len) == 0)
10149         return TYPE_FIELD_ENUMVAL (type, f);
10150     }
10151   return val;
10152 }
10153
10154 /* See ada-exp.h.  */
10155
10156 operation_up
10157 ada_char_operation::replace (operation_up &&owner,
10158                              struct expression *exp,
10159                              bool deprocedure_p,
10160                              bool parse_completion,
10161                              innermost_block_tracker *tracker,
10162                              struct type *context_type)
10163 {
10164   operation_up result = std::move (owner);
10165
10166   if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10167     {
10168       gdb_assert (result.get () == this);
10169       std::get<0> (m_storage) = context_type;
10170       std::get<1> (m_storage)
10171         = convert_char_literal (context_type, std::get<1> (m_storage));
10172     }
10173
10174   return make_operation<ada_wrapped_operation> (std::move (result));
10175 }
10176
10177 value *
10178 ada_wrapped_operation::evaluate (struct type *expect_type,
10179                                  struct expression *exp,
10180                                  enum noside noside)
10181 {
10182   value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10183   if (noside == EVAL_NORMAL)
10184     result = unwrap_value (result);
10185
10186   /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10187      then we need to perform the conversion manually, because
10188      evaluate_subexp_standard doesn't do it.  This conversion is
10189      necessary in Ada because the different kinds of float/fixed
10190      types in Ada have different representations.
10191
10192      Similarly, we need to perform the conversion from OP_LONG
10193      ourselves.  */
10194   if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10195     result = ada_value_cast (expect_type, result);
10196
10197   return result;
10198 }
10199
10200 value *
10201 ada_string_operation::evaluate (struct type *expect_type,
10202                                 struct expression *exp,
10203                                 enum noside noside)
10204 {
10205   value *result = string_operation::evaluate (expect_type, exp, noside);
10206   /* The result type will have code OP_STRING, bashed there from 
10207      OP_ARRAY.  Bash it back.  */
10208   if (value_type (result)->code () == TYPE_CODE_STRING)
10209     value_type (result)->set_code (TYPE_CODE_ARRAY);
10210   return result;
10211 }
10212
10213 value *
10214 ada_qual_operation::evaluate (struct type *expect_type,
10215                               struct expression *exp,
10216                               enum noside noside)
10217 {
10218   struct type *type = std::get<1> (m_storage);
10219   return std::get<0> (m_storage)->evaluate (type, exp, noside);
10220 }
10221
10222 value *
10223 ada_ternop_range_operation::evaluate (struct type *expect_type,
10224                                       struct expression *exp,
10225                                       enum noside noside)
10226 {
10227   value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10228   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10229   value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10230   return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10231 }
10232
10233 value *
10234 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10235                                       struct expression *exp,
10236                                       enum noside noside)
10237 {
10238   value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10239   value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10240
10241   auto do_op = [=] (LONGEST x, LONGEST y)
10242     {
10243       if (std::get<0> (m_storage) == BINOP_ADD)
10244         return x + y;
10245       return x - y;
10246     };
10247
10248   if (value_type (arg1)->code () == TYPE_CODE_PTR)
10249     return (value_from_longest
10250             (value_type (arg1),
10251              do_op (value_as_long (arg1), value_as_long (arg2))));
10252   if (value_type (arg2)->code () == TYPE_CODE_PTR)
10253     return (value_from_longest
10254             (value_type (arg2),
10255              do_op (value_as_long (arg1), value_as_long (arg2))));
10256   /* Preserve the original type for use by the range case below.
10257      We cannot cast the result to a reference type, so if ARG1 is
10258      a reference type, find its underlying type.  */
10259   struct type *type = value_type (arg1);
10260   while (type->code () == TYPE_CODE_REF)
10261     type = TYPE_TARGET_TYPE (type);
10262   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10263   arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10264   /* We need to special-case the result with a range.
10265      This is done for the benefit of "ptype".  gdb's Ada support
10266      historically used the LHS to set the result type here, so
10267      preserve this behavior.  */
10268   if (type->code () == TYPE_CODE_RANGE)
10269     arg1 = value_cast (type, arg1);
10270   return arg1;
10271 }
10272
10273 value *
10274 ada_unop_atr_operation::evaluate (struct type *expect_type,
10275                                   struct expression *exp,
10276                                   enum noside noside)
10277 {
10278   struct type *type_arg = nullptr;
10279   value *val = nullptr;
10280
10281   if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10282     {
10283       value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10284                                                       EVAL_AVOID_SIDE_EFFECTS);
10285       type_arg = value_type (tem);
10286     }
10287   else
10288     val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10289
10290   return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10291                        val, type_arg, std::get<2> (m_storage));
10292 }
10293
10294 value *
10295 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10296                                                  struct expression *exp,
10297                                                  enum noside noside)
10298 {
10299   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10300     return value_zero (expect_type, not_lval);
10301
10302   const bound_minimal_symbol &b = std::get<0> (m_storage);
10303   value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10304
10305   val = ada_value_cast (expect_type, val);
10306
10307   /* Follow the Ada language semantics that do not allow taking
10308      an address of the result of a cast (view conversion in Ada).  */
10309   if (VALUE_LVAL (val) == lval_memory)
10310     {
10311       if (value_lazy (val))
10312         value_fetch_lazy (val);
10313       VALUE_LVAL (val) = not_lval;
10314     }
10315   return val;
10316 }
10317
10318 value *
10319 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10320                                             struct expression *exp,
10321                                             enum noside noside)
10322 {
10323   value *val = evaluate_var_value (noside,
10324                                    std::get<0> (m_storage).block,
10325                                    std::get<0> (m_storage).symbol);
10326
10327   val = ada_value_cast (expect_type, val);
10328
10329   /* Follow the Ada language semantics that do not allow taking
10330      an address of the result of a cast (view conversion in Ada).  */
10331   if (VALUE_LVAL (val) == lval_memory)
10332     {
10333       if (value_lazy (val))
10334         value_fetch_lazy (val);
10335       VALUE_LVAL (val) = not_lval;
10336     }
10337   return val;
10338 }
10339
10340 value *
10341 ada_var_value_operation::evaluate (struct type *expect_type,
10342                                    struct expression *exp,
10343                                    enum noside noside)
10344 {
10345   symbol *sym = std::get<0> (m_storage).symbol;
10346
10347   if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
10348     /* Only encountered when an unresolved symbol occurs in a
10349        context other than a function call, in which case, it is
10350        invalid.  */
10351     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10352            sym->print_name ());
10353
10354   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10355     {
10356       struct type *type = static_unwrap_type (SYMBOL_TYPE (sym));
10357       /* Check to see if this is a tagged type.  We also need to handle
10358          the case where the type is a reference to a tagged type, but
10359          we have to be careful to exclude pointers to tagged types.
10360          The latter should be shown as usual (as a pointer), whereas
10361          a reference should mostly be transparent to the user.  */
10362       if (ada_is_tagged_type (type, 0)
10363           || (type->code () == TYPE_CODE_REF
10364               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10365         {
10366           /* Tagged types are a little special in the fact that the real
10367              type is dynamic and can only be determined by inspecting the
10368              object's tag.  This means that we need to get the object's
10369              value first (EVAL_NORMAL) and then extract the actual object
10370              type from its tag.
10371
10372              Note that we cannot skip the final step where we extract
10373              the object type from its tag, because the EVAL_NORMAL phase
10374              results in dynamic components being resolved into fixed ones.
10375              This can cause problems when trying to print the type
10376              description of tagged types whose parent has a dynamic size:
10377              We use the type name of the "_parent" component in order
10378              to print the name of the ancestor type in the type description.
10379              If that component had a dynamic size, the resolution into
10380              a fixed type would result in the loss of that type name,
10381              thus preventing us from printing the name of the ancestor
10382              type in the type description.  */
10383           value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10384
10385           if (type->code () != TYPE_CODE_REF)
10386             {
10387               struct type *actual_type;
10388
10389               actual_type = type_from_tag (ada_value_tag (arg1));
10390               if (actual_type == NULL)
10391                 /* If, for some reason, we were unable to determine
10392                    the actual type from the tag, then use the static
10393                    approximation that we just computed as a fallback.
10394                    This can happen if the debugging information is
10395                    incomplete, for instance.  */
10396                 actual_type = type;
10397               return value_zero (actual_type, not_lval);
10398             }
10399           else
10400             {
10401               /* In the case of a ref, ada_coerce_ref takes care
10402                  of determining the actual type.  But the evaluation
10403                  should return a ref as it should be valid to ask
10404                  for its address; so rebuild a ref after coerce.  */
10405               arg1 = ada_coerce_ref (arg1);
10406               return value_ref (arg1, TYPE_CODE_REF);
10407             }
10408         }
10409
10410       /* Records and unions for which GNAT encodings have been
10411          generated need to be statically fixed as well.
10412          Otherwise, non-static fixing produces a type where
10413          all dynamic properties are removed, which prevents "ptype"
10414          from being able to completely describe the type.
10415          For instance, a case statement in a variant record would be
10416          replaced by the relevant components based on the actual
10417          value of the discriminants.  */
10418       if ((type->code () == TYPE_CODE_STRUCT
10419            && dynamic_template_type (type) != NULL)
10420           || (type->code () == TYPE_CODE_UNION
10421               && ada_find_parallel_type (type, "___XVU") != NULL))
10422         return value_zero (to_static_fixed_type (type), not_lval);
10423     }
10424
10425   value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10426   return ada_to_fixed_value (arg1);
10427 }
10428
10429 bool
10430 ada_var_value_operation::resolve (struct expression *exp,
10431                                   bool deprocedure_p,
10432                                   bool parse_completion,
10433                                   innermost_block_tracker *tracker,
10434                                   struct type *context_type)
10435 {
10436   symbol *sym = std::get<0> (m_storage).symbol;
10437   if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
10438     {
10439       block_symbol resolved
10440         = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10441                                 context_type, parse_completion,
10442                                 deprocedure_p, tracker);
10443       std::get<0> (m_storage) = resolved;
10444     }
10445
10446   if (deprocedure_p
10447       && (SYMBOL_TYPE (std::get<0> (m_storage).symbol)->code ()
10448           == TYPE_CODE_FUNC))
10449     return true;
10450
10451   return false;
10452 }
10453
10454 value *
10455 ada_atr_val_operation::evaluate (struct type *expect_type,
10456                                  struct expression *exp,
10457                                  enum noside noside)
10458 {
10459   value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10460   return ada_val_atr (noside, std::get<0> (m_storage), arg);
10461 }
10462
10463 value *
10464 ada_unop_ind_operation::evaluate (struct type *expect_type,
10465                                   struct expression *exp,
10466                                   enum noside noside)
10467 {
10468   value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10469
10470   struct type *type = ada_check_typedef (value_type (arg1));
10471   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10472     {
10473       if (ada_is_array_descriptor_type (type))
10474         /* GDB allows dereferencing GNAT array descriptors.  */
10475         {
10476           struct type *arrType = ada_type_of_array (arg1, 0);
10477
10478           if (arrType == NULL)
10479             error (_("Attempt to dereference null array pointer."));
10480           return value_at_lazy (arrType, 0);
10481         }
10482       else if (type->code () == TYPE_CODE_PTR
10483                || type->code () == TYPE_CODE_REF
10484                /* In C you can dereference an array to get the 1st elt.  */
10485                || type->code () == TYPE_CODE_ARRAY)
10486         {
10487           /* As mentioned in the OP_VAR_VALUE case, tagged types can
10488              only be determined by inspecting the object's tag.
10489              This means that we need to evaluate completely the
10490              expression in order to get its type.  */
10491
10492           if ((type->code () == TYPE_CODE_REF
10493                || type->code () == TYPE_CODE_PTR)
10494               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
10495             {
10496               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
10497                                                         EVAL_NORMAL);
10498               type = value_type (ada_value_ind (arg1));
10499             }
10500           else
10501             {
10502               type = to_static_fixed_type
10503                 (ada_aligned_type
10504                  (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10505             }
10506           ada_ensure_varsize_limit (type);
10507           return value_zero (type, lval_memory);
10508         }
10509       else if (type->code () == TYPE_CODE_INT)
10510         {
10511           /* GDB allows dereferencing an int.  */
10512           if (expect_type == NULL)
10513             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10514                                lval_memory);
10515           else
10516             {
10517               expect_type =
10518                 to_static_fixed_type (ada_aligned_type (expect_type));
10519               return value_zero (expect_type, lval_memory);
10520             }
10521         }
10522       else
10523         error (_("Attempt to take contents of a non-pointer value."));
10524     }
10525   arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
10526   type = ada_check_typedef (value_type (arg1));
10527
10528   if (type->code () == TYPE_CODE_INT)
10529     /* GDB allows dereferencing an int.  If we were given
10530        the expect_type, then use that as the target type.
10531        Otherwise, assume that the target type is an int.  */
10532     {
10533       if (expect_type != NULL)
10534         return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10535                                           arg1));
10536       else
10537         return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10538                               (CORE_ADDR) value_as_address (arg1));
10539     }
10540
10541   struct type *target_type = (to_static_fixed_type
10542                               (ada_aligned_type
10543                                (ada_check_typedef (TYPE_TARGET_TYPE (type)))));
10544   ada_ensure_varsize_limit (target_type);
10545
10546   if (ada_is_array_descriptor_type (type))
10547     /* GDB allows dereferencing GNAT array descriptors.  */
10548     return ada_coerce_to_simple_array (arg1);
10549   else
10550     return ada_value_ind (arg1);
10551 }
10552
10553 value *
10554 ada_structop_operation::evaluate (struct type *expect_type,
10555                                   struct expression *exp,
10556                                   enum noside noside)
10557 {
10558   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10559   const char *str = std::get<1> (m_storage).c_str ();
10560   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10561     {
10562       struct type *type;
10563       struct type *type1 = value_type (arg1);
10564
10565       if (ada_is_tagged_type (type1, 1))
10566         {
10567           type = ada_lookup_struct_elt_type (type1, str, 1, 1);
10568
10569           /* If the field is not found, check if it exists in the
10570              extension of this object's type. This means that we
10571              need to evaluate completely the expression.  */
10572
10573           if (type == NULL)
10574             {
10575               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
10576                                                         EVAL_NORMAL);
10577               arg1 = ada_value_struct_elt (arg1, str, 0);
10578               arg1 = unwrap_value (arg1);
10579               type = value_type (ada_to_fixed_value (arg1));
10580             }
10581         }
10582       else
10583         type = ada_lookup_struct_elt_type (type1, str, 1, 0);
10584
10585       return value_zero (ada_aligned_type (type), lval_memory);
10586     }
10587   else
10588     {
10589       arg1 = ada_value_struct_elt (arg1, str, 0);
10590       arg1 = unwrap_value (arg1);
10591       return ada_to_fixed_value (arg1);
10592     }
10593 }
10594
10595 value *
10596 ada_funcall_operation::evaluate (struct type *expect_type,
10597                                  struct expression *exp,
10598                                  enum noside noside)
10599 {
10600   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
10601   int nargs = args_up.size ();
10602   std::vector<value *> argvec (nargs);
10603   operation_up &callee_op = std::get<0> (m_storage);
10604
10605   ada_var_value_operation *avv
10606     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
10607   if (avv != nullptr
10608       && SYMBOL_DOMAIN (avv->get_symbol ()) == UNDEF_DOMAIN)
10609     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10610            avv->get_symbol ()->print_name ());
10611
10612   value *callee = callee_op->evaluate (nullptr, exp, noside);
10613   for (int i = 0; i < args_up.size (); ++i)
10614     argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
10615
10616   if (ada_is_constrained_packed_array_type
10617       (desc_base_type (value_type (callee))))
10618     callee = ada_coerce_to_simple_array (callee);
10619   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
10620            && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
10621     /* This is a packed array that has already been fixed, and
10622        therefore already coerced to a simple array.  Nothing further
10623        to do.  */
10624     ;
10625   else if (value_type (callee)->code () == TYPE_CODE_REF)
10626     {
10627       /* Make sure we dereference references so that all the code below
10628          feels like it's really handling the referenced value.  Wrapping
10629          types (for alignment) may be there, so make sure we strip them as
10630          well.  */
10631       callee = ada_to_fixed_value (coerce_ref (callee));
10632     }
10633   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
10634            && VALUE_LVAL (callee) == lval_memory)
10635     callee = value_addr (callee);
10636
10637   struct type *type = ada_check_typedef (value_type (callee));
10638
10639   /* Ada allows us to implicitly dereference arrays when subscripting
10640      them.  So, if this is an array typedef (encoding use for array
10641      access types encoded as fat pointers), strip it now.  */
10642   if (type->code () == TYPE_CODE_TYPEDEF)
10643     type = ada_typedef_target_type (type);
10644
10645   if (type->code () == TYPE_CODE_PTR)
10646     {
10647       switch (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ())
10648         {
10649         case TYPE_CODE_FUNC:
10650           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10651           break;
10652         case TYPE_CODE_ARRAY:
10653           break;
10654         case TYPE_CODE_STRUCT:
10655           if (noside != EVAL_AVOID_SIDE_EFFECTS)
10656             callee = ada_value_ind (callee);
10657           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10658           break;
10659         default:
10660           error (_("cannot subscript or call something of type `%s'"),
10661                  ada_type_name (value_type (callee)));
10662           break;
10663         }
10664     }
10665
10666   switch (type->code ())
10667     {
10668     case TYPE_CODE_FUNC:
10669       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10670         {
10671           if (TYPE_TARGET_TYPE (type) == NULL)
10672             error_call_unknown_return_type (NULL);
10673           return allocate_value (TYPE_TARGET_TYPE (type));
10674         }
10675       return call_function_by_hand (callee, NULL, argvec);
10676     case TYPE_CODE_INTERNAL_FUNCTION:
10677       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10678         /* We don't know anything about what the internal
10679            function might return, but we have to return
10680            something.  */
10681         return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10682                            not_lval);
10683       else
10684         return call_internal_function (exp->gdbarch, exp->language_defn,
10685                                        callee, nargs,
10686                                        argvec.data ());
10687
10688     case TYPE_CODE_STRUCT:
10689       {
10690         int arity;
10691
10692         arity = ada_array_arity (type);
10693         type = ada_array_element_type (type, nargs);
10694         if (type == NULL)
10695           error (_("cannot subscript or call a record"));
10696         if (arity != nargs)
10697           error (_("wrong number of subscripts; expecting %d"), arity);
10698         if (noside == EVAL_AVOID_SIDE_EFFECTS)
10699           return value_zero (ada_aligned_type (type), lval_memory);
10700         return
10701           unwrap_value (ada_value_subscript
10702                         (callee, nargs, argvec.data ()));
10703       }
10704     case TYPE_CODE_ARRAY:
10705       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10706         {
10707           type = ada_array_element_type (type, nargs);
10708           if (type == NULL)
10709             error (_("element type of array unknown"));
10710           else
10711             return value_zero (ada_aligned_type (type), lval_memory);
10712         }
10713       return
10714         unwrap_value (ada_value_subscript
10715                       (ada_coerce_to_simple_array (callee),
10716                        nargs, argvec.data ()));
10717     case TYPE_CODE_PTR:     /* Pointer to array */
10718       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10719         {
10720           type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10721           type = ada_array_element_type (type, nargs);
10722           if (type == NULL)
10723             error (_("element type of array unknown"));
10724           else
10725             return value_zero (ada_aligned_type (type), lval_memory);
10726         }
10727       return
10728         unwrap_value (ada_value_ptr_subscript (callee, nargs,
10729                                                argvec.data ()));
10730
10731     default:
10732       error (_("Attempt to index or call something other than an "
10733                "array or function"));
10734     }
10735 }
10736
10737 bool
10738 ada_funcall_operation::resolve (struct expression *exp,
10739                                 bool deprocedure_p,
10740                                 bool parse_completion,
10741                                 innermost_block_tracker *tracker,
10742                                 struct type *context_type)
10743 {
10744   operation_up &callee_op = std::get<0> (m_storage);
10745
10746   ada_var_value_operation *avv
10747     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
10748   if (avv == nullptr)
10749     return false;
10750
10751   symbol *sym = avv->get_symbol ();
10752   if (SYMBOL_DOMAIN (sym) != UNDEF_DOMAIN)
10753     return false;
10754
10755   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
10756   int nargs = args_up.size ();
10757   std::vector<value *> argvec (nargs);
10758
10759   for (int i = 0; i < args_up.size (); ++i)
10760     argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
10761
10762   const block *block = avv->get_block ();
10763   block_symbol resolved
10764     = ada_resolve_funcall (sym, block,
10765                            context_type, parse_completion,
10766                            nargs, argvec.data (),
10767                            tracker);
10768
10769   std::get<0> (m_storage)
10770     = make_operation<ada_var_value_operation> (resolved);
10771   return false;
10772 }
10773
10774 bool
10775 ada_ternop_slice_operation::resolve (struct expression *exp,
10776                                      bool deprocedure_p,
10777                                      bool parse_completion,
10778                                      innermost_block_tracker *tracker,
10779                                      struct type *context_type)
10780 {
10781   /* Historically this check was done during resolution, so we
10782      continue that here.  */
10783   value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
10784                                                 EVAL_AVOID_SIDE_EFFECTS);
10785   if (ada_is_any_packed_array_type (value_type (v)))
10786     error (_("cannot slice a packed array"));
10787   return false;
10788 }
10789
10790 }
10791
10792 \f
10793
10794 /* Return non-zero iff TYPE represents a System.Address type.  */
10795
10796 int
10797 ada_is_system_address_type (struct type *type)
10798 {
10799   return (type->name () && strcmp (type->name (), "system__address") == 0);
10800 }
10801
10802 \f
10803
10804                                 /* Range types */
10805
10806 /* Scan STR beginning at position K for a discriminant name, and
10807    return the value of that discriminant field of DVAL in *PX.  If
10808    PNEW_K is not null, put the position of the character beyond the
10809    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
10810    not alter *PX and *PNEW_K if unsuccessful.  */
10811
10812 static int
10813 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
10814                     int *pnew_k)
10815 {
10816   static std::string storage;
10817   const char *pstart, *pend, *bound;
10818   struct value *bound_val;
10819
10820   if (dval == NULL || str == NULL || str[k] == '\0')
10821     return 0;
10822
10823   pstart = str + k;
10824   pend = strstr (pstart, "__");
10825   if (pend == NULL)
10826     {
10827       bound = pstart;
10828       k += strlen (bound);
10829     }
10830   else
10831     {
10832       int len = pend - pstart;
10833
10834       /* Strip __ and beyond.  */
10835       storage = std::string (pstart, len);
10836       bound = storage.c_str ();
10837       k = pend - str;
10838     }
10839
10840   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
10841   if (bound_val == NULL)
10842     return 0;
10843
10844   *px = value_as_long (bound_val);
10845   if (pnew_k != NULL)
10846     *pnew_k = k;
10847   return 1;
10848 }
10849
10850 /* Value of variable named NAME.  Only exact matches are considered.
10851    If no such variable found, then if ERR_MSG is null, returns 0, and
10852    otherwise causes an error with message ERR_MSG.  */
10853
10854 static struct value *
10855 get_var_value (const char *name, const char *err_msg)
10856 {
10857   std::string quoted_name = add_angle_brackets (name);
10858
10859   lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
10860
10861   std::vector<struct block_symbol> syms
10862     = ada_lookup_symbol_list_worker (lookup_name,
10863                                      get_selected_block (0),
10864                                      VAR_DOMAIN, 1);
10865
10866   if (syms.size () != 1)
10867     {
10868       if (err_msg == NULL)
10869         return 0;
10870       else
10871         error (("%s"), err_msg);
10872     }
10873
10874   return value_of_variable (syms[0].symbol, syms[0].block);
10875 }
10876
10877 /* Value of integer variable named NAME in the current environment.
10878    If no such variable is found, returns false.  Otherwise, sets VALUE
10879    to the variable's value and returns true.  */
10880
10881 bool
10882 get_int_var_value (const char *name, LONGEST &value)
10883 {
10884   struct value *var_val = get_var_value (name, 0);
10885
10886   if (var_val == 0)
10887     return false;
10888
10889   value = value_as_long (var_val);
10890   return true;
10891 }
10892
10893
10894 /* Return a range type whose base type is that of the range type named
10895    NAME in the current environment, and whose bounds are calculated
10896    from NAME according to the GNAT range encoding conventions.
10897    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
10898    corresponding range type from debug information; fall back to using it
10899    if symbol lookup fails.  If a new type must be created, allocate it
10900    like ORIG_TYPE was.  The bounds information, in general, is encoded
10901    in NAME, the base type given in the named range type.  */
10902
10903 static struct type *
10904 to_fixed_range_type (struct type *raw_type, struct value *dval)
10905 {
10906   const char *name;
10907   struct type *base_type;
10908   const char *subtype_info;
10909
10910   gdb_assert (raw_type != NULL);
10911   gdb_assert (raw_type->name () != NULL);
10912
10913   if (raw_type->code () == TYPE_CODE_RANGE)
10914     base_type = TYPE_TARGET_TYPE (raw_type);
10915   else
10916     base_type = raw_type;
10917
10918   name = raw_type->name ();
10919   subtype_info = strstr (name, "___XD");
10920   if (subtype_info == NULL)
10921     {
10922       LONGEST L = ada_discrete_type_low_bound (raw_type);
10923       LONGEST U = ada_discrete_type_high_bound (raw_type);
10924
10925       if (L < INT_MIN || U > INT_MAX)
10926         return raw_type;
10927       else
10928         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
10929                                          L, U);
10930     }
10931   else
10932     {
10933       int prefix_len = subtype_info - name;
10934       LONGEST L, U;
10935       struct type *type;
10936       const char *bounds_str;
10937       int n;
10938
10939       subtype_info += 5;
10940       bounds_str = strchr (subtype_info, '_');
10941       n = 1;
10942
10943       if (*subtype_info == 'L')
10944         {
10945           if (!ada_scan_number (bounds_str, n, &L, &n)
10946               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
10947             return raw_type;
10948           if (bounds_str[n] == '_')
10949             n += 2;
10950           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
10951             n += 1;
10952           subtype_info += 1;
10953         }
10954       else
10955         {
10956           std::string name_buf = std::string (name, prefix_len) + "___L";
10957           if (!get_int_var_value (name_buf.c_str (), L))
10958             {
10959               lim_warning (_("Unknown lower bound, using 1."));
10960               L = 1;
10961             }
10962         }
10963
10964       if (*subtype_info == 'U')
10965         {
10966           if (!ada_scan_number (bounds_str, n, &U, &n)
10967               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
10968             return raw_type;
10969         }
10970       else
10971         {
10972           std::string name_buf = std::string (name, prefix_len) + "___U";
10973           if (!get_int_var_value (name_buf.c_str (), U))
10974             {
10975               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
10976               U = L;
10977             }
10978         }
10979
10980       type = create_static_range_type (alloc_type_copy (raw_type),
10981                                        base_type, L, U);
10982       /* create_static_range_type alters the resulting type's length
10983          to match the size of the base_type, which is not what we want.
10984          Set it back to the original range type's length.  */
10985       TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
10986       type->set_name (name);
10987       return type;
10988     }
10989 }
10990
10991 /* True iff NAME is the name of a range type.  */
10992
10993 int
10994 ada_is_range_type_name (const char *name)
10995 {
10996   return (name != NULL && strstr (name, "___XD"));
10997 }
10998 \f
10999
11000                                 /* Modular types */
11001
11002 /* True iff TYPE is an Ada modular type.  */
11003
11004 int
11005 ada_is_modular_type (struct type *type)
11006 {
11007   struct type *subranged_type = get_base_type (type);
11008
11009   return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11010           && subranged_type->code () == TYPE_CODE_INT
11011           && subranged_type->is_unsigned ());
11012 }
11013
11014 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
11015
11016 ULONGEST
11017 ada_modulus (struct type *type)
11018 {
11019   const dynamic_prop &high = type->bounds ()->high;
11020
11021   if (high.kind () == PROP_CONST)
11022     return (ULONGEST) high.const_val () + 1;
11023
11024   /* If TYPE is unresolved, the high bound might be a location list.  Return
11025      0, for lack of a better value to return.  */
11026   return 0;
11027 }
11028 \f
11029
11030 /* Ada exception catchpoint support:
11031    ---------------------------------
11032
11033    We support 3 kinds of exception catchpoints:
11034      . catchpoints on Ada exceptions
11035      . catchpoints on unhandled Ada exceptions
11036      . catchpoints on failed assertions
11037
11038    Exceptions raised during failed assertions, or unhandled exceptions
11039    could perfectly be caught with the general catchpoint on Ada exceptions.
11040    However, we can easily differentiate these two special cases, and having
11041    the option to distinguish these two cases from the rest can be useful
11042    to zero-in on certain situations.
11043
11044    Exception catchpoints are a specialized form of breakpoint,
11045    since they rely on inserting breakpoints inside known routines
11046    of the GNAT runtime.  The implementation therefore uses a standard
11047    breakpoint structure of the BP_BREAKPOINT type, but with its own set
11048    of breakpoint_ops.
11049
11050    Support in the runtime for exception catchpoints have been changed
11051    a few times already, and these changes affect the implementation
11052    of these catchpoints.  In order to be able to support several
11053    variants of the runtime, we use a sniffer that will determine
11054    the runtime variant used by the program being debugged.  */
11055
11056 /* Ada's standard exceptions.
11057
11058    The Ada 83 standard also defined Numeric_Error.  But there so many
11059    situations where it was unclear from the Ada 83 Reference Manual
11060    (RM) whether Constraint_Error or Numeric_Error should be raised,
11061    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11062    Interpretation saying that anytime the RM says that Numeric_Error
11063    should be raised, the implementation may raise Constraint_Error.
11064    Ada 95 went one step further and pretty much removed Numeric_Error
11065    from the list of standard exceptions (it made it a renaming of
11066    Constraint_Error, to help preserve compatibility when compiling
11067    an Ada83 compiler). As such, we do not include Numeric_Error from
11068    this list of standard exceptions.  */
11069
11070 static const char * const standard_exc[] = {
11071   "constraint_error",
11072   "program_error",
11073   "storage_error",
11074   "tasking_error"
11075 };
11076
11077 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11078
11079 /* A structure that describes how to support exception catchpoints
11080    for a given executable.  */
11081
11082 struct exception_support_info
11083 {
11084    /* The name of the symbol to break on in order to insert
11085       a catchpoint on exceptions.  */
11086    const char *catch_exception_sym;
11087
11088    /* The name of the symbol to break on in order to insert
11089       a catchpoint on unhandled exceptions.  */
11090    const char *catch_exception_unhandled_sym;
11091
11092    /* The name of the symbol to break on in order to insert
11093       a catchpoint on failed assertions.  */
11094    const char *catch_assert_sym;
11095
11096    /* The name of the symbol to break on in order to insert
11097       a catchpoint on exception handling.  */
11098    const char *catch_handlers_sym;
11099
11100    /* Assuming that the inferior just triggered an unhandled exception
11101       catchpoint, this function is responsible for returning the address
11102       in inferior memory where the name of that exception is stored.
11103       Return zero if the address could not be computed.  */
11104    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11105 };
11106
11107 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11108 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11109
11110 /* The following exception support info structure describes how to
11111    implement exception catchpoints with the latest version of the
11112    Ada runtime (as of 2019-08-??).  */
11113
11114 static const struct exception_support_info default_exception_support_info =
11115 {
11116   "__gnat_debug_raise_exception", /* catch_exception_sym */
11117   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11118   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11119   "__gnat_begin_handler_v1", /* catch_handlers_sym */
11120   ada_unhandled_exception_name_addr
11121 };
11122
11123 /* The following exception support info structure describes how to
11124    implement exception catchpoints with an earlier version of the
11125    Ada runtime (as of 2007-03-06) using v0 of the EH ABI.  */
11126
11127 static const struct exception_support_info exception_support_info_v0 =
11128 {
11129   "__gnat_debug_raise_exception", /* catch_exception_sym */
11130   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11131   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11132   "__gnat_begin_handler", /* catch_handlers_sym */
11133   ada_unhandled_exception_name_addr
11134 };
11135
11136 /* The following exception support info structure describes how to
11137    implement exception catchpoints with a slightly older version
11138    of the Ada runtime.  */
11139
11140 static const struct exception_support_info exception_support_info_fallback =
11141 {
11142   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11143   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11144   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
11145   "__gnat_begin_handler", /* catch_handlers_sym */
11146   ada_unhandled_exception_name_addr_from_raise
11147 };
11148
11149 /* Return nonzero if we can detect the exception support routines
11150    described in EINFO.
11151
11152    This function errors out if an abnormal situation is detected
11153    (for instance, if we find the exception support routines, but
11154    that support is found to be incomplete).  */
11155
11156 static int
11157 ada_has_this_exception_support (const struct exception_support_info *einfo)
11158 {
11159   struct symbol *sym;
11160
11161   /* The symbol we're looking up is provided by a unit in the GNAT runtime
11162      that should be compiled with debugging information.  As a result, we
11163      expect to find that symbol in the symtabs.  */
11164
11165   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11166   if (sym == NULL)
11167     {
11168       /* Perhaps we did not find our symbol because the Ada runtime was
11169          compiled without debugging info, or simply stripped of it.
11170          It happens on some GNU/Linux distributions for instance, where
11171          users have to install a separate debug package in order to get
11172          the runtime's debugging info.  In that situation, let the user
11173          know why we cannot insert an Ada exception catchpoint.
11174
11175          Note: Just for the purpose of inserting our Ada exception
11176          catchpoint, we could rely purely on the associated minimal symbol.
11177          But we would be operating in degraded mode anyway, since we are
11178          still lacking the debugging info needed later on to extract
11179          the name of the exception being raised (this name is printed in
11180          the catchpoint message, and is also used when trying to catch
11181          a specific exception).  We do not handle this case for now.  */
11182       struct bound_minimal_symbol msym
11183         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11184
11185       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11186         error (_("Your Ada runtime appears to be missing some debugging "
11187                  "information.\nCannot insert Ada exception catchpoint "
11188                  "in this configuration."));
11189
11190       return 0;
11191     }
11192
11193   /* Make sure that the symbol we found corresponds to a function.  */
11194
11195   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11196     {
11197       error (_("Symbol \"%s\" is not a function (class = %d)"),
11198              sym->linkage_name (), SYMBOL_CLASS (sym));
11199       return 0;
11200     }
11201
11202   sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11203   if (sym == NULL)
11204     {
11205       struct bound_minimal_symbol msym
11206         = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11207
11208       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11209         error (_("Your Ada runtime appears to be missing some debugging "
11210                  "information.\nCannot insert Ada exception catchpoint "
11211                  "in this configuration."));
11212
11213       return 0;
11214     }
11215
11216   /* Make sure that the symbol we found corresponds to a function.  */
11217
11218   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11219     {
11220       error (_("Symbol \"%s\" is not a function (class = %d)"),
11221              sym->linkage_name (), SYMBOL_CLASS (sym));
11222       return 0;
11223     }
11224
11225   return 1;
11226 }
11227
11228 /* Inspect the Ada runtime and determine which exception info structure
11229    should be used to provide support for exception catchpoints.
11230
11231    This function will always set the per-inferior exception_info,
11232    or raise an error.  */
11233
11234 static void
11235 ada_exception_support_info_sniffer (void)
11236 {
11237   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11238
11239   /* If the exception info is already known, then no need to recompute it.  */
11240   if (data->exception_info != NULL)
11241     return;
11242
11243   /* Check the latest (default) exception support info.  */
11244   if (ada_has_this_exception_support (&default_exception_support_info))
11245     {
11246       data->exception_info = &default_exception_support_info;
11247       return;
11248     }
11249
11250   /* Try the v0 exception suport info.  */
11251   if (ada_has_this_exception_support (&exception_support_info_v0))
11252     {
11253       data->exception_info = &exception_support_info_v0;
11254       return;
11255     }
11256
11257   /* Try our fallback exception suport info.  */
11258   if (ada_has_this_exception_support (&exception_support_info_fallback))
11259     {
11260       data->exception_info = &exception_support_info_fallback;
11261       return;
11262     }
11263
11264   /* Sometimes, it is normal for us to not be able to find the routine
11265      we are looking for.  This happens when the program is linked with
11266      the shared version of the GNAT runtime, and the program has not been
11267      started yet.  Inform the user of these two possible causes if
11268      applicable.  */
11269
11270   if (ada_update_initial_language (language_unknown) != language_ada)
11271     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
11272
11273   /* If the symbol does not exist, then check that the program is
11274      already started, to make sure that shared libraries have been
11275      loaded.  If it is not started, this may mean that the symbol is
11276      in a shared library.  */
11277
11278   if (inferior_ptid.pid () == 0)
11279     error (_("Unable to insert catchpoint. Try to start the program first."));
11280
11281   /* At this point, we know that we are debugging an Ada program and
11282      that the inferior has been started, but we still are not able to
11283      find the run-time symbols.  That can mean that we are in
11284      configurable run time mode, or that a-except as been optimized
11285      out by the linker...  In any case, at this point it is not worth
11286      supporting this feature.  */
11287
11288   error (_("Cannot insert Ada exception catchpoints in this configuration."));
11289 }
11290
11291 /* True iff FRAME is very likely to be that of a function that is
11292    part of the runtime system.  This is all very heuristic, but is
11293    intended to be used as advice as to what frames are uninteresting
11294    to most users.  */
11295
11296 static int
11297 is_known_support_routine (struct frame_info *frame)
11298 {
11299   enum language func_lang;
11300   int i;
11301   const char *fullname;
11302
11303   /* If this code does not have any debugging information (no symtab),
11304      This cannot be any user code.  */
11305
11306   symtab_and_line sal = find_frame_sal (frame);
11307   if (sal.symtab == NULL)
11308     return 1;
11309
11310   /* If there is a symtab, but the associated source file cannot be
11311      located, then assume this is not user code:  Selecting a frame
11312      for which we cannot display the code would not be very helpful
11313      for the user.  This should also take care of case such as VxWorks
11314      where the kernel has some debugging info provided for a few units.  */
11315
11316   fullname = symtab_to_fullname (sal.symtab);
11317   if (access (fullname, R_OK) != 0)
11318     return 1;
11319
11320   /* Check the unit filename against the Ada runtime file naming.
11321      We also check the name of the objfile against the name of some
11322      known system libraries that sometimes come with debugging info
11323      too.  */
11324
11325   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11326     {
11327       re_comp (known_runtime_file_name_patterns[i]);
11328       if (re_exec (lbasename (sal.symtab->filename)))
11329         return 1;
11330       if (SYMTAB_OBJFILE (sal.symtab) != NULL
11331           && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
11332         return 1;
11333     }
11334
11335   /* Check whether the function is a GNAT-generated entity.  */
11336
11337   gdb::unique_xmalloc_ptr<char> func_name
11338     = find_frame_funname (frame, &func_lang, NULL);
11339   if (func_name == NULL)
11340     return 1;
11341
11342   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11343     {
11344       re_comp (known_auxiliary_function_name_patterns[i]);
11345       if (re_exec (func_name.get ()))
11346         return 1;
11347     }
11348
11349   return 0;
11350 }
11351
11352 /* Find the first frame that contains debugging information and that is not
11353    part of the Ada run-time, starting from FI and moving upward.  */
11354
11355 void
11356 ada_find_printable_frame (struct frame_info *fi)
11357 {
11358   for (; fi != NULL; fi = get_prev_frame (fi))
11359     {
11360       if (!is_known_support_routine (fi))
11361         {
11362           select_frame (fi);
11363           break;
11364         }
11365     }
11366
11367 }
11368
11369 /* Assuming that the inferior just triggered an unhandled exception
11370    catchpoint, return the address in inferior memory where the name
11371    of the exception is stored.
11372    
11373    Return zero if the address could not be computed.  */
11374
11375 static CORE_ADDR
11376 ada_unhandled_exception_name_addr (void)
11377 {
11378   return parse_and_eval_address ("e.full_name");
11379 }
11380
11381 /* Same as ada_unhandled_exception_name_addr, except that this function
11382    should be used when the inferior uses an older version of the runtime,
11383    where the exception name needs to be extracted from a specific frame
11384    several frames up in the callstack.  */
11385
11386 static CORE_ADDR
11387 ada_unhandled_exception_name_addr_from_raise (void)
11388 {
11389   int frame_level;
11390   struct frame_info *fi;
11391   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11392
11393   /* To determine the name of this exception, we need to select
11394      the frame corresponding to RAISE_SYM_NAME.  This frame is
11395      at least 3 levels up, so we simply skip the first 3 frames
11396      without checking the name of their associated function.  */
11397   fi = get_current_frame ();
11398   for (frame_level = 0; frame_level < 3; frame_level += 1)
11399     if (fi != NULL)
11400       fi = get_prev_frame (fi); 
11401
11402   while (fi != NULL)
11403     {
11404       enum language func_lang;
11405
11406       gdb::unique_xmalloc_ptr<char> func_name
11407         = find_frame_funname (fi, &func_lang, NULL);
11408       if (func_name != NULL)
11409         {
11410           if (strcmp (func_name.get (),
11411                       data->exception_info->catch_exception_sym) == 0)
11412             break; /* We found the frame we were looking for...  */
11413         }
11414       fi = get_prev_frame (fi);
11415     }
11416
11417   if (fi == NULL)
11418     return 0;
11419
11420   select_frame (fi);
11421   return parse_and_eval_address ("id.full_name");
11422 }
11423
11424 /* Assuming the inferior just triggered an Ada exception catchpoint
11425    (of any type), return the address in inferior memory where the name
11426    of the exception is stored, if applicable.
11427
11428    Assumes the selected frame is the current frame.
11429
11430    Return zero if the address could not be computed, or if not relevant.  */
11431
11432 static CORE_ADDR
11433 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
11434                            struct breakpoint *b)
11435 {
11436   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11437
11438   switch (ex)
11439     {
11440       case ada_catch_exception:
11441         return (parse_and_eval_address ("e.full_name"));
11442         break;
11443
11444       case ada_catch_exception_unhandled:
11445         return data->exception_info->unhandled_exception_name_addr ();
11446         break;
11447
11448       case ada_catch_handlers:
11449         return 0;  /* The runtimes does not provide access to the exception
11450                       name.  */
11451         break;
11452
11453       case ada_catch_assert:
11454         return 0;  /* Exception name is not relevant in this case.  */
11455         break;
11456
11457       default:
11458         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11459         break;
11460     }
11461
11462   return 0; /* Should never be reached.  */
11463 }
11464
11465 /* Assuming the inferior is stopped at an exception catchpoint,
11466    return the message which was associated to the exception, if
11467    available.  Return NULL if the message could not be retrieved.
11468
11469    Note: The exception message can be associated to an exception
11470    either through the use of the Raise_Exception function, or
11471    more simply (Ada 2005 and later), via:
11472
11473        raise Exception_Name with "exception message";
11474
11475    */
11476
11477 static gdb::unique_xmalloc_ptr<char>
11478 ada_exception_message_1 (void)
11479 {
11480   struct value *e_msg_val;
11481   int e_msg_len;
11482
11483   /* For runtimes that support this feature, the exception message
11484      is passed as an unbounded string argument called "message".  */
11485   e_msg_val = parse_and_eval ("message");
11486   if (e_msg_val == NULL)
11487     return NULL; /* Exception message not supported.  */
11488
11489   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
11490   gdb_assert (e_msg_val != NULL);
11491   e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
11492
11493   /* If the message string is empty, then treat it as if there was
11494      no exception message.  */
11495   if (e_msg_len <= 0)
11496     return NULL;
11497
11498   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
11499   read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
11500                e_msg_len);
11501   e_msg.get ()[e_msg_len] = '\0';
11502
11503   return e_msg;
11504 }
11505
11506 /* Same as ada_exception_message_1, except that all exceptions are
11507    contained here (returning NULL instead).  */
11508
11509 static gdb::unique_xmalloc_ptr<char>
11510 ada_exception_message (void)
11511 {
11512   gdb::unique_xmalloc_ptr<char> e_msg;
11513
11514   try
11515     {
11516       e_msg = ada_exception_message_1 ();
11517     }
11518   catch (const gdb_exception_error &e)
11519     {
11520       e_msg.reset (nullptr);
11521     }
11522
11523   return e_msg;
11524 }
11525
11526 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11527    any error that ada_exception_name_addr_1 might cause to be thrown.
11528    When an error is intercepted, a warning with the error message is printed,
11529    and zero is returned.  */
11530
11531 static CORE_ADDR
11532 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
11533                          struct breakpoint *b)
11534 {
11535   CORE_ADDR result = 0;
11536
11537   try
11538     {
11539       result = ada_exception_name_addr_1 (ex, b);
11540     }
11541
11542   catch (const gdb_exception_error &e)
11543     {
11544       warning (_("failed to get exception name: %s"), e.what ());
11545       return 0;
11546     }
11547
11548   return result;
11549 }
11550
11551 static std::string ada_exception_catchpoint_cond_string
11552   (const char *excep_string,
11553    enum ada_exception_catchpoint_kind ex);
11554
11555 /* Ada catchpoints.
11556
11557    In the case of catchpoints on Ada exceptions, the catchpoint will
11558    stop the target on every exception the program throws.  When a user
11559    specifies the name of a specific exception, we translate this
11560    request into a condition expression (in text form), and then parse
11561    it into an expression stored in each of the catchpoint's locations.
11562    We then use this condition to check whether the exception that was
11563    raised is the one the user is interested in.  If not, then the
11564    target is resumed again.  We store the name of the requested
11565    exception, in order to be able to re-set the condition expression
11566    when symbols change.  */
11567
11568 /* An instance of this type is used to represent an Ada catchpoint
11569    breakpoint location.  */
11570
11571 class ada_catchpoint_location : public bp_location
11572 {
11573 public:
11574   ada_catchpoint_location (breakpoint *owner)
11575     : bp_location (owner, bp_loc_software_breakpoint)
11576   {}
11577
11578   /* The condition that checks whether the exception that was raised
11579      is the specific exception the user specified on catchpoint
11580      creation.  */
11581   expression_up excep_cond_expr;
11582 };
11583
11584 /* An instance of this type is used to represent an Ada catchpoint.  */
11585
11586 struct ada_catchpoint : public breakpoint
11587 {
11588   explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind)
11589     : m_kind (kind)
11590   {
11591   }
11592
11593   /* The name of the specific exception the user specified.  */
11594   std::string excep_string;
11595
11596   /* What kind of catchpoint this is.  */
11597   enum ada_exception_catchpoint_kind m_kind;
11598 };
11599
11600 /* Parse the exception condition string in the context of each of the
11601    catchpoint's locations, and store them for later evaluation.  */
11602
11603 static void
11604 create_excep_cond_exprs (struct ada_catchpoint *c,
11605                          enum ada_exception_catchpoint_kind ex)
11606 {
11607   /* Nothing to do if there's no specific exception to catch.  */
11608   if (c->excep_string.empty ())
11609     return;
11610
11611   /* Same if there are no locations... */
11612   if (c->loc == NULL)
11613     return;
11614
11615   /* Compute the condition expression in text form, from the specific
11616      expection we want to catch.  */
11617   std::string cond_string
11618     = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
11619
11620   /* Iterate over all the catchpoint's locations, and parse an
11621      expression for each.  */
11622   for (bp_location *bl : c->locations ())
11623     {
11624       struct ada_catchpoint_location *ada_loc
11625         = (struct ada_catchpoint_location *) bl;
11626       expression_up exp;
11627
11628       if (!bl->shlib_disabled)
11629         {
11630           const char *s;
11631
11632           s = cond_string.c_str ();
11633           try
11634             {
11635               exp = parse_exp_1 (&s, bl->address,
11636                                  block_for_pc (bl->address),
11637                                  0);
11638             }
11639           catch (const gdb_exception_error &e)
11640             {
11641               warning (_("failed to reevaluate internal exception condition "
11642                          "for catchpoint %d: %s"),
11643                        c->number, e.what ());
11644             }
11645         }
11646
11647       ada_loc->excep_cond_expr = std::move (exp);
11648     }
11649 }
11650
11651 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11652    structure for all exception catchpoint kinds.  */
11653
11654 static struct bp_location *
11655 allocate_location_exception (struct breakpoint *self)
11656 {
11657   return new ada_catchpoint_location (self);
11658 }
11659
11660 /* Implement the RE_SET method in the breakpoint_ops structure for all
11661    exception catchpoint kinds.  */
11662
11663 static void
11664 re_set_exception (struct breakpoint *b)
11665 {
11666   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11667
11668   /* Call the base class's method.  This updates the catchpoint's
11669      locations.  */
11670   bkpt_breakpoint_ops.re_set (b);
11671
11672   /* Reparse the exception conditional expressions.  One for each
11673      location.  */
11674   create_excep_cond_exprs (c, c->m_kind);
11675 }
11676
11677 /* Returns true if we should stop for this breakpoint hit.  If the
11678    user specified a specific exception, we only want to cause a stop
11679    if the program thrown that exception.  */
11680
11681 static int
11682 should_stop_exception (const struct bp_location *bl)
11683 {
11684   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11685   const struct ada_catchpoint_location *ada_loc
11686     = (const struct ada_catchpoint_location *) bl;
11687   int stop;
11688
11689   struct internalvar *var = lookup_internalvar ("_ada_exception");
11690   if (c->m_kind == ada_catch_assert)
11691     clear_internalvar (var);
11692   else
11693     {
11694       try
11695         {
11696           const char *expr;
11697
11698           if (c->m_kind == ada_catch_handlers)
11699             expr = ("GNAT_GCC_exception_Access(gcc_exception)"
11700                     ".all.occurrence.id");
11701           else
11702             expr = "e";
11703
11704           struct value *exc = parse_and_eval (expr);
11705           set_internalvar (var, exc);
11706         }
11707       catch (const gdb_exception_error &ex)
11708         {
11709           clear_internalvar (var);
11710         }
11711     }
11712
11713   /* With no specific exception, should always stop.  */
11714   if (c->excep_string.empty ())
11715     return 1;
11716
11717   if (ada_loc->excep_cond_expr == NULL)
11718     {
11719       /* We will have a NULL expression if back when we were creating
11720          the expressions, this location's had failed to parse.  */
11721       return 1;
11722     }
11723
11724   stop = 1;
11725   try
11726     {
11727       struct value *mark;
11728
11729       mark = value_mark ();
11730       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
11731       value_free_to_mark (mark);
11732     }
11733   catch (const gdb_exception &ex)
11734     {
11735       exception_fprintf (gdb_stderr, ex,
11736                          _("Error in testing exception condition:\n"));
11737     }
11738
11739   return stop;
11740 }
11741
11742 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
11743    for all exception catchpoint kinds.  */
11744
11745 static void
11746 check_status_exception (bpstat bs)
11747 {
11748   bs->stop = should_stop_exception (bs->bp_location_at.get ());
11749 }
11750
11751 /* Implement the PRINT_IT method in the breakpoint_ops structure
11752    for all exception catchpoint kinds.  */
11753
11754 static enum print_stop_action
11755 print_it_exception (bpstat bs)
11756 {
11757   struct ui_out *uiout = current_uiout;
11758   struct breakpoint *b = bs->breakpoint_at;
11759
11760   annotate_catchpoint (b->number);
11761
11762   if (uiout->is_mi_like_p ())
11763     {
11764       uiout->field_string ("reason",
11765                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11766       uiout->field_string ("disp", bpdisp_text (b->disposition));
11767     }
11768
11769   uiout->text (b->disposition == disp_del
11770                ? "\nTemporary catchpoint " : "\nCatchpoint ");
11771   uiout->field_signed ("bkptno", b->number);
11772   uiout->text (", ");
11773
11774   /* ada_exception_name_addr relies on the selected frame being the
11775      current frame.  Need to do this here because this function may be
11776      called more than once when printing a stop, and below, we'll
11777      select the first frame past the Ada run-time (see
11778      ada_find_printable_frame).  */
11779   select_frame (get_current_frame ());
11780
11781   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11782   switch (c->m_kind)
11783     {
11784       case ada_catch_exception:
11785       case ada_catch_exception_unhandled:
11786       case ada_catch_handlers:
11787         {
11788           const CORE_ADDR addr = ada_exception_name_addr (c->m_kind, b);
11789           char exception_name[256];
11790
11791           if (addr != 0)
11792             {
11793               read_memory (addr, (gdb_byte *) exception_name,
11794                            sizeof (exception_name) - 1);
11795               exception_name [sizeof (exception_name) - 1] = '\0';
11796             }
11797           else
11798             {
11799               /* For some reason, we were unable to read the exception
11800                  name.  This could happen if the Runtime was compiled
11801                  without debugging info, for instance.  In that case,
11802                  just replace the exception name by the generic string
11803                  "exception" - it will read as "an exception" in the
11804                  notification we are about to print.  */
11805               memcpy (exception_name, "exception", sizeof ("exception"));
11806             }
11807           /* In the case of unhandled exception breakpoints, we print
11808              the exception name as "unhandled EXCEPTION_NAME", to make
11809              it clearer to the user which kind of catchpoint just got
11810              hit.  We used ui_out_text to make sure that this extra
11811              info does not pollute the exception name in the MI case.  */
11812           if (c->m_kind == ada_catch_exception_unhandled)
11813             uiout->text ("unhandled ");
11814           uiout->field_string ("exception-name", exception_name);
11815         }
11816         break;
11817       case ada_catch_assert:
11818         /* In this case, the name of the exception is not really
11819            important.  Just print "failed assertion" to make it clearer
11820            that his program just hit an assertion-failure catchpoint.
11821            We used ui_out_text because this info does not belong in
11822            the MI output.  */
11823         uiout->text ("failed assertion");
11824         break;
11825     }
11826
11827   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
11828   if (exception_message != NULL)
11829     {
11830       uiout->text (" (");
11831       uiout->field_string ("exception-message", exception_message.get ());
11832       uiout->text (")");
11833     }
11834
11835   uiout->text (" at ");
11836   ada_find_printable_frame (get_current_frame ());
11837
11838   return PRINT_SRC_AND_LOC;
11839 }
11840
11841 /* Implement the PRINT_ONE method in the breakpoint_ops structure
11842    for all exception catchpoint kinds.  */
11843
11844 static void
11845 print_one_exception (struct breakpoint *b, struct bp_location **last_loc)
11846
11847   struct ui_out *uiout = current_uiout;
11848   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11849   struct value_print_options opts;
11850
11851   get_user_print_options (&opts);
11852
11853   if (opts.addressprint)
11854     uiout->field_skip ("addr");
11855
11856   annotate_field (5);
11857   switch (c->m_kind)
11858     {
11859       case ada_catch_exception:
11860         if (!c->excep_string.empty ())
11861           {
11862             std::string msg = string_printf (_("`%s' Ada exception"),
11863                                              c->excep_string.c_str ());
11864
11865             uiout->field_string ("what", msg);
11866           }
11867         else
11868           uiout->field_string ("what", "all Ada exceptions");
11869         
11870         break;
11871
11872       case ada_catch_exception_unhandled:
11873         uiout->field_string ("what", "unhandled Ada exceptions");
11874         break;
11875       
11876       case ada_catch_handlers:
11877         if (!c->excep_string.empty ())
11878           {
11879             uiout->field_fmt ("what",
11880                               _("`%s' Ada exception handlers"),
11881                               c->excep_string.c_str ());
11882           }
11883         else
11884           uiout->field_string ("what", "all Ada exceptions handlers");
11885         break;
11886
11887       case ada_catch_assert:
11888         uiout->field_string ("what", "failed Ada assertions");
11889         break;
11890
11891       default:
11892         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11893         break;
11894     }
11895 }
11896
11897 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
11898    for all exception catchpoint kinds.  */
11899
11900 static void
11901 print_mention_exception (struct breakpoint *b)
11902 {
11903   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11904   struct ui_out *uiout = current_uiout;
11905
11906   uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
11907                                                  : _("Catchpoint "));
11908   uiout->field_signed ("bkptno", b->number);
11909   uiout->text (": ");
11910
11911   switch (c->m_kind)
11912     {
11913       case ada_catch_exception:
11914         if (!c->excep_string.empty ())
11915           {
11916             std::string info = string_printf (_("`%s' Ada exception"),
11917                                               c->excep_string.c_str ());
11918             uiout->text (info);
11919           }
11920         else
11921           uiout->text (_("all Ada exceptions"));
11922         break;
11923
11924       case ada_catch_exception_unhandled:
11925         uiout->text (_("unhandled Ada exceptions"));
11926         break;
11927
11928       case ada_catch_handlers:
11929         if (!c->excep_string.empty ())
11930           {
11931             std::string info
11932               = string_printf (_("`%s' Ada exception handlers"),
11933                                c->excep_string.c_str ());
11934             uiout->text (info);
11935           }
11936         else
11937           uiout->text (_("all Ada exceptions handlers"));
11938         break;
11939
11940       case ada_catch_assert:
11941         uiout->text (_("failed Ada assertions"));
11942         break;
11943
11944       default:
11945         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11946         break;
11947     }
11948 }
11949
11950 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
11951    for all exception catchpoint kinds.  */
11952
11953 static void
11954 print_recreate_exception (struct breakpoint *b, struct ui_file *fp)
11955 {
11956   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11957
11958   switch (c->m_kind)
11959     {
11960       case ada_catch_exception:
11961         fprintf_filtered (fp, "catch exception");
11962         if (!c->excep_string.empty ())
11963           fprintf_filtered (fp, " %s", c->excep_string.c_str ());
11964         break;
11965
11966       case ada_catch_exception_unhandled:
11967         fprintf_filtered (fp, "catch exception unhandled");
11968         break;
11969
11970       case ada_catch_handlers:
11971         fprintf_filtered (fp, "catch handlers");
11972         break;
11973
11974       case ada_catch_assert:
11975         fprintf_filtered (fp, "catch assert");
11976         break;
11977
11978       default:
11979         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11980     }
11981   print_recreate_thread (b, fp);
11982 }
11983
11984 /* Virtual tables for various breakpoint types.  */
11985 static struct breakpoint_ops catch_exception_breakpoint_ops;
11986 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
11987 static struct breakpoint_ops catch_assert_breakpoint_ops;
11988 static struct breakpoint_ops catch_handlers_breakpoint_ops;
11989
11990 /* See ada-lang.h.  */
11991
11992 bool
11993 is_ada_exception_catchpoint (breakpoint *bp)
11994 {
11995   return (bp->ops == &catch_exception_breakpoint_ops
11996           || bp->ops == &catch_exception_unhandled_breakpoint_ops
11997           || bp->ops == &catch_assert_breakpoint_ops
11998           || bp->ops == &catch_handlers_breakpoint_ops);
11999 }
12000
12001 /* Split the arguments specified in a "catch exception" command.  
12002    Set EX to the appropriate catchpoint type.
12003    Set EXCEP_STRING to the name of the specific exception if
12004    specified by the user.
12005    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12006    "catch handlers" command.  False otherwise.
12007    If a condition is found at the end of the arguments, the condition
12008    expression is stored in COND_STRING (memory must be deallocated
12009    after use).  Otherwise COND_STRING is set to NULL.  */
12010
12011 static void
12012 catch_ada_exception_command_split (const char *args,
12013                                    bool is_catch_handlers_cmd,
12014                                    enum ada_exception_catchpoint_kind *ex,
12015                                    std::string *excep_string,
12016                                    std::string *cond_string)
12017 {
12018   std::string exception_name;
12019
12020   exception_name = extract_arg (&args);
12021   if (exception_name == "if")
12022     {
12023       /* This is not an exception name; this is the start of a condition
12024          expression for a catchpoint on all exceptions.  So, "un-get"
12025          this token, and set exception_name to NULL.  */
12026       exception_name.clear ();
12027       args -= 2;
12028     }
12029
12030   /* Check to see if we have a condition.  */
12031
12032   args = skip_spaces (args);
12033   if (startswith (args, "if")
12034       && (isspace (args[2]) || args[2] == '\0'))
12035     {
12036       args += 2;
12037       args = skip_spaces (args);
12038
12039       if (args[0] == '\0')
12040         error (_("Condition missing after `if' keyword"));
12041       *cond_string = args;
12042
12043       args += strlen (args);
12044     }
12045
12046   /* Check that we do not have any more arguments.  Anything else
12047      is unexpected.  */
12048
12049   if (args[0] != '\0')
12050     error (_("Junk at end of expression"));
12051
12052   if (is_catch_handlers_cmd)
12053     {
12054       /* Catch handling of exceptions.  */
12055       *ex = ada_catch_handlers;
12056       *excep_string = exception_name;
12057     }
12058   else if (exception_name.empty ())
12059     {
12060       /* Catch all exceptions.  */
12061       *ex = ada_catch_exception;
12062       excep_string->clear ();
12063     }
12064   else if (exception_name == "unhandled")
12065     {
12066       /* Catch unhandled exceptions.  */
12067       *ex = ada_catch_exception_unhandled;
12068       excep_string->clear ();
12069     }
12070   else
12071     {
12072       /* Catch a specific exception.  */
12073       *ex = ada_catch_exception;
12074       *excep_string = exception_name;
12075     }
12076 }
12077
12078 /* Return the name of the symbol on which we should break in order to
12079    implement a catchpoint of the EX kind.  */
12080
12081 static const char *
12082 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12083 {
12084   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12085
12086   gdb_assert (data->exception_info != NULL);
12087
12088   switch (ex)
12089     {
12090       case ada_catch_exception:
12091         return (data->exception_info->catch_exception_sym);
12092         break;
12093       case ada_catch_exception_unhandled:
12094         return (data->exception_info->catch_exception_unhandled_sym);
12095         break;
12096       case ada_catch_assert:
12097         return (data->exception_info->catch_assert_sym);
12098         break;
12099       case ada_catch_handlers:
12100         return (data->exception_info->catch_handlers_sym);
12101         break;
12102       default:
12103         internal_error (__FILE__, __LINE__,
12104                         _("unexpected catchpoint kind (%d)"), ex);
12105     }
12106 }
12107
12108 /* Return the breakpoint ops "virtual table" used for catchpoints
12109    of the EX kind.  */
12110
12111 static const struct breakpoint_ops *
12112 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
12113 {
12114   switch (ex)
12115     {
12116       case ada_catch_exception:
12117         return (&catch_exception_breakpoint_ops);
12118         break;
12119       case ada_catch_exception_unhandled:
12120         return (&catch_exception_unhandled_breakpoint_ops);
12121         break;
12122       case ada_catch_assert:
12123         return (&catch_assert_breakpoint_ops);
12124         break;
12125       case ada_catch_handlers:
12126         return (&catch_handlers_breakpoint_ops);
12127         break;
12128       default:
12129         internal_error (__FILE__, __LINE__,
12130                         _("unexpected catchpoint kind (%d)"), ex);
12131     }
12132 }
12133
12134 /* Return the condition that will be used to match the current exception
12135    being raised with the exception that the user wants to catch.  This
12136    assumes that this condition is used when the inferior just triggered
12137    an exception catchpoint.
12138    EX: the type of catchpoints used for catching Ada exceptions.  */
12139
12140 static std::string
12141 ada_exception_catchpoint_cond_string (const char *excep_string,
12142                                       enum ada_exception_catchpoint_kind ex)
12143 {
12144   int i;
12145   bool is_standard_exc = false;
12146   std::string result;
12147
12148   if (ex == ada_catch_handlers)
12149     {
12150       /* For exception handlers catchpoints, the condition string does
12151          not use the same parameter as for the other exceptions.  */
12152       result = ("long_integer (GNAT_GCC_exception_Access"
12153                 "(gcc_exception).all.occurrence.id)");
12154     }
12155   else
12156     result = "long_integer (e)";
12157
12158   /* The standard exceptions are a special case.  They are defined in
12159      runtime units that have been compiled without debugging info; if
12160      EXCEP_STRING is the not-fully-qualified name of a standard
12161      exception (e.g. "constraint_error") then, during the evaluation
12162      of the condition expression, the symbol lookup on this name would
12163      *not* return this standard exception.  The catchpoint condition
12164      may then be set only on user-defined exceptions which have the
12165      same not-fully-qualified name (e.g. my_package.constraint_error).
12166
12167      To avoid this unexcepted behavior, these standard exceptions are
12168      systematically prefixed by "standard".  This means that "catch
12169      exception constraint_error" is rewritten into "catch exception
12170      standard.constraint_error".
12171
12172      If an exception named constraint_error is defined in another package of
12173      the inferior program, then the only way to specify this exception as a
12174      breakpoint condition is to use its fully-qualified named:
12175      e.g. my_package.constraint_error.  */
12176
12177   for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12178     {
12179       if (strcmp (standard_exc [i], excep_string) == 0)
12180         {
12181           is_standard_exc = true;
12182           break;
12183         }
12184     }
12185
12186   result += " = ";
12187
12188   if (is_standard_exc)
12189     string_appendf (result, "long_integer (&standard.%s)", excep_string);
12190   else
12191     string_appendf (result, "long_integer (&%s)", excep_string);
12192
12193   return result;
12194 }
12195
12196 /* Return the symtab_and_line that should be used to insert an exception
12197    catchpoint of the TYPE kind.
12198
12199    ADDR_STRING returns the name of the function where the real
12200    breakpoint that implements the catchpoints is set, depending on the
12201    type of catchpoint we need to create.  */
12202
12203 static struct symtab_and_line
12204 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12205                    std::string *addr_string, const struct breakpoint_ops **ops)
12206 {
12207   const char *sym_name;
12208   struct symbol *sym;
12209
12210   /* First, find out which exception support info to use.  */
12211   ada_exception_support_info_sniffer ();
12212
12213   /* Then lookup the function on which we will break in order to catch
12214      the Ada exceptions requested by the user.  */
12215   sym_name = ada_exception_sym_name (ex);
12216   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12217
12218   if (sym == NULL)
12219     error (_("Catchpoint symbol not found: %s"), sym_name);
12220
12221   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12222     error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12223
12224   /* Set ADDR_STRING.  */
12225   *addr_string = sym_name;
12226
12227   /* Set OPS.  */
12228   *ops = ada_exception_breakpoint_ops (ex);
12229
12230   return find_function_start_sal (sym, 1);
12231 }
12232
12233 /* Create an Ada exception catchpoint.
12234
12235    EX_KIND is the kind of exception catchpoint to be created.
12236
12237    If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12238    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
12239    of the exception to which this catchpoint applies.
12240
12241    COND_STRING, if not empty, is the catchpoint condition.
12242
12243    TEMPFLAG, if nonzero, means that the underlying breakpoint
12244    should be temporary.
12245
12246    FROM_TTY is the usual argument passed to all commands implementations.  */
12247
12248 void
12249 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12250                                  enum ada_exception_catchpoint_kind ex_kind,
12251                                  const std::string &excep_string,
12252                                  const std::string &cond_string,
12253                                  int tempflag,
12254                                  int disabled,
12255                                  int from_tty)
12256 {
12257   std::string addr_string;
12258   const struct breakpoint_ops *ops = NULL;
12259   struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
12260
12261   std::unique_ptr<ada_catchpoint> c (new ada_catchpoint (ex_kind));
12262   init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
12263                                  ops, tempflag, disabled, from_tty);
12264   c->excep_string = excep_string;
12265   create_excep_cond_exprs (c.get (), ex_kind);
12266   if (!cond_string.empty ())
12267     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12268   install_breakpoint (0, std::move (c), 1);
12269 }
12270
12271 /* Implement the "catch exception" command.  */
12272
12273 static void
12274 catch_ada_exception_command (const char *arg_entry, int from_tty,
12275                              struct cmd_list_element *command)
12276 {
12277   const char *arg = arg_entry;
12278   struct gdbarch *gdbarch = get_current_arch ();
12279   int tempflag;
12280   enum ada_exception_catchpoint_kind ex_kind;
12281   std::string excep_string;
12282   std::string cond_string;
12283
12284   tempflag = command->context () == CATCH_TEMPORARY;
12285
12286   if (!arg)
12287     arg = "";
12288   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12289                                      &cond_string);
12290   create_ada_exception_catchpoint (gdbarch, ex_kind,
12291                                    excep_string, cond_string,
12292                                    tempflag, 1 /* enabled */,
12293                                    from_tty);
12294 }
12295
12296 /* Implement the "catch handlers" command.  */
12297
12298 static void
12299 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12300                             struct cmd_list_element *command)
12301 {
12302   const char *arg = arg_entry;
12303   struct gdbarch *gdbarch = get_current_arch ();
12304   int tempflag;
12305   enum ada_exception_catchpoint_kind ex_kind;
12306   std::string excep_string;
12307   std::string cond_string;
12308
12309   tempflag = command->context () == CATCH_TEMPORARY;
12310
12311   if (!arg)
12312     arg = "";
12313   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12314                                      &cond_string);
12315   create_ada_exception_catchpoint (gdbarch, ex_kind,
12316                                    excep_string, cond_string,
12317                                    tempflag, 1 /* enabled */,
12318                                    from_tty);
12319 }
12320
12321 /* Completion function for the Ada "catch" commands.  */
12322
12323 static void
12324 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12325                      const char *text, const char *word)
12326 {
12327   std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12328
12329   for (const ada_exc_info &info : exceptions)
12330     {
12331       if (startswith (info.name, word))
12332         tracker.add_completion (make_unique_xstrdup (info.name));
12333     }
12334 }
12335
12336 /* Split the arguments specified in a "catch assert" command.
12337
12338    ARGS contains the command's arguments (or the empty string if
12339    no arguments were passed).
12340
12341    If ARGS contains a condition, set COND_STRING to that condition
12342    (the memory needs to be deallocated after use).  */
12343
12344 static void
12345 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12346 {
12347   args = skip_spaces (args);
12348
12349   /* Check whether a condition was provided.  */
12350   if (startswith (args, "if")
12351       && (isspace (args[2]) || args[2] == '\0'))
12352     {
12353       args += 2;
12354       args = skip_spaces (args);
12355       if (args[0] == '\0')
12356         error (_("condition missing after `if' keyword"));
12357       cond_string.assign (args);
12358     }
12359
12360   /* Otherwise, there should be no other argument at the end of
12361      the command.  */
12362   else if (args[0] != '\0')
12363     error (_("Junk at end of arguments."));
12364 }
12365
12366 /* Implement the "catch assert" command.  */
12367
12368 static void
12369 catch_assert_command (const char *arg_entry, int from_tty,
12370                       struct cmd_list_element *command)
12371 {
12372   const char *arg = arg_entry;
12373   struct gdbarch *gdbarch = get_current_arch ();
12374   int tempflag;
12375   std::string cond_string;
12376
12377   tempflag = command->context () == CATCH_TEMPORARY;
12378
12379   if (!arg)
12380     arg = "";
12381   catch_ada_assert_command_split (arg, cond_string);
12382   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12383                                    "", cond_string,
12384                                    tempflag, 1 /* enabled */,
12385                                    from_tty);
12386 }
12387
12388 /* Return non-zero if the symbol SYM is an Ada exception object.  */
12389
12390 static int
12391 ada_is_exception_sym (struct symbol *sym)
12392 {
12393   const char *type_name = SYMBOL_TYPE (sym)->name ();
12394
12395   return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12396           && SYMBOL_CLASS (sym) != LOC_BLOCK
12397           && SYMBOL_CLASS (sym) != LOC_CONST
12398           && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12399           && type_name != NULL && strcmp (type_name, "exception") == 0);
12400 }
12401
12402 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12403    Ada exception object.  This matches all exceptions except the ones
12404    defined by the Ada language.  */
12405
12406 static int
12407 ada_is_non_standard_exception_sym (struct symbol *sym)
12408 {
12409   int i;
12410
12411   if (!ada_is_exception_sym (sym))
12412     return 0;
12413
12414   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12415     if (strcmp (sym->linkage_name (), standard_exc[i]) == 0)
12416       return 0;  /* A standard exception.  */
12417
12418   /* Numeric_Error is also a standard exception, so exclude it.
12419      See the STANDARD_EXC description for more details as to why
12420      this exception is not listed in that array.  */
12421   if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12422     return 0;
12423
12424   return 1;
12425 }
12426
12427 /* A helper function for std::sort, comparing two struct ada_exc_info
12428    objects.
12429
12430    The comparison is determined first by exception name, and then
12431    by exception address.  */
12432
12433 bool
12434 ada_exc_info::operator< (const ada_exc_info &other) const
12435 {
12436   int result;
12437
12438   result = strcmp (name, other.name);
12439   if (result < 0)
12440     return true;
12441   if (result == 0 && addr < other.addr)
12442     return true;
12443   return false;
12444 }
12445
12446 bool
12447 ada_exc_info::operator== (const ada_exc_info &other) const
12448 {
12449   return addr == other.addr && strcmp (name, other.name) == 0;
12450 }
12451
12452 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12453    routine, but keeping the first SKIP elements untouched.
12454
12455    All duplicates are also removed.  */
12456
12457 static void
12458 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
12459                                       int skip)
12460 {
12461   std::sort (exceptions->begin () + skip, exceptions->end ());
12462   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
12463                      exceptions->end ());
12464 }
12465
12466 /* Add all exceptions defined by the Ada standard whose name match
12467    a regular expression.
12468
12469    If PREG is not NULL, then this regexp_t object is used to
12470    perform the symbol name matching.  Otherwise, no name-based
12471    filtering is performed.
12472
12473    EXCEPTIONS is a vector of exceptions to which matching exceptions
12474    gets pushed.  */
12475
12476 static void
12477 ada_add_standard_exceptions (compiled_regex *preg,
12478                              std::vector<ada_exc_info> *exceptions)
12479 {
12480   int i;
12481
12482   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12483     {
12484       if (preg == NULL
12485           || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
12486         {
12487           struct bound_minimal_symbol msymbol
12488             = ada_lookup_simple_minsym (standard_exc[i]);
12489
12490           if (msymbol.minsym != NULL)
12491             {
12492               struct ada_exc_info info
12493                 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
12494
12495               exceptions->push_back (info);
12496             }
12497         }
12498     }
12499 }
12500
12501 /* Add all Ada exceptions defined locally and accessible from the given
12502    FRAME.
12503
12504    If PREG is not NULL, then this regexp_t object is used to
12505    perform the symbol name matching.  Otherwise, no name-based
12506    filtering is performed.
12507
12508    EXCEPTIONS is a vector of exceptions to which matching exceptions
12509    gets pushed.  */
12510
12511 static void
12512 ada_add_exceptions_from_frame (compiled_regex *preg,
12513                                struct frame_info *frame,
12514                                std::vector<ada_exc_info> *exceptions)
12515 {
12516   const struct block *block = get_frame_block (frame, 0);
12517
12518   while (block != 0)
12519     {
12520       struct block_iterator iter;
12521       struct symbol *sym;
12522
12523       ALL_BLOCK_SYMBOLS (block, iter, sym)
12524         {
12525           switch (SYMBOL_CLASS (sym))
12526             {
12527             case LOC_TYPEDEF:
12528             case LOC_BLOCK:
12529             case LOC_CONST:
12530               break;
12531             default:
12532               if (ada_is_exception_sym (sym))
12533                 {
12534                   struct ada_exc_info info = {sym->print_name (),
12535                                               SYMBOL_VALUE_ADDRESS (sym)};
12536
12537                   exceptions->push_back (info);
12538                 }
12539             }
12540         }
12541       if (BLOCK_FUNCTION (block) != NULL)
12542         break;
12543       block = BLOCK_SUPERBLOCK (block);
12544     }
12545 }
12546
12547 /* Return true if NAME matches PREG or if PREG is NULL.  */
12548
12549 static bool
12550 name_matches_regex (const char *name, compiled_regex *preg)
12551 {
12552   return (preg == NULL
12553           || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
12554 }
12555
12556 /* Add all exceptions defined globally whose name name match
12557    a regular expression, excluding standard exceptions.
12558
12559    The reason we exclude standard exceptions is that they need
12560    to be handled separately: Standard exceptions are defined inside
12561    a runtime unit which is normally not compiled with debugging info,
12562    and thus usually do not show up in our symbol search.  However,
12563    if the unit was in fact built with debugging info, we need to
12564    exclude them because they would duplicate the entry we found
12565    during the special loop that specifically searches for those
12566    standard exceptions.
12567
12568    If PREG is not NULL, then this regexp_t object is used to
12569    perform the symbol name matching.  Otherwise, no name-based
12570    filtering is performed.
12571
12572    EXCEPTIONS is a vector of exceptions to which matching exceptions
12573    gets pushed.  */
12574
12575 static void
12576 ada_add_global_exceptions (compiled_regex *preg,
12577                            std::vector<ada_exc_info> *exceptions)
12578 {
12579   /* In Ada, the symbol "search name" is a linkage name, whereas the
12580      regular expression used to do the matching refers to the natural
12581      name.  So match against the decoded name.  */
12582   expand_symtabs_matching (NULL,
12583                            lookup_name_info::match_any (),
12584                            [&] (const char *search_name)
12585                            {
12586                              std::string decoded = ada_decode (search_name);
12587                              return name_matches_regex (decoded.c_str (), preg);
12588                            },
12589                            NULL,
12590                            SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
12591                            VARIABLES_DOMAIN);
12592
12593   for (objfile *objfile : current_program_space->objfiles ())
12594     {
12595       for (compunit_symtab *s : objfile->compunits ())
12596         {
12597           const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
12598           int i;
12599
12600           for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
12601             {
12602               const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
12603               struct block_iterator iter;
12604               struct symbol *sym;
12605
12606               ALL_BLOCK_SYMBOLS (b, iter, sym)
12607                 if (ada_is_non_standard_exception_sym (sym)
12608                     && name_matches_regex (sym->natural_name (), preg))
12609                   {
12610                     struct ada_exc_info info
12611                       = {sym->print_name (), SYMBOL_VALUE_ADDRESS (sym)};
12612
12613                     exceptions->push_back (info);
12614                   }
12615             }
12616         }
12617     }
12618 }
12619
12620 /* Implements ada_exceptions_list with the regular expression passed
12621    as a regex_t, rather than a string.
12622
12623    If not NULL, PREG is used to filter out exceptions whose names
12624    do not match.  Otherwise, all exceptions are listed.  */
12625
12626 static std::vector<ada_exc_info>
12627 ada_exceptions_list_1 (compiled_regex *preg)
12628 {
12629   std::vector<ada_exc_info> result;
12630   int prev_len;
12631
12632   /* First, list the known standard exceptions.  These exceptions
12633      need to be handled separately, as they are usually defined in
12634      runtime units that have been compiled without debugging info.  */
12635
12636   ada_add_standard_exceptions (preg, &result);
12637
12638   /* Next, find all exceptions whose scope is local and accessible
12639      from the currently selected frame.  */
12640
12641   if (has_stack_frames ())
12642     {
12643       prev_len = result.size ();
12644       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
12645                                      &result);
12646       if (result.size () > prev_len)
12647         sort_remove_dups_ada_exceptions_list (&result, prev_len);
12648     }
12649
12650   /* Add all exceptions whose scope is global.  */
12651
12652   prev_len = result.size ();
12653   ada_add_global_exceptions (preg, &result);
12654   if (result.size () > prev_len)
12655     sort_remove_dups_ada_exceptions_list (&result, prev_len);
12656
12657   return result;
12658 }
12659
12660 /* Return a vector of ada_exc_info.
12661
12662    If REGEXP is NULL, all exceptions are included in the result.
12663    Otherwise, it should contain a valid regular expression,
12664    and only the exceptions whose names match that regular expression
12665    are included in the result.
12666
12667    The exceptions are sorted in the following order:
12668      - Standard exceptions (defined by the Ada language), in
12669        alphabetical order;
12670      - Exceptions only visible from the current frame, in
12671        alphabetical order;
12672      - Exceptions whose scope is global, in alphabetical order.  */
12673
12674 std::vector<ada_exc_info>
12675 ada_exceptions_list (const char *regexp)
12676 {
12677   if (regexp == NULL)
12678     return ada_exceptions_list_1 (NULL);
12679
12680   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
12681   return ada_exceptions_list_1 (&reg);
12682 }
12683
12684 /* Implement the "info exceptions" command.  */
12685
12686 static void
12687 info_exceptions_command (const char *regexp, int from_tty)
12688 {
12689   struct gdbarch *gdbarch = get_current_arch ();
12690
12691   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
12692
12693   if (regexp != NULL)
12694     printf_filtered
12695       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
12696   else
12697     printf_filtered (_("All defined Ada exceptions:\n"));
12698
12699   for (const ada_exc_info &info : exceptions)
12700     printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
12701 }
12702
12703 \f
12704                                 /* Language vector */
12705
12706 /* symbol_name_matcher_ftype adapter for wild_match.  */
12707
12708 static bool
12709 do_wild_match (const char *symbol_search_name,
12710                const lookup_name_info &lookup_name,
12711                completion_match_result *comp_match_res)
12712 {
12713   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
12714 }
12715
12716 /* symbol_name_matcher_ftype adapter for full_match.  */
12717
12718 static bool
12719 do_full_match (const char *symbol_search_name,
12720                const lookup_name_info &lookup_name,
12721                completion_match_result *comp_match_res)
12722 {
12723   const char *lname = lookup_name.ada ().lookup_name ().c_str ();
12724
12725   /* If both symbols start with "_ada_", just let the loop below
12726      handle the comparison.  However, if only the symbol name starts
12727      with "_ada_", skip the prefix and let the match proceed as
12728      usual.  */
12729   if (startswith (symbol_search_name, "_ada_")
12730       && !startswith (lname, "_ada"))
12731     symbol_search_name += 5;
12732
12733   int uscore_count = 0;
12734   while (*lname != '\0')
12735     {
12736       if (*symbol_search_name != *lname)
12737         {
12738           if (*symbol_search_name == 'B' && uscore_count == 2
12739               && symbol_search_name[1] == '_')
12740             {
12741               symbol_search_name += 2;
12742               while (isdigit (*symbol_search_name))
12743                 ++symbol_search_name;
12744               if (symbol_search_name[0] == '_'
12745                   && symbol_search_name[1] == '_')
12746                 {
12747                   symbol_search_name += 2;
12748                   continue;
12749                 }
12750             }
12751           return false;
12752         }
12753
12754       if (*symbol_search_name == '_')
12755         ++uscore_count;
12756       else
12757         uscore_count = 0;
12758
12759       ++symbol_search_name;
12760       ++lname;
12761     }
12762
12763   return is_name_suffix (symbol_search_name);
12764 }
12765
12766 /* symbol_name_matcher_ftype for exact (verbatim) matches.  */
12767
12768 static bool
12769 do_exact_match (const char *symbol_search_name,
12770                 const lookup_name_info &lookup_name,
12771                 completion_match_result *comp_match_res)
12772 {
12773   return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
12774 }
12775
12776 /* Build the Ada lookup name for LOOKUP_NAME.  */
12777
12778 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
12779 {
12780   gdb::string_view user_name = lookup_name.name ();
12781
12782   if (!user_name.empty () && user_name[0] == '<')
12783     {
12784       if (user_name.back () == '>')
12785         m_encoded_name
12786           = gdb::to_string (user_name.substr (1, user_name.size () - 2));
12787       else
12788         m_encoded_name
12789           = gdb::to_string (user_name.substr (1, user_name.size () - 1));
12790       m_encoded_p = true;
12791       m_verbatim_p = true;
12792       m_wild_match_p = false;
12793       m_standard_p = false;
12794     }
12795   else
12796     {
12797       m_verbatim_p = false;
12798
12799       m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
12800
12801       if (!m_encoded_p)
12802         {
12803           const char *folded = ada_fold_name (user_name);
12804           m_encoded_name = ada_encode_1 (folded, false);
12805           if (m_encoded_name.empty ())
12806             m_encoded_name = gdb::to_string (user_name);
12807         }
12808       else
12809         m_encoded_name = gdb::to_string (user_name);
12810
12811       /* Handle the 'package Standard' special case.  See description
12812          of m_standard_p.  */
12813       if (startswith (m_encoded_name.c_str (), "standard__"))
12814         {
12815           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
12816           m_standard_p = true;
12817         }
12818       else
12819         m_standard_p = false;
12820
12821       /* If the name contains a ".", then the user is entering a fully
12822          qualified entity name, and the match must not be done in wild
12823          mode.  Similarly, if the user wants to complete what looks
12824          like an encoded name, the match must not be done in wild
12825          mode.  Also, in the standard__ special case always do
12826          non-wild matching.  */
12827       m_wild_match_p
12828         = (lookup_name.match_type () != symbol_name_match_type::FULL
12829            && !m_encoded_p
12830            && !m_standard_p
12831            && user_name.find ('.') == std::string::npos);
12832     }
12833 }
12834
12835 /* symbol_name_matcher_ftype method for Ada.  This only handles
12836    completion mode.  */
12837
12838 static bool
12839 ada_symbol_name_matches (const char *symbol_search_name,
12840                          const lookup_name_info &lookup_name,
12841                          completion_match_result *comp_match_res)
12842 {
12843   return lookup_name.ada ().matches (symbol_search_name,
12844                                      lookup_name.match_type (),
12845                                      comp_match_res);
12846 }
12847
12848 /* A name matcher that matches the symbol name exactly, with
12849    strcmp.  */
12850
12851 static bool
12852 literal_symbol_name_matcher (const char *symbol_search_name,
12853                              const lookup_name_info &lookup_name,
12854                              completion_match_result *comp_match_res)
12855 {
12856   gdb::string_view name_view = lookup_name.name ();
12857
12858   if (lookup_name.completion_mode ()
12859       ? (strncmp (symbol_search_name, name_view.data (),
12860                   name_view.size ()) == 0)
12861       : symbol_search_name == name_view)
12862     {
12863       if (comp_match_res != NULL)
12864         comp_match_res->set_match (symbol_search_name);
12865       return true;
12866     }
12867   else
12868     return false;
12869 }
12870
12871 /* Implement the "get_symbol_name_matcher" language_defn method for
12872    Ada.  */
12873
12874 static symbol_name_matcher_ftype *
12875 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
12876 {
12877   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
12878     return literal_symbol_name_matcher;
12879
12880   if (lookup_name.completion_mode ())
12881     return ada_symbol_name_matches;
12882   else
12883     {
12884       if (lookup_name.ada ().wild_match_p ())
12885         return do_wild_match;
12886       else if (lookup_name.ada ().verbatim_p ())
12887         return do_exact_match;
12888       else
12889         return do_full_match;
12890     }
12891 }
12892
12893 /* Class representing the Ada language.  */
12894
12895 class ada_language : public language_defn
12896 {
12897 public:
12898   ada_language ()
12899     : language_defn (language_ada)
12900   { /* Nothing.  */ }
12901
12902   /* See language.h.  */
12903
12904   const char *name () const override
12905   { return "ada"; }
12906
12907   /* See language.h.  */
12908
12909   const char *natural_name () const override
12910   { return "Ada"; }
12911
12912   /* See language.h.  */
12913
12914   const std::vector<const char *> &filename_extensions () const override
12915   {
12916     static const std::vector<const char *> extensions
12917       = { ".adb", ".ads", ".a", ".ada", ".dg" };
12918     return extensions;
12919   }
12920
12921   /* Print an array element index using the Ada syntax.  */
12922
12923   void print_array_index (struct type *index_type,
12924                           LONGEST index,
12925                           struct ui_file *stream,
12926                           const value_print_options *options) const override
12927   {
12928     struct value *index_value = val_atr (index_type, index);
12929
12930     value_print (index_value, stream, options);
12931     fprintf_filtered (stream, " => ");
12932   }
12933
12934   /* Implement the "read_var_value" language_defn method for Ada.  */
12935
12936   struct value *read_var_value (struct symbol *var,
12937                                 const struct block *var_block,
12938                                 struct frame_info *frame) const override
12939   {
12940     /* The only case where default_read_var_value is not sufficient
12941        is when VAR is a renaming...  */
12942     if (frame != nullptr)
12943       {
12944         const struct block *frame_block = get_frame_block (frame, NULL);
12945         if (frame_block != nullptr && ada_is_renaming_symbol (var))
12946           return ada_read_renaming_var_value (var, frame_block);
12947       }
12948
12949     /* This is a typical case where we expect the default_read_var_value
12950        function to work.  */
12951     return language_defn::read_var_value (var, var_block, frame);
12952   }
12953
12954   /* See language.h.  */
12955   void language_arch_info (struct gdbarch *gdbarch,
12956                            struct language_arch_info *lai) const override
12957   {
12958     const struct builtin_type *builtin = builtin_type (gdbarch);
12959
12960     /* Helper function to allow shorter lines below.  */
12961     auto add = [&] (struct type *t)
12962     {
12963       lai->add_primitive_type (t);
12964     };
12965
12966     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12967                             0, "integer"));
12968     add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
12969                             0, "long_integer"));
12970     add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
12971                             0, "short_integer"));
12972     struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
12973                                                   0, "character");
12974     lai->set_string_char_type (char_type);
12975     add (char_type);
12976     add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
12977                           "float", gdbarch_float_format (gdbarch)));
12978     add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
12979                           "long_float", gdbarch_double_format (gdbarch)));
12980     add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
12981                             0, "long_long_integer"));
12982     add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
12983                           "long_long_float",
12984                           gdbarch_long_double_format (gdbarch)));
12985     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12986                             0, "natural"));
12987     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12988                             0, "positive"));
12989     add (builtin->builtin_void);
12990
12991     struct type *system_addr_ptr
12992       = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
12993                                         "void"));
12994     system_addr_ptr->set_name ("system__address");
12995     add (system_addr_ptr);
12996
12997     /* Create the equivalent of the System.Storage_Elements.Storage_Offset
12998        type.  This is a signed integral type whose size is the same as
12999        the size of addresses.  */
13000     unsigned int addr_length = TYPE_LENGTH (system_addr_ptr);
13001     add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13002                             "storage_offset"));
13003
13004     lai->set_bool_type (builtin->builtin_bool);
13005   }
13006
13007   /* See language.h.  */
13008
13009   bool iterate_over_symbols
13010         (const struct block *block, const lookup_name_info &name,
13011          domain_enum domain,
13012          gdb::function_view<symbol_found_callback_ftype> callback) const override
13013   {
13014     std::vector<struct block_symbol> results
13015       = ada_lookup_symbol_list_worker (name, block, domain, 0);
13016     for (block_symbol &sym : results)
13017       {
13018         if (!callback (&sym))
13019           return false;
13020       }
13021
13022     return true;
13023   }
13024
13025   /* See language.h.  */
13026   bool sniff_from_mangled_name (const char *mangled,
13027                                 char **out) const override
13028   {
13029     std::string demangled = ada_decode (mangled);
13030
13031     *out = NULL;
13032
13033     if (demangled != mangled && demangled[0] != '<')
13034       {
13035         /* Set the gsymbol language to Ada, but still return 0.
13036            Two reasons for that:
13037
13038            1. For Ada, we prefer computing the symbol's decoded name
13039            on the fly rather than pre-compute it, in order to save
13040            memory (Ada projects are typically very large).
13041
13042            2. There are some areas in the definition of the GNAT
13043            encoding where, with a bit of bad luck, we might be able
13044            to decode a non-Ada symbol, generating an incorrect
13045            demangled name (Eg: names ending with "TB" for instance
13046            are identified as task bodies and so stripped from
13047            the decoded name returned).
13048
13049            Returning true, here, but not setting *DEMANGLED, helps us get
13050            a little bit of the best of both worlds.  Because we're last,
13051            we should not affect any of the other languages that were
13052            able to demangle the symbol before us; we get to correctly
13053            tag Ada symbols as such; and even if we incorrectly tagged a
13054            non-Ada symbol, which should be rare, any routing through the
13055            Ada language should be transparent (Ada tries to behave much
13056            like C/C++ with non-Ada symbols).  */
13057         return true;
13058       }
13059
13060     return false;
13061   }
13062
13063   /* See language.h.  */
13064
13065   char *demangle_symbol (const char *mangled, int options) const override
13066   {
13067     return ada_la_decode (mangled, options);
13068   }
13069
13070   /* See language.h.  */
13071
13072   void print_type (struct type *type, const char *varstring,
13073                    struct ui_file *stream, int show, int level,
13074                    const struct type_print_options *flags) const override
13075   {
13076     ada_print_type (type, varstring, stream, show, level, flags);
13077   }
13078
13079   /* See language.h.  */
13080
13081   const char *word_break_characters (void) const override
13082   {
13083     return ada_completer_word_break_characters;
13084   }
13085
13086   /* See language.h.  */
13087
13088   void collect_symbol_completion_matches (completion_tracker &tracker,
13089                                           complete_symbol_mode mode,
13090                                           symbol_name_match_type name_match_type,
13091                                           const char *text, const char *word,
13092                                           enum type_code code) const override
13093   {
13094     struct symbol *sym;
13095     const struct block *b, *surrounding_static_block = 0;
13096     struct block_iterator iter;
13097
13098     gdb_assert (code == TYPE_CODE_UNDEF);
13099
13100     lookup_name_info lookup_name (text, name_match_type, true);
13101
13102     /* First, look at the partial symtab symbols.  */
13103     expand_symtabs_matching (NULL,
13104                              lookup_name,
13105                              NULL,
13106                              NULL,
13107                              SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13108                              ALL_DOMAIN);
13109
13110     /* At this point scan through the misc symbol vectors and add each
13111        symbol you find to the list.  Eventually we want to ignore
13112        anything that isn't a text symbol (everything else will be
13113        handled by the psymtab code above).  */
13114
13115     for (objfile *objfile : current_program_space->objfiles ())
13116       {
13117         for (minimal_symbol *msymbol : objfile->msymbols ())
13118           {
13119             QUIT;
13120
13121             if (completion_skip_symbol (mode, msymbol))
13122               continue;
13123
13124             language symbol_language = msymbol->language ();
13125
13126             /* Ada minimal symbols won't have their language set to Ada.  If
13127                we let completion_list_add_name compare using the
13128                default/C-like matcher, then when completing e.g., symbols in a
13129                package named "pck", we'd match internal Ada symbols like
13130                "pckS", which are invalid in an Ada expression, unless you wrap
13131                them in '<' '>' to request a verbatim match.
13132
13133                Unfortunately, some Ada encoded names successfully demangle as
13134                C++ symbols (using an old mangling scheme), such as "name__2Xn"
13135                -> "Xn::name(void)" and thus some Ada minimal symbols end up
13136                with the wrong language set.  Paper over that issue here.  */
13137             if (symbol_language == language_auto
13138                 || symbol_language == language_cplus)
13139               symbol_language = language_ada;
13140
13141             completion_list_add_name (tracker,
13142                                       symbol_language,
13143                                       msymbol->linkage_name (),
13144                                       lookup_name, text, word);
13145           }
13146       }
13147
13148     /* Search upwards from currently selected frame (so that we can
13149        complete on local vars.  */
13150
13151     for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
13152       {
13153         if (!BLOCK_SUPERBLOCK (b))
13154           surrounding_static_block = b;   /* For elmin of dups */
13155
13156         ALL_BLOCK_SYMBOLS (b, iter, sym)
13157           {
13158             if (completion_skip_symbol (mode, sym))
13159               continue;
13160
13161             completion_list_add_name (tracker,
13162                                       sym->language (),
13163                                       sym->linkage_name (),
13164                                       lookup_name, text, word);
13165           }
13166       }
13167
13168     /* Go through the symtabs and check the externs and statics for
13169        symbols which match.  */
13170
13171     for (objfile *objfile : current_program_space->objfiles ())
13172       {
13173         for (compunit_symtab *s : objfile->compunits ())
13174           {
13175             QUIT;
13176             b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
13177             ALL_BLOCK_SYMBOLS (b, iter, sym)
13178               {
13179                 if (completion_skip_symbol (mode, sym))
13180                   continue;
13181
13182                 completion_list_add_name (tracker,
13183                                           sym->language (),
13184                                           sym->linkage_name (),
13185                                           lookup_name, text, word);
13186               }
13187           }
13188       }
13189
13190     for (objfile *objfile : current_program_space->objfiles ())
13191       {
13192         for (compunit_symtab *s : objfile->compunits ())
13193           {
13194             QUIT;
13195             b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
13196             /* Don't do this block twice.  */
13197             if (b == surrounding_static_block)
13198               continue;
13199             ALL_BLOCK_SYMBOLS (b, iter, sym)
13200               {
13201                 if (completion_skip_symbol (mode, sym))
13202                   continue;
13203
13204                 completion_list_add_name (tracker,
13205                                           sym->language (),
13206                                           sym->linkage_name (),
13207                                           lookup_name, text, word);
13208               }
13209           }
13210       }
13211   }
13212
13213   /* See language.h.  */
13214
13215   gdb::unique_xmalloc_ptr<char> watch_location_expression
13216         (struct type *type, CORE_ADDR addr) const override
13217   {
13218     type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
13219     std::string name = type_to_string (type);
13220     return gdb::unique_xmalloc_ptr<char>
13221       (xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr)));
13222   }
13223
13224   /* See language.h.  */
13225
13226   void value_print (struct value *val, struct ui_file *stream,
13227                     const struct value_print_options *options) const override
13228   {
13229     return ada_value_print (val, stream, options);
13230   }
13231
13232   /* See language.h.  */
13233
13234   void value_print_inner
13235         (struct value *val, struct ui_file *stream, int recurse,
13236          const struct value_print_options *options) const override
13237   {
13238     return ada_value_print_inner (val, stream, recurse, options);
13239   }
13240
13241   /* See language.h.  */
13242
13243   struct block_symbol lookup_symbol_nonlocal
13244         (const char *name, const struct block *block,
13245          const domain_enum domain) const override
13246   {
13247     struct block_symbol sym;
13248
13249     sym = ada_lookup_symbol (name, block_static_block (block), domain);
13250     if (sym.symbol != NULL)
13251       return sym;
13252
13253     /* If we haven't found a match at this point, try the primitive
13254        types.  In other languages, this search is performed before
13255        searching for global symbols in order to short-circuit that
13256        global-symbol search if it happens that the name corresponds
13257        to a primitive type.  But we cannot do the same in Ada, because
13258        it is perfectly legitimate for a program to declare a type which
13259        has the same name as a standard type.  If looking up a type in
13260        that situation, we have traditionally ignored the primitive type
13261        in favor of user-defined types.  This is why, unlike most other
13262        languages, we search the primitive types this late and only after
13263        having searched the global symbols without success.  */
13264
13265     if (domain == VAR_DOMAIN)
13266       {
13267         struct gdbarch *gdbarch;
13268
13269         if (block == NULL)
13270           gdbarch = target_gdbarch ();
13271         else
13272           gdbarch = block_gdbarch (block);
13273         sym.symbol
13274           = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13275         if (sym.symbol != NULL)
13276           return sym;
13277       }
13278
13279     return {};
13280   }
13281
13282   /* See language.h.  */
13283
13284   int parser (struct parser_state *ps) const override
13285   {
13286     warnings_issued = 0;
13287     return ada_parse (ps);
13288   }
13289
13290   /* See language.h.  */
13291
13292   void emitchar (int ch, struct type *chtype,
13293                  struct ui_file *stream, int quoter) const override
13294   {
13295     ada_emit_char (ch, chtype, stream, quoter, 1);
13296   }
13297
13298   /* See language.h.  */
13299
13300   void printchar (int ch, struct type *chtype,
13301                   struct ui_file *stream) const override
13302   {
13303     ada_printchar (ch, chtype, stream);
13304   }
13305
13306   /* See language.h.  */
13307
13308   void printstr (struct ui_file *stream, struct type *elttype,
13309                  const gdb_byte *string, unsigned int length,
13310                  const char *encoding, int force_ellipses,
13311                  const struct value_print_options *options) const override
13312   {
13313     ada_printstr (stream, elttype, string, length, encoding,
13314                   force_ellipses, options);
13315   }
13316
13317   /* See language.h.  */
13318
13319   void print_typedef (struct type *type, struct symbol *new_symbol,
13320                       struct ui_file *stream) const override
13321   {
13322     ada_print_typedef (type, new_symbol, stream);
13323   }
13324
13325   /* See language.h.  */
13326
13327   bool is_string_type_p (struct type *type) const override
13328   {
13329     return ada_is_string_type (type);
13330   }
13331
13332   /* See language.h.  */
13333
13334   const char *struct_too_deep_ellipsis () const override
13335   { return "(...)"; }
13336
13337   /* See language.h.  */
13338
13339   bool c_style_arrays_p () const override
13340   { return false; }
13341
13342   /* See language.h.  */
13343
13344   bool store_sym_names_in_linkage_form_p () const override
13345   { return true; }
13346
13347   /* See language.h.  */
13348
13349   const struct lang_varobj_ops *varobj_ops () const override
13350   { return &ada_varobj_ops; }
13351
13352 protected:
13353   /* See language.h.  */
13354
13355   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13356         (const lookup_name_info &lookup_name) const override
13357   {
13358     return ada_get_symbol_name_matcher (lookup_name);
13359   }
13360 };
13361
13362 /* Single instance of the Ada language class.  */
13363
13364 static ada_language ada_language_defn;
13365
13366 /* Command-list for the "set/show ada" prefix command.  */
13367 static struct cmd_list_element *set_ada_list;
13368 static struct cmd_list_element *show_ada_list;
13369
13370 static void
13371 initialize_ada_catchpoint_ops (void)
13372 {
13373   struct breakpoint_ops *ops;
13374
13375   initialize_breakpoint_ops ();
13376
13377   ops = &catch_exception_breakpoint_ops;
13378   *ops = bkpt_breakpoint_ops;
13379   ops->allocate_location = allocate_location_exception;
13380   ops->re_set = re_set_exception;
13381   ops->check_status = check_status_exception;
13382   ops->print_it = print_it_exception;
13383   ops->print_one = print_one_exception;
13384   ops->print_mention = print_mention_exception;
13385   ops->print_recreate = print_recreate_exception;
13386
13387   ops = &catch_exception_unhandled_breakpoint_ops;
13388   *ops = bkpt_breakpoint_ops;
13389   ops->allocate_location = allocate_location_exception;
13390   ops->re_set = re_set_exception;
13391   ops->check_status = check_status_exception;
13392   ops->print_it = print_it_exception;
13393   ops->print_one = print_one_exception;
13394   ops->print_mention = print_mention_exception;
13395   ops->print_recreate = print_recreate_exception;
13396
13397   ops = &catch_assert_breakpoint_ops;
13398   *ops = bkpt_breakpoint_ops;
13399   ops->allocate_location = allocate_location_exception;
13400   ops->re_set = re_set_exception;
13401   ops->check_status = check_status_exception;
13402   ops->print_it = print_it_exception;
13403   ops->print_one = print_one_exception;
13404   ops->print_mention = print_mention_exception;
13405   ops->print_recreate = print_recreate_exception;
13406
13407   ops = &catch_handlers_breakpoint_ops;
13408   *ops = bkpt_breakpoint_ops;
13409   ops->allocate_location = allocate_location_exception;
13410   ops->re_set = re_set_exception;
13411   ops->check_status = check_status_exception;
13412   ops->print_it = print_it_exception;
13413   ops->print_one = print_one_exception;
13414   ops->print_mention = print_mention_exception;
13415   ops->print_recreate = print_recreate_exception;
13416 }
13417
13418 /* This module's 'new_objfile' observer.  */
13419
13420 static void
13421 ada_new_objfile_observer (struct objfile *objfile)
13422 {
13423   ada_clear_symbol_cache ();
13424 }
13425
13426 /* This module's 'free_objfile' observer.  */
13427
13428 static void
13429 ada_free_objfile_observer (struct objfile *objfile)
13430 {
13431   ada_clear_symbol_cache ();
13432 }
13433
13434 void _initialize_ada_language ();
13435 void
13436 _initialize_ada_language ()
13437 {
13438   initialize_ada_catchpoint_ops ();
13439
13440   add_basic_prefix_cmd ("ada", no_class,
13441                         _("Prefix command for changing Ada-specific settings."),
13442                         &set_ada_list, 0, &setlist);
13443
13444   add_show_prefix_cmd ("ada", no_class,
13445                        _("Generic command for showing Ada-specific settings."),
13446                        &show_ada_list, 0, &showlist);
13447
13448   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13449                            &trust_pad_over_xvs, _("\
13450 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13451 Show whether an optimization trusting PAD types over XVS types is activated."),
13452                            _("\
13453 This is related to the encoding used by the GNAT compiler.  The debugger\n\
13454 should normally trust the contents of PAD types, but certain older versions\n\
13455 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13456 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
13457 work around this bug.  It is always safe to turn this option \"off\", but\n\
13458 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13459 this option to \"off\" unless necessary."),
13460                             NULL, NULL, &set_ada_list, &show_ada_list);
13461
13462   add_setshow_boolean_cmd ("print-signatures", class_vars,
13463                            &print_signatures, _("\
13464 Enable or disable the output of formal and return types for functions in the \
13465 overloads selection menu."), _("\
13466 Show whether the output of formal and return types for functions in the \
13467 overloads selection menu is activated."),
13468                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
13469
13470   add_catch_command ("exception", _("\
13471 Catch Ada exceptions, when raised.\n\
13472 Usage: catch exception [ARG] [if CONDITION]\n\
13473 Without any argument, stop when any Ada exception is raised.\n\
13474 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
13475 being raised does not have a handler (and will therefore lead to the task's\n\
13476 termination).\n\
13477 Otherwise, the catchpoint only stops when the name of the exception being\n\
13478 raised is the same as ARG.\n\
13479 CONDITION is a boolean expression that is evaluated to see whether the\n\
13480 exception should cause a stop."),
13481                      catch_ada_exception_command,
13482                      catch_ada_completer,
13483                      CATCH_PERMANENT,
13484                      CATCH_TEMPORARY);
13485
13486   add_catch_command ("handlers", _("\
13487 Catch Ada exceptions, when handled.\n\
13488 Usage: catch handlers [ARG] [if CONDITION]\n\
13489 Without any argument, stop when any Ada exception is handled.\n\
13490 With an argument, catch only exceptions with the given name.\n\
13491 CONDITION is a boolean expression that is evaluated to see whether the\n\
13492 exception should cause a stop."),
13493                      catch_ada_handlers_command,
13494                      catch_ada_completer,
13495                      CATCH_PERMANENT,
13496                      CATCH_TEMPORARY);
13497   add_catch_command ("assert", _("\
13498 Catch failed Ada assertions, when raised.\n\
13499 Usage: catch assert [if CONDITION]\n\
13500 CONDITION is a boolean expression that is evaluated to see whether the\n\
13501 exception should cause a stop."),
13502                      catch_assert_command,
13503                      NULL,
13504                      CATCH_PERMANENT,
13505                      CATCH_TEMPORARY);
13506
13507   varsize_limit = 65536;
13508   add_setshow_uinteger_cmd ("varsize-limit", class_support,
13509                             &varsize_limit, _("\
13510 Set the maximum number of bytes allowed in a variable-size object."), _("\
13511 Show the maximum number of bytes allowed in a variable-size object."), _("\
13512 Attempts to access an object whose size is not a compile-time constant\n\
13513 and exceeds this limit will cause an error."),
13514                             NULL, NULL, &setlist, &showlist);
13515
13516   add_info ("exceptions", info_exceptions_command,
13517             _("\
13518 List all Ada exception names.\n\
13519 Usage: info exceptions [REGEXP]\n\
13520 If a regular expression is passed as an argument, only those matching\n\
13521 the regular expression are listed."));
13522
13523   add_basic_prefix_cmd ("ada", class_maintenance,
13524                         _("Set Ada maintenance-related variables."),
13525                         &maint_set_ada_cmdlist,
13526                         0/*allow-unknown*/, &maintenance_set_cmdlist);
13527
13528   add_show_prefix_cmd ("ada", class_maintenance,
13529                        _("Show Ada maintenance-related variables."),
13530                        &maint_show_ada_cmdlist,
13531                        0/*allow-unknown*/, &maintenance_show_cmdlist);
13532
13533   add_setshow_boolean_cmd
13534     ("ignore-descriptive-types", class_maintenance,
13535      &ada_ignore_descriptive_types_p,
13536      _("Set whether descriptive types generated by GNAT should be ignored."),
13537      _("Show whether descriptive types generated by GNAT should be ignored."),
13538      _("\
13539 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13540 DWARF attribute."),
13541      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
13542
13543   decoded_names_store = htab_create_alloc (256, htab_hash_string,
13544                                            htab_eq_string,
13545                                            NULL, xcalloc, xfree);
13546
13547   /* The ada-lang observers.  */
13548   gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
13549   gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
13550   gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");
13551 }
This page took 0.783155 seconds and 4 git commands to generate.