]> Git Repo - binutils.git/blob - gdb/ada-lang.c
Remove union exp_element
[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
53 #include "value.h"
54 #include "mi/mi-common.h"
55 #include "arch-utils.h"
56 #include "cli/cli-utils.h"
57 #include "gdbsupport/function-view.h"
58 #include "gdbsupport/byte-vector.h"
59 #include <algorithm>
60 #include "ada-exp.h"
61
62 /* Define whether or not the C operator '/' truncates towards zero for
63    differently signed operands (truncation direction is undefined in C).
64    Copied from valarith.c.  */
65
66 #ifndef TRUNCATION_TOWARDS_ZERO
67 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
68 #endif
69
70 static struct type *desc_base_type (struct type *);
71
72 static struct type *desc_bounds_type (struct type *);
73
74 static struct value *desc_bounds (struct value *);
75
76 static int fat_pntr_bounds_bitpos (struct type *);
77
78 static int fat_pntr_bounds_bitsize (struct type *);
79
80 static struct type *desc_data_target_type (struct type *);
81
82 static struct value *desc_data (struct value *);
83
84 static int fat_pntr_data_bitpos (struct type *);
85
86 static int fat_pntr_data_bitsize (struct type *);
87
88 static struct value *desc_one_bound (struct value *, int, int);
89
90 static int desc_bound_bitpos (struct type *, int, int);
91
92 static int desc_bound_bitsize (struct type *, int, int);
93
94 static struct type *desc_index_type (struct type *, int);
95
96 static int desc_arity (struct type *);
97
98 static int ada_type_match (struct type *, struct type *, int);
99
100 static int ada_args_match (struct symbol *, struct value **, int);
101
102 static struct value *make_array_descriptor (struct type *, struct value *);
103
104 static void ada_add_block_symbols (std::vector<struct block_symbol> &,
105                                    const struct block *,
106                                    const lookup_name_info &lookup_name,
107                                    domain_enum, struct objfile *);
108
109 static void ada_add_all_symbols (std::vector<struct block_symbol> &,
110                                  const struct block *,
111                                  const lookup_name_info &lookup_name,
112                                  domain_enum, int, int *);
113
114 static int is_nonfunction (const std::vector<struct block_symbol> &);
115
116 static void add_defn_to_vec (std::vector<struct block_symbol> &,
117                              struct symbol *,
118                              const struct block *);
119
120 static int possible_user_operator_p (enum exp_opcode, struct value **);
121
122 static const char *ada_decoded_op_name (enum exp_opcode);
123
124 static int numeric_type_p (struct type *);
125
126 static int integer_type_p (struct type *);
127
128 static int scalar_type_p (struct type *);
129
130 static int discrete_type_p (struct type *);
131
132 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
133                                                 int, int);
134
135 static struct type *ada_find_parallel_type_with_name (struct type *,
136                                                       const char *);
137
138 static int is_dynamic_field (struct type *, int);
139
140 static struct type *to_fixed_variant_branch_type (struct type *,
141                                                   const gdb_byte *,
142                                                   CORE_ADDR, struct value *);
143
144 static struct type *to_fixed_array_type (struct type *, struct value *, int);
145
146 static struct type *to_fixed_range_type (struct type *, struct value *);
147
148 static struct type *to_static_fixed_type (struct type *);
149 static struct type *static_unwrap_type (struct type *type);
150
151 static struct value *unwrap_value (struct value *);
152
153 static struct type *constrained_packed_array_type (struct type *, long *);
154
155 static struct type *decode_constrained_packed_array_type (struct type *);
156
157 static long decode_packed_array_bitsize (struct type *);
158
159 static struct value *decode_constrained_packed_array (struct value *);
160
161 static int ada_is_unconstrained_packed_array_type (struct type *);
162
163 static struct value *value_subscript_packed (struct value *, int,
164                                              struct value **);
165
166 static struct value *coerce_unspec_val_to_type (struct value *,
167                                                 struct type *);
168
169 static int lesseq_defined_than (struct symbol *, struct symbol *);
170
171 static int equiv_types (struct type *, struct type *);
172
173 static int is_name_suffix (const char *);
174
175 static int advance_wild_match (const char **, const char *, char);
176
177 static bool wild_match (const char *name, const char *patn);
178
179 static struct value *ada_coerce_ref (struct value *);
180
181 static LONGEST pos_atr (struct value *);
182
183 static struct value *val_atr (struct type *, LONGEST);
184
185 static struct symbol *standard_lookup (const char *, const struct block *,
186                                        domain_enum);
187
188 static struct value *ada_search_struct_field (const char *, struct value *, int,
189                                               struct type *);
190
191 static int find_struct_field (const char *, struct type *, int,
192                               struct type **, int *, int *, int *, int *);
193
194 static int ada_resolve_function (std::vector<struct block_symbol> &,
195                                  struct value **, int, const char *,
196                                  struct type *, int);
197
198 static int ada_is_direct_array_type (struct type *);
199
200 static struct value *ada_index_struct_field (int, struct value *, int,
201                                              struct type *);
202
203 static void add_component_interval (LONGEST, LONGEST, std::vector<LONGEST> &);
204
205
206 static struct type *ada_find_any_type (const char *name);
207
208 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
209   (const lookup_name_info &lookup_name);
210
211 \f
212
213 /* The result of a symbol lookup to be stored in our symbol cache.  */
214
215 struct cache_entry
216 {
217   /* The name used to perform the lookup.  */
218   const char *name;
219   /* The namespace used during the lookup.  */
220   domain_enum domain;
221   /* The symbol returned by the lookup, or NULL if no matching symbol
222      was found.  */
223   struct symbol *sym;
224   /* The block where the symbol was found, or NULL if no matching
225      symbol was found.  */
226   const struct block *block;
227   /* A pointer to the next entry with the same hash.  */
228   struct cache_entry *next;
229 };
230
231 /* The Ada symbol cache, used to store the result of Ada-mode symbol
232    lookups in the course of executing the user's commands.
233
234    The cache is implemented using a simple, fixed-sized hash.
235    The size is fixed on the grounds that there are not likely to be
236    all that many symbols looked up during any given session, regardless
237    of the size of the symbol table.  If we decide to go to a resizable
238    table, let's just use the stuff from libiberty instead.  */
239
240 #define HASH_SIZE 1009
241
242 struct ada_symbol_cache
243 {
244   /* An obstack used to store the entries in our cache.  */
245   struct auto_obstack cache_space;
246
247   /* The root of the hash table used to implement our symbol cache.  */
248   struct cache_entry *root[HASH_SIZE] {};
249 };
250
251 /* Maximum-sized dynamic type.  */
252 static unsigned int varsize_limit;
253
254 static const char ada_completer_word_break_characters[] =
255 #ifdef VMS
256   " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
257 #else
258   " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
259 #endif
260
261 /* The name of the symbol to use to get the name of the main subprogram.  */
262 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
263   = "__gnat_ada_main_program_name";
264
265 /* Limit on the number of warnings to raise per expression evaluation.  */
266 static int warning_limit = 2;
267
268 /* Number of warning messages issued; reset to 0 by cleanups after
269    expression evaluation.  */
270 static int warnings_issued = 0;
271
272 static const char * const known_runtime_file_name_patterns[] = {
273   ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
274 };
275
276 static const char * const known_auxiliary_function_name_patterns[] = {
277   ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
278 };
279
280 /* Maintenance-related settings for this module.  */
281
282 static struct cmd_list_element *maint_set_ada_cmdlist;
283 static struct cmd_list_element *maint_show_ada_cmdlist;
284
285 /* The "maintenance ada set/show ignore-descriptive-type" value.  */
286
287 static bool ada_ignore_descriptive_types_p = false;
288
289                         /* Inferior-specific data.  */
290
291 /* Per-inferior data for this module.  */
292
293 struct ada_inferior_data
294 {
295   /* The ada__tags__type_specific_data type, which is used when decoding
296      tagged types.  With older versions of GNAT, this type was directly
297      accessible through a component ("tsd") in the object tag.  But this
298      is no longer the case, so we cache it for each inferior.  */
299   struct type *tsd_type = nullptr;
300
301   /* The exception_support_info data.  This data is used to determine
302      how to implement support for Ada exception catchpoints in a given
303      inferior.  */
304   const struct exception_support_info *exception_info = nullptr;
305 };
306
307 /* Our key to this module's inferior data.  */
308 static const struct inferior_key<ada_inferior_data> ada_inferior_data;
309
310 /* Return our inferior data for the given inferior (INF).
311
312    This function always returns a valid pointer to an allocated
313    ada_inferior_data structure.  If INF's inferior data has not
314    been previously set, this functions creates a new one with all
315    fields set to zero, sets INF's inferior to it, and then returns
316    a pointer to that newly allocated ada_inferior_data.  */
317
318 static struct ada_inferior_data *
319 get_ada_inferior_data (struct inferior *inf)
320 {
321   struct ada_inferior_data *data;
322
323   data = ada_inferior_data.get (inf);
324   if (data == NULL)
325     data = ada_inferior_data.emplace (inf);
326
327   return data;
328 }
329
330 /* Perform all necessary cleanups regarding our module's inferior data
331    that is required after the inferior INF just exited.  */
332
333 static void
334 ada_inferior_exit (struct inferior *inf)
335 {
336   ada_inferior_data.clear (inf);
337 }
338
339
340                         /* program-space-specific data.  */
341
342 /* This module's per-program-space data.  */
343 struct ada_pspace_data
344 {
345   /* The Ada symbol cache.  */
346   std::unique_ptr<ada_symbol_cache> sym_cache;
347 };
348
349 /* Key to our per-program-space data.  */
350 static const struct program_space_key<ada_pspace_data> ada_pspace_data_handle;
351
352 /* Return this module's data for the given program space (PSPACE).
353    If not is found, add a zero'ed one now.
354
355    This function always returns a valid object.  */
356
357 static struct ada_pspace_data *
358 get_ada_pspace_data (struct program_space *pspace)
359 {
360   struct ada_pspace_data *data;
361
362   data = ada_pspace_data_handle.get (pspace);
363   if (data == NULL)
364     data = ada_pspace_data_handle.emplace (pspace);
365
366   return data;
367 }
368
369                         /* Utilities */
370
371 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
372    all typedef layers have been peeled.  Otherwise, return TYPE.
373
374    Normally, we really expect a typedef type to only have 1 typedef layer.
375    In other words, we really expect the target type of a typedef type to be
376    a non-typedef type.  This is particularly true for Ada units, because
377    the language does not have a typedef vs not-typedef distinction.
378    In that respect, the Ada compiler has been trying to eliminate as many
379    typedef definitions in the debugging information, since they generally
380    do not bring any extra information (we still use typedef under certain
381    circumstances related mostly to the GNAT encoding).
382
383    Unfortunately, we have seen situations where the debugging information
384    generated by the compiler leads to such multiple typedef layers.  For
385    instance, consider the following example with stabs:
386
387      .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
388      .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
389
390    This is an error in the debugging information which causes type
391    pck__float_array___XUP to be defined twice, and the second time,
392    it is defined as a typedef of a typedef.
393
394    This is on the fringe of legality as far as debugging information is
395    concerned, and certainly unexpected.  But it is easy to handle these
396    situations correctly, so we can afford to be lenient in this case.  */
397
398 static struct type *
399 ada_typedef_target_type (struct type *type)
400 {
401   while (type->code () == TYPE_CODE_TYPEDEF)
402     type = TYPE_TARGET_TYPE (type);
403   return type;
404 }
405
406 /* Given DECODED_NAME a string holding a symbol name in its
407    decoded form (ie using the Ada dotted notation), returns
408    its unqualified name.  */
409
410 static const char *
411 ada_unqualified_name (const char *decoded_name)
412 {
413   const char *result;
414   
415   /* If the decoded name starts with '<', it means that the encoded
416      name does not follow standard naming conventions, and thus that
417      it is not your typical Ada symbol name.  Trying to unqualify it
418      is therefore pointless and possibly erroneous.  */
419   if (decoded_name[0] == '<')
420     return decoded_name;
421
422   result = strrchr (decoded_name, '.');
423   if (result != NULL)
424     result++;                   /* Skip the dot...  */
425   else
426     result = decoded_name;
427
428   return result;
429 }
430
431 /* Return a string starting with '<', followed by STR, and '>'.  */
432
433 static std::string
434 add_angle_brackets (const char *str)
435 {
436   return string_printf ("<%s>", str);
437 }
438
439 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
440    suffix of FIELD_NAME beginning "___".  */
441
442 static int
443 field_name_match (const char *field_name, const char *target)
444 {
445   int len = strlen (target);
446
447   return
448     (strncmp (field_name, target, len) == 0
449      && (field_name[len] == '\0'
450          || (startswith (field_name + len, "___")
451              && strcmp (field_name + strlen (field_name) - 6,
452                         "___XVN") != 0)));
453 }
454
455
456 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
457    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
458    and return its index.  This function also handles fields whose name
459    have ___ suffixes because the compiler sometimes alters their name
460    by adding such a suffix to represent fields with certain constraints.
461    If the field could not be found, return a negative number if
462    MAYBE_MISSING is set.  Otherwise raise an error.  */
463
464 int
465 ada_get_field_index (const struct type *type, const char *field_name,
466                      int maybe_missing)
467 {
468   int fieldno;
469   struct type *struct_type = check_typedef ((struct type *) type);
470
471   for (fieldno = 0; fieldno < struct_type->num_fields (); fieldno++)
472     if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
473       return fieldno;
474
475   if (!maybe_missing)
476     error (_("Unable to find field %s in struct %s.  Aborting"),
477            field_name, struct_type->name ());
478
479   return -1;
480 }
481
482 /* The length of the prefix of NAME prior to any "___" suffix.  */
483
484 int
485 ada_name_prefix_len (const char *name)
486 {
487   if (name == NULL)
488     return 0;
489   else
490     {
491       const char *p = strstr (name, "___");
492
493       if (p == NULL)
494         return strlen (name);
495       else
496         return p - name;
497     }
498 }
499
500 /* Return non-zero if SUFFIX is a suffix of STR.
501    Return zero if STR is null.  */
502
503 static int
504 is_suffix (const char *str, const char *suffix)
505 {
506   int len1, len2;
507
508   if (str == NULL)
509     return 0;
510   len1 = strlen (str);
511   len2 = strlen (suffix);
512   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
513 }
514
515 /* The contents of value VAL, treated as a value of type TYPE.  The
516    result is an lval in memory if VAL is.  */
517
518 static struct value *
519 coerce_unspec_val_to_type (struct value *val, struct type *type)
520 {
521   type = ada_check_typedef (type);
522   if (value_type (val) == type)
523     return val;
524   else
525     {
526       struct value *result;
527
528       /* Make sure that the object size is not unreasonable before
529          trying to allocate some memory for it.  */
530       ada_ensure_varsize_limit (type);
531
532       if (value_optimized_out (val))
533         result = allocate_optimized_out_value (type);
534       else if (value_lazy (val)
535                /* Be careful not to make a lazy not_lval value.  */
536                || (VALUE_LVAL (val) != not_lval
537                    && TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val))))
538         result = allocate_value_lazy (type);
539       else
540         {
541           result = allocate_value (type);
542           value_contents_copy (result, 0, val, 0, TYPE_LENGTH (type));
543         }
544       set_value_component_location (result, val);
545       set_value_bitsize (result, value_bitsize (val));
546       set_value_bitpos (result, value_bitpos (val));
547       if (VALUE_LVAL (result) == lval_memory)
548         set_value_address (result, value_address (val));
549       return result;
550     }
551 }
552
553 static const gdb_byte *
554 cond_offset_host (const gdb_byte *valaddr, long offset)
555 {
556   if (valaddr == NULL)
557     return NULL;
558   else
559     return valaddr + offset;
560 }
561
562 static CORE_ADDR
563 cond_offset_target (CORE_ADDR address, long offset)
564 {
565   if (address == 0)
566     return 0;
567   else
568     return address + offset;
569 }
570
571 /* Issue a warning (as for the definition of warning in utils.c, but
572    with exactly one argument rather than ...), unless the limit on the
573    number of warnings has passed during the evaluation of the current
574    expression.  */
575
576 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
577    provided by "complaint".  */
578 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
579
580 static void
581 lim_warning (const char *format, ...)
582 {
583   va_list args;
584
585   va_start (args, format);
586   warnings_issued += 1;
587   if (warnings_issued <= warning_limit)
588     vwarning (format, args);
589
590   va_end (args);
591 }
592
593 /* Issue an error if the size of an object of type T is unreasonable,
594    i.e. if it would be a bad idea to allocate a value of this type in
595    GDB.  */
596
597 void
598 ada_ensure_varsize_limit (const struct type *type)
599 {
600   if (TYPE_LENGTH (type) > varsize_limit)
601     error (_("object size is larger than varsize-limit"));
602 }
603
604 /* Maximum value of a SIZE-byte signed integer type.  */
605 static LONGEST
606 max_of_size (int size)
607 {
608   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
609
610   return top_bit | (top_bit - 1);
611 }
612
613 /* Minimum value of a SIZE-byte signed integer type.  */
614 static LONGEST
615 min_of_size (int size)
616 {
617   return -max_of_size (size) - 1;
618 }
619
620 /* Maximum value of a SIZE-byte unsigned integer type.  */
621 static ULONGEST
622 umax_of_size (int size)
623 {
624   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
625
626   return top_bit | (top_bit - 1);
627 }
628
629 /* Maximum value of integral type T, as a signed quantity.  */
630 static LONGEST
631 max_of_type (struct type *t)
632 {
633   if (t->is_unsigned ())
634     return (LONGEST) umax_of_size (TYPE_LENGTH (t));
635   else
636     return max_of_size (TYPE_LENGTH (t));
637 }
638
639 /* Minimum value of integral type T, as a signed quantity.  */
640 static LONGEST
641 min_of_type (struct type *t)
642 {
643   if (t->is_unsigned ())
644     return 0;
645   else
646     return min_of_size (TYPE_LENGTH (t));
647 }
648
649 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
650 LONGEST
651 ada_discrete_type_high_bound (struct type *type)
652 {
653   type = resolve_dynamic_type (type, {}, 0);
654   switch (type->code ())
655     {
656     case TYPE_CODE_RANGE:
657       {
658         const dynamic_prop &high = type->bounds ()->high;
659
660         if (high.kind () == PROP_CONST)
661           return high.const_val ();
662         else
663           {
664             gdb_assert (high.kind () == PROP_UNDEFINED);
665
666             /* This happens when trying to evaluate a type's dynamic bound
667                without a live target.  There is nothing relevant for us to
668                return here, so return 0.  */
669             return 0;
670           }
671       }
672     case TYPE_CODE_ENUM:
673       return TYPE_FIELD_ENUMVAL (type, type->num_fields () - 1);
674     case TYPE_CODE_BOOL:
675       return 1;
676     case TYPE_CODE_CHAR:
677     case TYPE_CODE_INT:
678       return max_of_type (type);
679     default:
680       error (_("Unexpected type in ada_discrete_type_high_bound."));
681     }
682 }
683
684 /* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
685 LONGEST
686 ada_discrete_type_low_bound (struct type *type)
687 {
688   type = resolve_dynamic_type (type, {}, 0);
689   switch (type->code ())
690     {
691     case TYPE_CODE_RANGE:
692       {
693         const dynamic_prop &low = type->bounds ()->low;
694
695         if (low.kind () == PROP_CONST)
696           return low.const_val ();
697         else
698           {
699             gdb_assert (low.kind () == PROP_UNDEFINED);
700
701             /* This happens when trying to evaluate a type's dynamic bound
702                without a live target.  There is nothing relevant for us to
703                return here, so return 0.  */
704             return 0;
705           }
706       }
707     case TYPE_CODE_ENUM:
708       return TYPE_FIELD_ENUMVAL (type, 0);
709     case TYPE_CODE_BOOL:
710       return 0;
711     case TYPE_CODE_CHAR:
712     case TYPE_CODE_INT:
713       return min_of_type (type);
714     default:
715       error (_("Unexpected type in ada_discrete_type_low_bound."));
716     }
717 }
718
719 /* The identity on non-range types.  For range types, the underlying
720    non-range scalar type.  */
721
722 static struct type *
723 get_base_type (struct type *type)
724 {
725   while (type != NULL && type->code () == TYPE_CODE_RANGE)
726     {
727       if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
728         return type;
729       type = TYPE_TARGET_TYPE (type);
730     }
731   return type;
732 }
733
734 /* Return a decoded version of the given VALUE.  This means returning
735    a value whose type is obtained by applying all the GNAT-specific
736    encodings, making the resulting type a static but standard description
737    of the initial type.  */
738
739 struct value *
740 ada_get_decoded_value (struct value *value)
741 {
742   struct type *type = ada_check_typedef (value_type (value));
743
744   if (ada_is_array_descriptor_type (type)
745       || (ada_is_constrained_packed_array_type (type)
746           && type->code () != TYPE_CODE_PTR))
747     {
748       if (type->code () == TYPE_CODE_TYPEDEF)  /* array access type.  */
749         value = ada_coerce_to_simple_array_ptr (value);
750       else
751         value = ada_coerce_to_simple_array (value);
752     }
753   else
754     value = ada_to_fixed_value (value);
755
756   return value;
757 }
758
759 /* Same as ada_get_decoded_value, but with the given TYPE.
760    Because there is no associated actual value for this type,
761    the resulting type might be a best-effort approximation in
762    the case of dynamic types.  */
763
764 struct type *
765 ada_get_decoded_type (struct type *type)
766 {
767   type = to_static_fixed_type (type);
768   if (ada_is_constrained_packed_array_type (type))
769     type = ada_coerce_to_simple_array_type (type);
770   return type;
771 }
772
773 \f
774
775                                 /* Language Selection */
776
777 /* If the main program is in Ada, return language_ada, otherwise return LANG
778    (the main program is in Ada iif the adainit symbol is found).  */
779
780 static enum language
781 ada_update_initial_language (enum language lang)
782 {
783   if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
784     return language_ada;
785
786   return lang;
787 }
788
789 /* If the main procedure is written in Ada, then return its name.
790    The result is good until the next call.  Return NULL if the main
791    procedure doesn't appear to be in Ada.  */
792
793 char *
794 ada_main_name (void)
795 {
796   struct bound_minimal_symbol msym;
797   static gdb::unique_xmalloc_ptr<char> main_program_name;
798
799   /* For Ada, the name of the main procedure is stored in a specific
800      string constant, generated by the binder.  Look for that symbol,
801      extract its address, and then read that string.  If we didn't find
802      that string, then most probably the main procedure is not written
803      in Ada.  */
804   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
805
806   if (msym.minsym != NULL)
807     {
808       CORE_ADDR main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
809       if (main_program_name_addr == 0)
810         error (_("Invalid address for Ada main program name."));
811
812       main_program_name = target_read_string (main_program_name_addr, 1024);
813       return main_program_name.get ();
814     }
815
816   /* The main procedure doesn't seem to be in Ada.  */
817   return NULL;
818 }
819 \f
820                                 /* Symbols */
821
822 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
823    of NULLs.  */
824
825 const struct ada_opname_map ada_opname_table[] = {
826   {"Oadd", "\"+\"", BINOP_ADD},
827   {"Osubtract", "\"-\"", BINOP_SUB},
828   {"Omultiply", "\"*\"", BINOP_MUL},
829   {"Odivide", "\"/\"", BINOP_DIV},
830   {"Omod", "\"mod\"", BINOP_MOD},
831   {"Orem", "\"rem\"", BINOP_REM},
832   {"Oexpon", "\"**\"", BINOP_EXP},
833   {"Olt", "\"<\"", BINOP_LESS},
834   {"Ole", "\"<=\"", BINOP_LEQ},
835   {"Ogt", "\">\"", BINOP_GTR},
836   {"Oge", "\">=\"", BINOP_GEQ},
837   {"Oeq", "\"=\"", BINOP_EQUAL},
838   {"One", "\"/=\"", BINOP_NOTEQUAL},
839   {"Oand", "\"and\"", BINOP_BITWISE_AND},
840   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
841   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
842   {"Oconcat", "\"&\"", BINOP_CONCAT},
843   {"Oabs", "\"abs\"", UNOP_ABS},
844   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
845   {"Oadd", "\"+\"", UNOP_PLUS},
846   {"Osubtract", "\"-\"", UNOP_NEG},
847   {NULL, NULL}
848 };
849
850 /* The "encoded" form of DECODED, according to GNAT conventions.  If
851    THROW_ERRORS, throw an error if invalid operator name is found.
852    Otherwise, return the empty string in that case.  */
853
854 static std::string
855 ada_encode_1 (const char *decoded, bool throw_errors)
856 {
857   if (decoded == NULL)
858     return {};
859
860   std::string encoding_buffer;
861   for (const char *p = decoded; *p != '\0'; p += 1)
862     {
863       if (*p == '.')
864         encoding_buffer.append ("__");
865       else if (*p == '"')
866         {
867           const struct ada_opname_map *mapping;
868
869           for (mapping = ada_opname_table;
870                mapping->encoded != NULL
871                && !startswith (p, mapping->decoded); mapping += 1)
872             ;
873           if (mapping->encoded == NULL)
874             {
875               if (throw_errors)
876                 error (_("invalid Ada operator name: %s"), p);
877               else
878                 return {};
879             }
880           encoding_buffer.append (mapping->encoded);
881           break;
882         }
883       else
884         encoding_buffer.push_back (*p);
885     }
886
887   return encoding_buffer;
888 }
889
890 /* The "encoded" form of DECODED, according to GNAT conventions.  */
891
892 std::string
893 ada_encode (const char *decoded)
894 {
895   return ada_encode_1 (decoded, true);
896 }
897
898 /* Return NAME folded to lower case, or, if surrounded by single
899    quotes, unfolded, but with the quotes stripped away.  Result good
900    to next call.  */
901
902 static const char *
903 ada_fold_name (gdb::string_view name)
904 {
905   static std::string fold_storage;
906
907   if (!name.empty () && name[0] == '\'')
908     fold_storage = gdb::to_string (name.substr (1, name.size () - 2));
909   else
910     {
911       fold_storage = gdb::to_string (name);
912       for (int i = 0; i < name.size (); i += 1)
913         fold_storage[i] = tolower (fold_storage[i]);
914     }
915
916   return fold_storage.c_str ();
917 }
918
919 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
920
921 static int
922 is_lower_alphanum (const char c)
923 {
924   return (isdigit (c) || (isalpha (c) && islower (c)));
925 }
926
927 /* ENCODED is the linkage name of a symbol and LEN contains its length.
928    This function saves in LEN the length of that same symbol name but
929    without either of these suffixes:
930      . .{DIGIT}+
931      . ${DIGIT}+
932      . ___{DIGIT}+
933      . __{DIGIT}+.
934
935    These are suffixes introduced by the compiler for entities such as
936    nested subprogram for instance, in order to avoid name clashes.
937    They do not serve any purpose for the debugger.  */
938
939 static void
940 ada_remove_trailing_digits (const char *encoded, int *len)
941 {
942   if (*len > 1 && isdigit (encoded[*len - 1]))
943     {
944       int i = *len - 2;
945
946       while (i > 0 && isdigit (encoded[i]))
947         i--;
948       if (i >= 0 && encoded[i] == '.')
949         *len = i;
950       else if (i >= 0 && encoded[i] == '$')
951         *len = i;
952       else if (i >= 2 && startswith (encoded + i - 2, "___"))
953         *len = i - 2;
954       else if (i >= 1 && startswith (encoded + i - 1, "__"))
955         *len = i - 1;
956     }
957 }
958
959 /* Remove the suffix introduced by the compiler for protected object
960    subprograms.  */
961
962 static void
963 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
964 {
965   /* Remove trailing N.  */
966
967   /* Protected entry subprograms are broken into two
968      separate subprograms: The first one is unprotected, and has
969      a 'N' suffix; the second is the protected version, and has
970      the 'P' suffix.  The second calls the first one after handling
971      the protection.  Since the P subprograms are internally generated,
972      we leave these names undecoded, giving the user a clue that this
973      entity is internal.  */
974
975   if (*len > 1
976       && encoded[*len - 1] == 'N'
977       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
978     *len = *len - 1;
979 }
980
981 /* If ENCODED follows the GNAT entity encoding conventions, then return
982    the decoded form of ENCODED.  Otherwise, return "<%s>" where "%s" is
983    replaced by ENCODED.  */
984
985 std::string
986 ada_decode (const char *encoded)
987 {
988   int i, j;
989   int len0;
990   const char *p;
991   int at_start_name;
992   std::string decoded;
993
994   /* With function descriptors on PPC64, the value of a symbol named
995      ".FN", if it exists, is the entry point of the function "FN".  */
996   if (encoded[0] == '.')
997     encoded += 1;
998
999   /* The name of the Ada main procedure starts with "_ada_".
1000      This prefix is not part of the decoded name, so skip this part
1001      if we see this prefix.  */
1002   if (startswith (encoded, "_ada_"))
1003     encoded += 5;
1004
1005   /* If the name starts with '_', then it is not a properly encoded
1006      name, so do not attempt to decode it.  Similarly, if the name
1007      starts with '<', the name should not be decoded.  */
1008   if (encoded[0] == '_' || encoded[0] == '<')
1009     goto Suppress;
1010
1011   len0 = strlen (encoded);
1012
1013   ada_remove_trailing_digits (encoded, &len0);
1014   ada_remove_po_subprogram_suffix (encoded, &len0);
1015
1016   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1017      the suffix is located before the current "end" of ENCODED.  We want
1018      to avoid re-matching parts of ENCODED that have previously been
1019      marked as discarded (by decrementing LEN0).  */
1020   p = strstr (encoded, "___");
1021   if (p != NULL && p - encoded < len0 - 3)
1022     {
1023       if (p[3] == 'X')
1024         len0 = p - encoded;
1025       else
1026         goto Suppress;
1027     }
1028
1029   /* Remove any trailing TKB suffix.  It tells us that this symbol
1030      is for the body of a task, but that information does not actually
1031      appear in the decoded name.  */
1032
1033   if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1034     len0 -= 3;
1035
1036   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1037      from the TKB suffix because it is used for non-anonymous task
1038      bodies.  */
1039
1040   if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1041     len0 -= 2;
1042
1043   /* Remove trailing "B" suffixes.  */
1044   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1045
1046   if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1047     len0 -= 1;
1048
1049   /* Make decoded big enough for possible expansion by operator name.  */
1050
1051   decoded.resize (2 * len0 + 1, 'X');
1052
1053   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1054
1055   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1056     {
1057       i = len0 - 2;
1058       while ((i >= 0 && isdigit (encoded[i]))
1059              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1060         i -= 1;
1061       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1062         len0 = i - 1;
1063       else if (encoded[i] == '$')
1064         len0 = i;
1065     }
1066
1067   /* The first few characters that are not alphabetic are not part
1068      of any encoding we use, so we can copy them over verbatim.  */
1069
1070   for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1071     decoded[j] = encoded[i];
1072
1073   at_start_name = 1;
1074   while (i < len0)
1075     {
1076       /* Is this a symbol function?  */
1077       if (at_start_name && encoded[i] == 'O')
1078         {
1079           int k;
1080
1081           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1082             {
1083               int op_len = strlen (ada_opname_table[k].encoded);
1084               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1085                             op_len - 1) == 0)
1086                   && !isalnum (encoded[i + op_len]))
1087                 {
1088                   strcpy (&decoded.front() + j, ada_opname_table[k].decoded);
1089                   at_start_name = 0;
1090                   i += op_len;
1091                   j += strlen (ada_opname_table[k].decoded);
1092                   break;
1093                 }
1094             }
1095           if (ada_opname_table[k].encoded != NULL)
1096             continue;
1097         }
1098       at_start_name = 0;
1099
1100       /* Replace "TK__" with "__", which will eventually be translated
1101          into "." (just below).  */
1102
1103       if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1104         i += 2;
1105
1106       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1107          be translated into "." (just below).  These are internal names
1108          generated for anonymous blocks inside which our symbol is nested.  */
1109
1110       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1111           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1112           && isdigit (encoded [i+4]))
1113         {
1114           int k = i + 5;
1115           
1116           while (k < len0 && isdigit (encoded[k]))
1117             k++;  /* Skip any extra digit.  */
1118
1119           /* Double-check that the "__B_{DIGITS}+" sequence we found
1120              is indeed followed by "__".  */
1121           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1122             i = k;
1123         }
1124
1125       /* Remove _E{DIGITS}+[sb] */
1126
1127       /* Just as for protected object subprograms, there are 2 categories
1128          of subprograms created by the compiler for each entry.  The first
1129          one implements the actual entry code, and has a suffix following
1130          the convention above; the second one implements the barrier and
1131          uses the same convention as above, except that the 'E' is replaced
1132          by a 'B'.
1133
1134          Just as above, we do not decode the name of barrier functions
1135          to give the user a clue that the code he is debugging has been
1136          internally generated.  */
1137
1138       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1139           && isdigit (encoded[i+2]))
1140         {
1141           int k = i + 3;
1142
1143           while (k < len0 && isdigit (encoded[k]))
1144             k++;
1145
1146           if (k < len0
1147               && (encoded[k] == 'b' || encoded[k] == 's'))
1148             {
1149               k++;
1150               /* Just as an extra precaution, make sure that if this
1151                  suffix is followed by anything else, it is a '_'.
1152                  Otherwise, we matched this sequence by accident.  */
1153               if (k == len0
1154                   || (k < len0 && encoded[k] == '_'))
1155                 i = k;
1156             }
1157         }
1158
1159       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1160          the GNAT front-end in protected object subprograms.  */
1161
1162       if (i < len0 + 3
1163           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1164         {
1165           /* Backtrack a bit up until we reach either the begining of
1166              the encoded name, or "__".  Make sure that we only find
1167              digits or lowercase characters.  */
1168           const char *ptr = encoded + i - 1;
1169
1170           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1171             ptr--;
1172           if (ptr < encoded
1173               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1174             i++;
1175         }
1176
1177       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1178         {
1179           /* This is a X[bn]* sequence not separated from the previous
1180              part of the name with a non-alpha-numeric character (in other
1181              words, immediately following an alpha-numeric character), then
1182              verify that it is placed at the end of the encoded name.  If
1183              not, then the encoding is not valid and we should abort the
1184              decoding.  Otherwise, just skip it, it is used in body-nested
1185              package names.  */
1186           do
1187             i += 1;
1188           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1189           if (i < len0)
1190             goto Suppress;
1191         }
1192       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1193         {
1194          /* Replace '__' by '.'.  */
1195           decoded[j] = '.';
1196           at_start_name = 1;
1197           i += 2;
1198           j += 1;
1199         }
1200       else
1201         {
1202           /* It's a character part of the decoded name, so just copy it
1203              over.  */
1204           decoded[j] = encoded[i];
1205           i += 1;
1206           j += 1;
1207         }
1208     }
1209   decoded.resize (j);
1210
1211   /* Decoded names should never contain any uppercase character.
1212      Double-check this, and abort the decoding if we find one.  */
1213
1214   for (i = 0; i < decoded.length(); ++i)
1215     if (isupper (decoded[i]) || decoded[i] == ' ')
1216       goto Suppress;
1217
1218   return decoded;
1219
1220 Suppress:
1221   if (encoded[0] == '<')
1222     decoded = encoded;
1223   else
1224     decoded = '<' + std::string(encoded) + '>';
1225   return decoded;
1226
1227 }
1228
1229 /* Table for keeping permanent unique copies of decoded names.  Once
1230    allocated, names in this table are never released.  While this is a
1231    storage leak, it should not be significant unless there are massive
1232    changes in the set of decoded names in successive versions of a 
1233    symbol table loaded during a single session.  */
1234 static struct htab *decoded_names_store;
1235
1236 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1237    in the language-specific part of GSYMBOL, if it has not been
1238    previously computed.  Tries to save the decoded name in the same
1239    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1240    in any case, the decoded symbol has a lifetime at least that of
1241    GSYMBOL).
1242    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1243    const, but nevertheless modified to a semantically equivalent form
1244    when a decoded name is cached in it.  */
1245
1246 const char *
1247 ada_decode_symbol (const struct general_symbol_info *arg)
1248 {
1249   struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1250   const char **resultp =
1251     &gsymbol->language_specific.demangled_name;
1252
1253   if (!gsymbol->ada_mangled)
1254     {
1255       std::string decoded = ada_decode (gsymbol->linkage_name ());
1256       struct obstack *obstack = gsymbol->language_specific.obstack;
1257
1258       gsymbol->ada_mangled = 1;
1259
1260       if (obstack != NULL)
1261         *resultp = obstack_strdup (obstack, decoded.c_str ());
1262       else
1263         {
1264           /* Sometimes, we can't find a corresponding objfile, in
1265              which case, we put the result on the heap.  Since we only
1266              decode when needed, we hope this usually does not cause a
1267              significant memory leak (FIXME).  */
1268
1269           char **slot = (char **) htab_find_slot (decoded_names_store,
1270                                                   decoded.c_str (), INSERT);
1271
1272           if (*slot == NULL)
1273             *slot = xstrdup (decoded.c_str ());
1274           *resultp = *slot;
1275         }
1276     }
1277
1278   return *resultp;
1279 }
1280
1281 static char *
1282 ada_la_decode (const char *encoded, int options)
1283 {
1284   return xstrdup (ada_decode (encoded).c_str ());
1285 }
1286
1287 \f
1288
1289                                 /* Arrays */
1290
1291 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1292    generated by the GNAT compiler to describe the index type used
1293    for each dimension of an array, check whether it follows the latest
1294    known encoding.  If not, fix it up to conform to the latest encoding.
1295    Otherwise, do nothing.  This function also does nothing if
1296    INDEX_DESC_TYPE is NULL.
1297
1298    The GNAT encoding used to describe the array index type evolved a bit.
1299    Initially, the information would be provided through the name of each
1300    field of the structure type only, while the type of these fields was
1301    described as unspecified and irrelevant.  The debugger was then expected
1302    to perform a global type lookup using the name of that field in order
1303    to get access to the full index type description.  Because these global
1304    lookups can be very expensive, the encoding was later enhanced to make
1305    the global lookup unnecessary by defining the field type as being
1306    the full index type description.
1307
1308    The purpose of this routine is to allow us to support older versions
1309    of the compiler by detecting the use of the older encoding, and by
1310    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1311    we essentially replace each field's meaningless type by the associated
1312    index subtype).  */
1313
1314 void
1315 ada_fixup_array_indexes_type (struct type *index_desc_type)
1316 {
1317   int i;
1318
1319   if (index_desc_type == NULL)
1320     return;
1321   gdb_assert (index_desc_type->num_fields () > 0);
1322
1323   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1324      to check one field only, no need to check them all).  If not, return
1325      now.
1326
1327      If our INDEX_DESC_TYPE was generated using the older encoding,
1328      the field type should be a meaningless integer type whose name
1329      is not equal to the field name.  */
1330   if (index_desc_type->field (0).type ()->name () != NULL
1331       && strcmp (index_desc_type->field (0).type ()->name (),
1332                  TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1333     return;
1334
1335   /* Fixup each field of INDEX_DESC_TYPE.  */
1336   for (i = 0; i < index_desc_type->num_fields (); i++)
1337    {
1338      const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1339      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1340
1341      if (raw_type)
1342        index_desc_type->field (i).set_type (raw_type);
1343    }
1344 }
1345
1346 /* The desc_* routines return primitive portions of array descriptors
1347    (fat pointers).  */
1348
1349 /* The descriptor or array type, if any, indicated by TYPE; removes
1350    level of indirection, if needed.  */
1351
1352 static struct type *
1353 desc_base_type (struct type *type)
1354 {
1355   if (type == NULL)
1356     return NULL;
1357   type = ada_check_typedef (type);
1358   if (type->code () == TYPE_CODE_TYPEDEF)
1359     type = ada_typedef_target_type (type);
1360
1361   if (type != NULL
1362       && (type->code () == TYPE_CODE_PTR
1363           || type->code () == TYPE_CODE_REF))
1364     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1365   else
1366     return type;
1367 }
1368
1369 /* True iff TYPE indicates a "thin" array pointer type.  */
1370
1371 static int
1372 is_thin_pntr (struct type *type)
1373 {
1374   return
1375     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1376     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1377 }
1378
1379 /* The descriptor type for thin pointer type TYPE.  */
1380
1381 static struct type *
1382 thin_descriptor_type (struct type *type)
1383 {
1384   struct type *base_type = desc_base_type (type);
1385
1386   if (base_type == NULL)
1387     return NULL;
1388   if (is_suffix (ada_type_name (base_type), "___XVE"))
1389     return base_type;
1390   else
1391     {
1392       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1393
1394       if (alt_type == NULL)
1395         return base_type;
1396       else
1397         return alt_type;
1398     }
1399 }
1400
1401 /* A pointer to the array data for thin-pointer value VAL.  */
1402
1403 static struct value *
1404 thin_data_pntr (struct value *val)
1405 {
1406   struct type *type = ada_check_typedef (value_type (val));
1407   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1408
1409   data_type = lookup_pointer_type (data_type);
1410
1411   if (type->code () == TYPE_CODE_PTR)
1412     return value_cast (data_type, value_copy (val));
1413   else
1414     return value_from_longest (data_type, value_address (val));
1415 }
1416
1417 /* True iff TYPE indicates a "thick" array pointer type.  */
1418
1419 static int
1420 is_thick_pntr (struct type *type)
1421 {
1422   type = desc_base_type (type);
1423   return (type != NULL && type->code () == TYPE_CODE_STRUCT
1424           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1425 }
1426
1427 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1428    pointer to one, the type of its bounds data; otherwise, NULL.  */
1429
1430 static struct type *
1431 desc_bounds_type (struct type *type)
1432 {
1433   struct type *r;
1434
1435   type = desc_base_type (type);
1436
1437   if (type == NULL)
1438     return NULL;
1439   else if (is_thin_pntr (type))
1440     {
1441       type = thin_descriptor_type (type);
1442       if (type == NULL)
1443         return NULL;
1444       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1445       if (r != NULL)
1446         return ada_check_typedef (r);
1447     }
1448   else if (type->code () == TYPE_CODE_STRUCT)
1449     {
1450       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1451       if (r != NULL)
1452         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1453     }
1454   return NULL;
1455 }
1456
1457 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1458    one, a pointer to its bounds data.   Otherwise NULL.  */
1459
1460 static struct value *
1461 desc_bounds (struct value *arr)
1462 {
1463   struct type *type = ada_check_typedef (value_type (arr));
1464
1465   if (is_thin_pntr (type))
1466     {
1467       struct type *bounds_type =
1468         desc_bounds_type (thin_descriptor_type (type));
1469       LONGEST addr;
1470
1471       if (bounds_type == NULL)
1472         error (_("Bad GNAT array descriptor"));
1473
1474       /* NOTE: The following calculation is not really kosher, but
1475          since desc_type is an XVE-encoded type (and shouldn't be),
1476          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1477       if (type->code () == TYPE_CODE_PTR)
1478         addr = value_as_long (arr);
1479       else
1480         addr = value_address (arr);
1481
1482       return
1483         value_from_longest (lookup_pointer_type (bounds_type),
1484                             addr - TYPE_LENGTH (bounds_type));
1485     }
1486
1487   else if (is_thick_pntr (type))
1488     {
1489       struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1490                                                _("Bad GNAT array descriptor"));
1491       struct type *p_bounds_type = value_type (p_bounds);
1492
1493       if (p_bounds_type
1494           && p_bounds_type->code () == TYPE_CODE_PTR)
1495         {
1496           struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1497
1498           if (target_type->is_stub ())
1499             p_bounds = value_cast (lookup_pointer_type
1500                                    (ada_check_typedef (target_type)),
1501                                    p_bounds);
1502         }
1503       else
1504         error (_("Bad GNAT array descriptor"));
1505
1506       return p_bounds;
1507     }
1508   else
1509     return NULL;
1510 }
1511
1512 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1513    position of the field containing the address of the bounds data.  */
1514
1515 static int
1516 fat_pntr_bounds_bitpos (struct type *type)
1517 {
1518   return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1519 }
1520
1521 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1522    size of the field containing the address of the bounds data.  */
1523
1524 static int
1525 fat_pntr_bounds_bitsize (struct type *type)
1526 {
1527   type = desc_base_type (type);
1528
1529   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1530     return TYPE_FIELD_BITSIZE (type, 1);
1531   else
1532     return 8 * TYPE_LENGTH (ada_check_typedef (type->field (1).type ()));
1533 }
1534
1535 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1536    pointer to one, the type of its array data (a array-with-no-bounds type);
1537    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1538    data.  */
1539
1540 static struct type *
1541 desc_data_target_type (struct type *type)
1542 {
1543   type = desc_base_type (type);
1544
1545   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1546   if (is_thin_pntr (type))
1547     return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1548   else if (is_thick_pntr (type))
1549     {
1550       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1551
1552       if (data_type
1553           && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1554         return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1555     }
1556
1557   return NULL;
1558 }
1559
1560 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1561    its array data.  */
1562
1563 static struct value *
1564 desc_data (struct value *arr)
1565 {
1566   struct type *type = value_type (arr);
1567
1568   if (is_thin_pntr (type))
1569     return thin_data_pntr (arr);
1570   else if (is_thick_pntr (type))
1571     return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1572                              _("Bad GNAT array descriptor"));
1573   else
1574     return NULL;
1575 }
1576
1577
1578 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1579    position of the field containing the address of the data.  */
1580
1581 static int
1582 fat_pntr_data_bitpos (struct type *type)
1583 {
1584   return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1585 }
1586
1587 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1588    size of the field containing the address of the data.  */
1589
1590 static int
1591 fat_pntr_data_bitsize (struct type *type)
1592 {
1593   type = desc_base_type (type);
1594
1595   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1596     return TYPE_FIELD_BITSIZE (type, 0);
1597   else
1598     return TARGET_CHAR_BIT * TYPE_LENGTH (type->field (0).type ());
1599 }
1600
1601 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1602    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1603    bound, if WHICH is 1.  The first bound is I=1.  */
1604
1605 static struct value *
1606 desc_one_bound (struct value *bounds, int i, int which)
1607 {
1608   char bound_name[20];
1609   xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1610              which ? 'U' : 'L', i - 1);
1611   return value_struct_elt (&bounds, NULL, bound_name, NULL,
1612                            _("Bad GNAT array descriptor bounds"));
1613 }
1614
1615 /* If BOUNDS is an array-bounds structure type, return the bit position
1616    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1617    bound, if WHICH is 1.  The first bound is I=1.  */
1618
1619 static int
1620 desc_bound_bitpos (struct type *type, int i, int which)
1621 {
1622   return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1623 }
1624
1625 /* If BOUNDS is an array-bounds structure type, return the bit field size
1626    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1627    bound, if WHICH is 1.  The first bound is I=1.  */
1628
1629 static int
1630 desc_bound_bitsize (struct type *type, int i, int which)
1631 {
1632   type = desc_base_type (type);
1633
1634   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1635     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1636   else
1637     return 8 * TYPE_LENGTH (type->field (2 * i + which - 2).type ());
1638 }
1639
1640 /* If TYPE is the type of an array-bounds structure, the type of its
1641    Ith bound (numbering from 1).  Otherwise, NULL.  */
1642
1643 static struct type *
1644 desc_index_type (struct type *type, int i)
1645 {
1646   type = desc_base_type (type);
1647
1648   if (type->code () == TYPE_CODE_STRUCT)
1649     {
1650       char bound_name[20];
1651       xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
1652       return lookup_struct_elt_type (type, bound_name, 1);
1653     }
1654   else
1655     return NULL;
1656 }
1657
1658 /* The number of index positions in the array-bounds type TYPE.
1659    Return 0 if TYPE is NULL.  */
1660
1661 static int
1662 desc_arity (struct type *type)
1663 {
1664   type = desc_base_type (type);
1665
1666   if (type != NULL)
1667     return type->num_fields () / 2;
1668   return 0;
1669 }
1670
1671 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
1672    an array descriptor type (representing an unconstrained array
1673    type).  */
1674
1675 static int
1676 ada_is_direct_array_type (struct type *type)
1677 {
1678   if (type == NULL)
1679     return 0;
1680   type = ada_check_typedef (type);
1681   return (type->code () == TYPE_CODE_ARRAY
1682           || ada_is_array_descriptor_type (type));
1683 }
1684
1685 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1686  * to one.  */
1687
1688 static int
1689 ada_is_array_type (struct type *type)
1690 {
1691   while (type != NULL
1692          && (type->code () == TYPE_CODE_PTR
1693              || type->code () == TYPE_CODE_REF))
1694     type = TYPE_TARGET_TYPE (type);
1695   return ada_is_direct_array_type (type);
1696 }
1697
1698 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
1699
1700 int
1701 ada_is_simple_array_type (struct type *type)
1702 {
1703   if (type == NULL)
1704     return 0;
1705   type = ada_check_typedef (type);
1706   return (type->code () == TYPE_CODE_ARRAY
1707           || (type->code () == TYPE_CODE_PTR
1708               && (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ()
1709                   == TYPE_CODE_ARRAY)));
1710 }
1711
1712 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
1713
1714 int
1715 ada_is_array_descriptor_type (struct type *type)
1716 {
1717   struct type *data_type = desc_data_target_type (type);
1718
1719   if (type == NULL)
1720     return 0;
1721   type = ada_check_typedef (type);
1722   return (data_type != NULL
1723           && data_type->code () == TYPE_CODE_ARRAY
1724           && desc_arity (desc_bounds_type (type)) > 0);
1725 }
1726
1727 /* Non-zero iff type is a partially mal-formed GNAT array
1728    descriptor.  FIXME: This is to compensate for some problems with
1729    debugging output from GNAT.  Re-examine periodically to see if it
1730    is still needed.  */
1731
1732 int
1733 ada_is_bogus_array_descriptor (struct type *type)
1734 {
1735   return
1736     type != NULL
1737     && type->code () == TYPE_CODE_STRUCT
1738     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1739         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1740     && !ada_is_array_descriptor_type (type);
1741 }
1742
1743
1744 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1745    (fat pointer) returns the type of the array data described---specifically,
1746    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
1747    in from the descriptor; otherwise, they are left unspecified.  If
1748    the ARR denotes a null array descriptor and BOUNDS is non-zero,
1749    returns NULL.  The result is simply the type of ARR if ARR is not
1750    a descriptor.  */
1751
1752 static struct type *
1753 ada_type_of_array (struct value *arr, int bounds)
1754 {
1755   if (ada_is_constrained_packed_array_type (value_type (arr)))
1756     return decode_constrained_packed_array_type (value_type (arr));
1757
1758   if (!ada_is_array_descriptor_type (value_type (arr)))
1759     return value_type (arr);
1760
1761   if (!bounds)
1762     {
1763       struct type *array_type =
1764         ada_check_typedef (desc_data_target_type (value_type (arr)));
1765
1766       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1767         TYPE_FIELD_BITSIZE (array_type, 0) =
1768           decode_packed_array_bitsize (value_type (arr));
1769       
1770       return array_type;
1771     }
1772   else
1773     {
1774       struct type *elt_type;
1775       int arity;
1776       struct value *descriptor;
1777
1778       elt_type = ada_array_element_type (value_type (arr), -1);
1779       arity = ada_array_arity (value_type (arr));
1780
1781       if (elt_type == NULL || arity == 0)
1782         return ada_check_typedef (value_type (arr));
1783
1784       descriptor = desc_bounds (arr);
1785       if (value_as_long (descriptor) == 0)
1786         return NULL;
1787       while (arity > 0)
1788         {
1789           struct type *range_type = alloc_type_copy (value_type (arr));
1790           struct type *array_type = alloc_type_copy (value_type (arr));
1791           struct value *low = desc_one_bound (descriptor, arity, 0);
1792           struct value *high = desc_one_bound (descriptor, arity, 1);
1793
1794           arity -= 1;
1795           create_static_range_type (range_type, value_type (low),
1796                                     longest_to_int (value_as_long (low)),
1797                                     longest_to_int (value_as_long (high)));
1798           elt_type = create_array_type (array_type, elt_type, range_type);
1799
1800           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1801             {
1802               /* We need to store the element packed bitsize, as well as
1803                  recompute the array size, because it was previously
1804                  computed based on the unpacked element size.  */
1805               LONGEST lo = value_as_long (low);
1806               LONGEST hi = value_as_long (high);
1807
1808               TYPE_FIELD_BITSIZE (elt_type, 0) =
1809                 decode_packed_array_bitsize (value_type (arr));
1810               /* If the array has no element, then the size is already
1811                  zero, and does not need to be recomputed.  */
1812               if (lo < hi)
1813                 {
1814                   int array_bitsize =
1815                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1816
1817                   TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1818                 }
1819             }
1820         }
1821
1822       return lookup_pointer_type (elt_type);
1823     }
1824 }
1825
1826 /* If ARR does not represent an array, returns ARR unchanged.
1827    Otherwise, returns either a standard GDB array with bounds set
1828    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1829    GDB array.  Returns NULL if ARR is a null fat pointer.  */
1830
1831 struct value *
1832 ada_coerce_to_simple_array_ptr (struct value *arr)
1833 {
1834   if (ada_is_array_descriptor_type (value_type (arr)))
1835     {
1836       struct type *arrType = ada_type_of_array (arr, 1);
1837
1838       if (arrType == NULL)
1839         return NULL;
1840       return value_cast (arrType, value_copy (desc_data (arr)));
1841     }
1842   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1843     return decode_constrained_packed_array (arr);
1844   else
1845     return arr;
1846 }
1847
1848 /* If ARR does not represent an array, returns ARR unchanged.
1849    Otherwise, returns a standard GDB array describing ARR (which may
1850    be ARR itself if it already is in the proper form).  */
1851
1852 struct value *
1853 ada_coerce_to_simple_array (struct value *arr)
1854 {
1855   if (ada_is_array_descriptor_type (value_type (arr)))
1856     {
1857       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1858
1859       if (arrVal == NULL)
1860         error (_("Bounds unavailable for null array pointer."));
1861       ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
1862       return value_ind (arrVal);
1863     }
1864   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1865     return decode_constrained_packed_array (arr);
1866   else
1867     return arr;
1868 }
1869
1870 /* If TYPE represents a GNAT array type, return it translated to an
1871    ordinary GDB array type (possibly with BITSIZE fields indicating
1872    packing).  For other types, is the identity.  */
1873
1874 struct type *
1875 ada_coerce_to_simple_array_type (struct type *type)
1876 {
1877   if (ada_is_constrained_packed_array_type (type))
1878     return decode_constrained_packed_array_type (type);
1879
1880   if (ada_is_array_descriptor_type (type))
1881     return ada_check_typedef (desc_data_target_type (type));
1882
1883   return type;
1884 }
1885
1886 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
1887
1888 static int
1889 ada_is_gnat_encoded_packed_array_type  (struct type *type)
1890 {
1891   if (type == NULL)
1892     return 0;
1893   type = desc_base_type (type);
1894   type = ada_check_typedef (type);
1895   return
1896     ada_type_name (type) != NULL
1897     && strstr (ada_type_name (type), "___XP") != NULL;
1898 }
1899
1900 /* Non-zero iff TYPE represents a standard GNAT constrained
1901    packed-array type.  */
1902
1903 int
1904 ada_is_constrained_packed_array_type (struct type *type)
1905 {
1906   return ada_is_gnat_encoded_packed_array_type (type)
1907     && !ada_is_array_descriptor_type (type);
1908 }
1909
1910 /* Non-zero iff TYPE represents an array descriptor for a
1911    unconstrained packed-array type.  */
1912
1913 static int
1914 ada_is_unconstrained_packed_array_type (struct type *type)
1915 {
1916   if (!ada_is_array_descriptor_type (type))
1917     return 0;
1918
1919   if (ada_is_gnat_encoded_packed_array_type (type))
1920     return 1;
1921
1922   /* If we saw GNAT encodings, then the above code is sufficient.
1923      However, with minimal encodings, we will just have a thick
1924      pointer instead.  */
1925   if (is_thick_pntr (type))
1926     {
1927       type = desc_base_type (type);
1928       /* The structure's first field is a pointer to an array, so this
1929          fetches the array type.  */
1930       type = TYPE_TARGET_TYPE (type->field (0).type ());
1931       /* Now we can see if the array elements are packed.  */
1932       return TYPE_FIELD_BITSIZE (type, 0) > 0;
1933     }
1934
1935   return 0;
1936 }
1937
1938 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
1939    type, or if it is an ordinary (non-Gnat-encoded) packed array.  */
1940
1941 static bool
1942 ada_is_any_packed_array_type (struct type *type)
1943 {
1944   return (ada_is_constrained_packed_array_type (type)
1945           || (type->code () == TYPE_CODE_ARRAY
1946               && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
1947 }
1948
1949 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
1950    return the size of its elements in bits.  */
1951
1952 static long
1953 decode_packed_array_bitsize (struct type *type)
1954 {
1955   const char *raw_name;
1956   const char *tail;
1957   long bits;
1958
1959   /* Access to arrays implemented as fat pointers are encoded as a typedef
1960      of the fat pointer type.  We need the name of the fat pointer type
1961      to do the decoding, so strip the typedef layer.  */
1962   if (type->code () == TYPE_CODE_TYPEDEF)
1963     type = ada_typedef_target_type (type);
1964
1965   raw_name = ada_type_name (ada_check_typedef (type));
1966   if (!raw_name)
1967     raw_name = ada_type_name (desc_base_type (type));
1968
1969   if (!raw_name)
1970     return 0;
1971
1972   tail = strstr (raw_name, "___XP");
1973   if (tail == nullptr)
1974     {
1975       gdb_assert (is_thick_pntr (type));
1976       /* The structure's first field is a pointer to an array, so this
1977          fetches the array type.  */
1978       type = TYPE_TARGET_TYPE (type->field (0).type ());
1979       /* Now we can see if the array elements are packed.  */
1980       return TYPE_FIELD_BITSIZE (type, 0);
1981     }
1982
1983   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1984     {
1985       lim_warning
1986         (_("could not understand bit size information on packed array"));
1987       return 0;
1988     }
1989
1990   return bits;
1991 }
1992
1993 /* Given that TYPE is a standard GDB array type with all bounds filled
1994    in, and that the element size of its ultimate scalar constituents
1995    (that is, either its elements, or, if it is an array of arrays, its
1996    elements' elements, etc.) is *ELT_BITS, return an identical type,
1997    but with the bit sizes of its elements (and those of any
1998    constituent arrays) recorded in the BITSIZE components of its
1999    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2000    in bits.
2001
2002    Note that, for arrays whose index type has an XA encoding where
2003    a bound references a record discriminant, getting that discriminant,
2004    and therefore the actual value of that bound, is not possible
2005    because none of the given parameters gives us access to the record.
2006    This function assumes that it is OK in the context where it is being
2007    used to return an array whose bounds are still dynamic and where
2008    the length is arbitrary.  */
2009
2010 static struct type *
2011 constrained_packed_array_type (struct type *type, long *elt_bits)
2012 {
2013   struct type *new_elt_type;
2014   struct type *new_type;
2015   struct type *index_type_desc;
2016   struct type *index_type;
2017   LONGEST low_bound, high_bound;
2018
2019   type = ada_check_typedef (type);
2020   if (type->code () != TYPE_CODE_ARRAY)
2021     return type;
2022
2023   index_type_desc = ada_find_parallel_type (type, "___XA");
2024   if (index_type_desc)
2025     index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2026                                       NULL);
2027   else
2028     index_type = type->index_type ();
2029
2030   new_type = alloc_type_copy (type);
2031   new_elt_type =
2032     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2033                                    elt_bits);
2034   create_array_type (new_type, new_elt_type, index_type);
2035   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2036   new_type->set_name (ada_type_name (type));
2037
2038   if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2039        && is_dynamic_type (check_typedef (index_type)))
2040       || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2041     low_bound = high_bound = 0;
2042   if (high_bound < low_bound)
2043     *elt_bits = TYPE_LENGTH (new_type) = 0;
2044   else
2045     {
2046       *elt_bits *= (high_bound - low_bound + 1);
2047       TYPE_LENGTH (new_type) =
2048         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2049     }
2050
2051   new_type->set_is_fixed_instance (true);
2052   return new_type;
2053 }
2054
2055 /* The array type encoded by TYPE, where
2056    ada_is_constrained_packed_array_type (TYPE).  */
2057
2058 static struct type *
2059 decode_constrained_packed_array_type (struct type *type)
2060 {
2061   const char *raw_name = ada_type_name (ada_check_typedef (type));
2062   char *name;
2063   const char *tail;
2064   struct type *shadow_type;
2065   long bits;
2066
2067   if (!raw_name)
2068     raw_name = ada_type_name (desc_base_type (type));
2069
2070   if (!raw_name)
2071     return NULL;
2072
2073   name = (char *) alloca (strlen (raw_name) + 1);
2074   tail = strstr (raw_name, "___XP");
2075   type = desc_base_type (type);
2076
2077   memcpy (name, raw_name, tail - raw_name);
2078   name[tail - raw_name] = '\000';
2079
2080   shadow_type = ada_find_parallel_type_with_name (type, name);
2081
2082   if (shadow_type == NULL)
2083     {
2084       lim_warning (_("could not find bounds information on packed array"));
2085       return NULL;
2086     }
2087   shadow_type = check_typedef (shadow_type);
2088
2089   if (shadow_type->code () != TYPE_CODE_ARRAY)
2090     {
2091       lim_warning (_("could not understand bounds "
2092                      "information on packed array"));
2093       return NULL;
2094     }
2095
2096   bits = decode_packed_array_bitsize (type);
2097   return constrained_packed_array_type (shadow_type, &bits);
2098 }
2099
2100 /* Helper function for decode_constrained_packed_array.  Set the field
2101    bitsize on a series of packed arrays.  Returns the number of
2102    elements in TYPE.  */
2103
2104 static LONGEST
2105 recursively_update_array_bitsize (struct type *type)
2106 {
2107   gdb_assert (type->code () == TYPE_CODE_ARRAY);
2108
2109   LONGEST low, high;
2110   if (!get_discrete_bounds (type->index_type (), &low, &high)
2111       || low > high)
2112     return 0;
2113   LONGEST our_len = high - low + 1;
2114
2115   struct type *elt_type = TYPE_TARGET_TYPE (type);
2116   if (elt_type->code () == TYPE_CODE_ARRAY)
2117     {
2118       LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2119       LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2120       TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2121
2122       TYPE_LENGTH (type) = ((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2123                             / HOST_CHAR_BIT);
2124     }
2125
2126   return our_len;
2127 }
2128
2129 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2130    array, returns a simple array that denotes that array.  Its type is a
2131    standard GDB array type except that the BITSIZEs of the array
2132    target types are set to the number of bits in each element, and the
2133    type length is set appropriately.  */
2134
2135 static struct value *
2136 decode_constrained_packed_array (struct value *arr)
2137 {
2138   struct type *type;
2139
2140   /* If our value is a pointer, then dereference it. Likewise if
2141      the value is a reference.  Make sure that this operation does not
2142      cause the target type to be fixed, as this would indirectly cause
2143      this array to be decoded.  The rest of the routine assumes that
2144      the array hasn't been decoded yet, so we use the basic "coerce_ref"
2145      and "value_ind" routines to perform the dereferencing, as opposed
2146      to using "ada_coerce_ref" or "ada_value_ind".  */
2147   arr = coerce_ref (arr);
2148   if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2149     arr = value_ind (arr);
2150
2151   type = decode_constrained_packed_array_type (value_type (arr));
2152   if (type == NULL)
2153     {
2154       error (_("can't unpack array"));
2155       return NULL;
2156     }
2157
2158   /* Decoding the packed array type could not correctly set the field
2159      bitsizes for any dimension except the innermost, because the
2160      bounds may be variable and were not passed to that function.  So,
2161      we further resolve the array bounds here and then update the
2162      sizes.  */
2163   const gdb_byte *valaddr = value_contents_for_printing (arr);
2164   CORE_ADDR address = value_address (arr);
2165   gdb::array_view<const gdb_byte> view
2166     = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
2167   type = resolve_dynamic_type (type, view, address);
2168   recursively_update_array_bitsize (type);
2169
2170   if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2171       && ada_is_modular_type (value_type (arr)))
2172     {
2173        /* This is a (right-justified) modular type representing a packed
2174          array with no wrapper.  In order to interpret the value through
2175          the (left-justified) packed array type we just built, we must
2176          first left-justify it.  */
2177       int bit_size, bit_pos;
2178       ULONGEST mod;
2179
2180       mod = ada_modulus (value_type (arr)) - 1;
2181       bit_size = 0;
2182       while (mod > 0)
2183         {
2184           bit_size += 1;
2185           mod >>= 1;
2186         }
2187       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2188       arr = ada_value_primitive_packed_val (arr, NULL,
2189                                             bit_pos / HOST_CHAR_BIT,
2190                                             bit_pos % HOST_CHAR_BIT,
2191                                             bit_size,
2192                                             type);
2193     }
2194
2195   return coerce_unspec_val_to_type (arr, type);
2196 }
2197
2198
2199 /* The value of the element of packed array ARR at the ARITY indices
2200    given in IND.   ARR must be a simple array.  */
2201
2202 static struct value *
2203 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2204 {
2205   int i;
2206   int bits, elt_off, bit_off;
2207   long elt_total_bit_offset;
2208   struct type *elt_type;
2209   struct value *v;
2210
2211   bits = 0;
2212   elt_total_bit_offset = 0;
2213   elt_type = ada_check_typedef (value_type (arr));
2214   for (i = 0; i < arity; i += 1)
2215     {
2216       if (elt_type->code () != TYPE_CODE_ARRAY
2217           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2218         error
2219           (_("attempt to do packed indexing of "
2220              "something other than a packed array"));
2221       else
2222         {
2223           struct type *range_type = elt_type->index_type ();
2224           LONGEST lowerbound, upperbound;
2225           LONGEST idx;
2226
2227           if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2228             {
2229               lim_warning (_("don't know bounds of array"));
2230               lowerbound = upperbound = 0;
2231             }
2232
2233           idx = pos_atr (ind[i]);
2234           if (idx < lowerbound || idx > upperbound)
2235             lim_warning (_("packed array index %ld out of bounds"),
2236                          (long) idx);
2237           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2238           elt_total_bit_offset += (idx - lowerbound) * bits;
2239           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2240         }
2241     }
2242   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2243   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2244
2245   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2246                                       bits, elt_type);
2247   return v;
2248 }
2249
2250 /* Non-zero iff TYPE includes negative integer values.  */
2251
2252 static int
2253 has_negatives (struct type *type)
2254 {
2255   switch (type->code ())
2256     {
2257     default:
2258       return 0;
2259     case TYPE_CODE_INT:
2260       return !type->is_unsigned ();
2261     case TYPE_CODE_RANGE:
2262       return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2263     }
2264 }
2265
2266 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2267    unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
2268    the unpacked buffer.
2269
2270    The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2271    enough to contain at least BIT_OFFSET bits.  If not, an error is raised.
2272
2273    IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2274    zero otherwise.
2275
2276    IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2277
2278    IS_SCALAR is nonzero if the data corresponds to a signed type.  */
2279
2280 static void
2281 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2282                           gdb_byte *unpacked, int unpacked_len,
2283                           int is_big_endian, int is_signed_type,
2284                           int is_scalar)
2285 {
2286   int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2287   int src_idx;                  /* Index into the source area */
2288   int src_bytes_left;           /* Number of source bytes left to process.  */
2289   int srcBitsLeft;              /* Number of source bits left to move */
2290   int unusedLS;                 /* Number of bits in next significant
2291                                    byte of source that are unused */
2292
2293   int unpacked_idx;             /* Index into the unpacked buffer */
2294   int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */
2295
2296   unsigned long accum;          /* Staging area for bits being transferred */
2297   int accumSize;                /* Number of meaningful bits in accum */
2298   unsigned char sign;
2299
2300   /* Transmit bytes from least to most significant; delta is the direction
2301      the indices move.  */
2302   int delta = is_big_endian ? -1 : 1;
2303
2304   /* Make sure that unpacked is large enough to receive the BIT_SIZE
2305      bits from SRC.  .*/
2306   if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2307     error (_("Cannot unpack %d bits into buffer of %d bytes"),
2308            bit_size, unpacked_len);
2309
2310   srcBitsLeft = bit_size;
2311   src_bytes_left = src_len;
2312   unpacked_bytes_left = unpacked_len;
2313   sign = 0;
2314
2315   if (is_big_endian)
2316     {
2317       src_idx = src_len - 1;
2318       if (is_signed_type
2319           && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2320         sign = ~0;
2321
2322       unusedLS =
2323         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2324         % HOST_CHAR_BIT;
2325
2326       if (is_scalar)
2327         {
2328           accumSize = 0;
2329           unpacked_idx = unpacked_len - 1;
2330         }
2331       else
2332         {
2333           /* Non-scalar values must be aligned at a byte boundary...  */
2334           accumSize =
2335             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2336           /* ... And are placed at the beginning (most-significant) bytes
2337              of the target.  */
2338           unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2339           unpacked_bytes_left = unpacked_idx + 1;
2340         }
2341     }
2342   else
2343     {
2344       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2345
2346       src_idx = unpacked_idx = 0;
2347       unusedLS = bit_offset;
2348       accumSize = 0;
2349
2350       if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2351         sign = ~0;
2352     }
2353
2354   accum = 0;
2355   while (src_bytes_left > 0)
2356     {
2357       /* Mask for removing bits of the next source byte that are not
2358          part of the value.  */
2359       unsigned int unusedMSMask =
2360         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2361         1;
2362       /* Sign-extend bits for this byte.  */
2363       unsigned int signMask = sign & ~unusedMSMask;
2364
2365       accum |=
2366         (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2367       accumSize += HOST_CHAR_BIT - unusedLS;
2368       if (accumSize >= HOST_CHAR_BIT)
2369         {
2370           unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2371           accumSize -= HOST_CHAR_BIT;
2372           accum >>= HOST_CHAR_BIT;
2373           unpacked_bytes_left -= 1;
2374           unpacked_idx += delta;
2375         }
2376       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2377       unusedLS = 0;
2378       src_bytes_left -= 1;
2379       src_idx += delta;
2380     }
2381   while (unpacked_bytes_left > 0)
2382     {
2383       accum |= sign << accumSize;
2384       unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2385       accumSize -= HOST_CHAR_BIT;
2386       if (accumSize < 0)
2387         accumSize = 0;
2388       accum >>= HOST_CHAR_BIT;
2389       unpacked_bytes_left -= 1;
2390       unpacked_idx += delta;
2391     }
2392 }
2393
2394 /* Create a new value of type TYPE from the contents of OBJ starting
2395    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2396    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2397    assigning through the result will set the field fetched from.
2398    VALADDR is ignored unless OBJ is NULL, in which case,
2399    VALADDR+OFFSET must address the start of storage containing the 
2400    packed value.  The value returned  in this case is never an lval.
2401    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2402
2403 struct value *
2404 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2405                                 long offset, int bit_offset, int bit_size,
2406                                 struct type *type)
2407 {
2408   struct value *v;
2409   const gdb_byte *src;                /* First byte containing data to unpack */
2410   gdb_byte *unpacked;
2411   const int is_scalar = is_scalar_type (type);
2412   const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2413   gdb::byte_vector staging;
2414
2415   type = ada_check_typedef (type);
2416
2417   if (obj == NULL)
2418     src = valaddr + offset;
2419   else
2420     src = value_contents (obj) + offset;
2421
2422   if (is_dynamic_type (type))
2423     {
2424       /* The length of TYPE might by dynamic, so we need to resolve
2425          TYPE in order to know its actual size, which we then use
2426          to create the contents buffer of the value we return.
2427          The difficulty is that the data containing our object is
2428          packed, and therefore maybe not at a byte boundary.  So, what
2429          we do, is unpack the data into a byte-aligned buffer, and then
2430          use that buffer as our object's value for resolving the type.  */
2431       int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2432       staging.resize (staging_len);
2433
2434       ada_unpack_from_contents (src, bit_offset, bit_size,
2435                                 staging.data (), staging.size (),
2436                                 is_big_endian, has_negatives (type),
2437                                 is_scalar);
2438       type = resolve_dynamic_type (type, staging, 0);
2439       if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2440         {
2441           /* This happens when the length of the object is dynamic,
2442              and is actually smaller than the space reserved for it.
2443              For instance, in an array of variant records, the bit_size
2444              we're given is the array stride, which is constant and
2445              normally equal to the maximum size of its element.
2446              But, in reality, each element only actually spans a portion
2447              of that stride.  */
2448           bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2449         }
2450     }
2451
2452   if (obj == NULL)
2453     {
2454       v = allocate_value (type);
2455       src = valaddr + offset;
2456     }
2457   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2458     {
2459       int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2460       gdb_byte *buf;
2461
2462       v = value_at (type, value_address (obj) + offset);
2463       buf = (gdb_byte *) alloca (src_len);
2464       read_memory (value_address (v), buf, src_len);
2465       src = buf;
2466     }
2467   else
2468     {
2469       v = allocate_value (type);
2470       src = value_contents (obj) + offset;
2471     }
2472
2473   if (obj != NULL)
2474     {
2475       long new_offset = offset;
2476
2477       set_value_component_location (v, obj);
2478       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2479       set_value_bitsize (v, bit_size);
2480       if (value_bitpos (v) >= HOST_CHAR_BIT)
2481         {
2482           ++new_offset;
2483           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2484         }
2485       set_value_offset (v, new_offset);
2486
2487       /* Also set the parent value.  This is needed when trying to
2488          assign a new value (in inferior memory).  */
2489       set_value_parent (v, obj);
2490     }
2491   else
2492     set_value_bitsize (v, bit_size);
2493   unpacked = value_contents_writeable (v);
2494
2495   if (bit_size == 0)
2496     {
2497       memset (unpacked, 0, TYPE_LENGTH (type));
2498       return v;
2499     }
2500
2501   if (staging.size () == TYPE_LENGTH (type))
2502     {
2503       /* Small short-cut: If we've unpacked the data into a buffer
2504          of the same size as TYPE's length, then we can reuse that,
2505          instead of doing the unpacking again.  */
2506       memcpy (unpacked, staging.data (), staging.size ());
2507     }
2508   else
2509     ada_unpack_from_contents (src, bit_offset, bit_size,
2510                               unpacked, TYPE_LENGTH (type),
2511                               is_big_endian, has_negatives (type), is_scalar);
2512
2513   return v;
2514 }
2515
2516 /* Store the contents of FROMVAL into the location of TOVAL.
2517    Return a new value with the location of TOVAL and contents of
2518    FROMVAL.   Handles assignment into packed fields that have
2519    floating-point or non-scalar types.  */
2520
2521 static struct value *
2522 ada_value_assign (struct value *toval, struct value *fromval)
2523 {
2524   struct type *type = value_type (toval);
2525   int bits = value_bitsize (toval);
2526
2527   toval = ada_coerce_ref (toval);
2528   fromval = ada_coerce_ref (fromval);
2529
2530   if (ada_is_direct_array_type (value_type (toval)))
2531     toval = ada_coerce_to_simple_array (toval);
2532   if (ada_is_direct_array_type (value_type (fromval)))
2533     fromval = ada_coerce_to_simple_array (fromval);
2534
2535   if (!deprecated_value_modifiable (toval))
2536     error (_("Left operand of assignment is not a modifiable lvalue."));
2537
2538   if (VALUE_LVAL (toval) == lval_memory
2539       && bits > 0
2540       && (type->code () == TYPE_CODE_FLT
2541           || type->code () == TYPE_CODE_STRUCT))
2542     {
2543       int len = (value_bitpos (toval)
2544                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2545       int from_size;
2546       gdb_byte *buffer = (gdb_byte *) alloca (len);
2547       struct value *val;
2548       CORE_ADDR to_addr = value_address (toval);
2549
2550       if (type->code () == TYPE_CODE_FLT)
2551         fromval = value_cast (type, fromval);
2552
2553       read_memory (to_addr, buffer, len);
2554       from_size = value_bitsize (fromval);
2555       if (from_size == 0)
2556         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2557
2558       const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2559       ULONGEST from_offset = 0;
2560       if (is_big_endian && is_scalar_type (value_type (fromval)))
2561         from_offset = from_size - bits;
2562       copy_bitwise (buffer, value_bitpos (toval),
2563                     value_contents (fromval), from_offset,
2564                     bits, is_big_endian);
2565       write_memory_with_notification (to_addr, buffer, len);
2566
2567       val = value_copy (toval);
2568       memcpy (value_contents_raw (val), value_contents (fromval),
2569               TYPE_LENGTH (type));
2570       deprecated_set_value_type (val, type);
2571
2572       return val;
2573     }
2574
2575   return value_assign (toval, fromval);
2576 }
2577
2578
2579 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2580    CONTAINER, assign the contents of VAL to COMPONENTS's place in
2581    CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2582    COMPONENT, and not the inferior's memory.  The current contents
2583    of COMPONENT are ignored.
2584
2585    Although not part of the initial design, this function also works
2586    when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2587    had a null address, and COMPONENT had an address which is equal to
2588    its offset inside CONTAINER.  */
2589
2590 static void
2591 value_assign_to_component (struct value *container, struct value *component,
2592                            struct value *val)
2593 {
2594   LONGEST offset_in_container =
2595     (LONGEST)  (value_address (component) - value_address (container));
2596   int bit_offset_in_container =
2597     value_bitpos (component) - value_bitpos (container);
2598   int bits;
2599
2600   val = value_cast (value_type (component), val);
2601
2602   if (value_bitsize (component) == 0)
2603     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2604   else
2605     bits = value_bitsize (component);
2606
2607   if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2608     {
2609       int src_offset;
2610
2611       if (is_scalar_type (check_typedef (value_type (component))))
2612         src_offset
2613           = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2614       else
2615         src_offset = 0;
2616       copy_bitwise (value_contents_writeable (container) + offset_in_container,
2617                     value_bitpos (container) + bit_offset_in_container,
2618                     value_contents (val), src_offset, bits, 1);
2619     }
2620   else
2621     copy_bitwise (value_contents_writeable (container) + offset_in_container,
2622                   value_bitpos (container) + bit_offset_in_container,
2623                   value_contents (val), 0, bits, 0);
2624 }
2625
2626 /* Determine if TYPE is an access to an unconstrained array.  */
2627
2628 bool
2629 ada_is_access_to_unconstrained_array (struct type *type)
2630 {
2631   return (type->code () == TYPE_CODE_TYPEDEF
2632           && is_thick_pntr (ada_typedef_target_type (type)));
2633 }
2634
2635 /* The value of the element of array ARR at the ARITY indices given in IND.
2636    ARR may be either a simple array, GNAT array descriptor, or pointer
2637    thereto.  */
2638
2639 struct value *
2640 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2641 {
2642   int k;
2643   struct value *elt;
2644   struct type *elt_type;
2645
2646   elt = ada_coerce_to_simple_array (arr);
2647
2648   elt_type = ada_check_typedef (value_type (elt));
2649   if (elt_type->code () == TYPE_CODE_ARRAY
2650       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2651     return value_subscript_packed (elt, arity, ind);
2652
2653   for (k = 0; k < arity; k += 1)
2654     {
2655       struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
2656
2657       if (elt_type->code () != TYPE_CODE_ARRAY)
2658         error (_("too many subscripts (%d expected)"), k);
2659
2660       elt = value_subscript (elt, pos_atr (ind[k]));
2661
2662       if (ada_is_access_to_unconstrained_array (saved_elt_type)
2663           && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
2664         {
2665           /* The element is a typedef to an unconstrained array,
2666              except that the value_subscript call stripped the
2667              typedef layer.  The typedef layer is GNAT's way to
2668              specify that the element is, at the source level, an
2669              access to the unconstrained array, rather than the
2670              unconstrained array.  So, we need to restore that
2671              typedef layer, which we can do by forcing the element's
2672              type back to its original type. Otherwise, the returned
2673              value is going to be printed as the array, rather
2674              than as an access.  Another symptom of the same issue
2675              would be that an expression trying to dereference the
2676              element would also be improperly rejected.  */
2677           deprecated_set_value_type (elt, saved_elt_type);
2678         }
2679
2680       elt_type = ada_check_typedef (value_type (elt));
2681     }
2682
2683   return elt;
2684 }
2685
2686 /* Assuming ARR is a pointer to a GDB array, the value of the element
2687    of *ARR at the ARITY indices given in IND.
2688    Does not read the entire array into memory.
2689
2690    Note: Unlike what one would expect, this function is used instead of
2691    ada_value_subscript for basically all non-packed array types.  The reason
2692    for this is that a side effect of doing our own pointer arithmetics instead
2693    of relying on value_subscript is that there is no implicit typedef peeling.
2694    This is important for arrays of array accesses, where it allows us to
2695    preserve the fact that the array's element is an array access, where the
2696    access part os encoded in a typedef layer.  */
2697
2698 static struct value *
2699 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2700 {
2701   int k;
2702   struct value *array_ind = ada_value_ind (arr);
2703   struct type *type
2704     = check_typedef (value_enclosing_type (array_ind));
2705
2706   if (type->code () == TYPE_CODE_ARRAY
2707       && TYPE_FIELD_BITSIZE (type, 0) > 0)
2708     return value_subscript_packed (array_ind, arity, ind);
2709
2710   for (k = 0; k < arity; k += 1)
2711     {
2712       LONGEST lwb, upb;
2713
2714       if (type->code () != TYPE_CODE_ARRAY)
2715         error (_("too many subscripts (%d expected)"), k);
2716       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2717                         value_copy (arr));
2718       get_discrete_bounds (type->index_type (), &lwb, &upb);
2719       arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
2720       type = TYPE_TARGET_TYPE (type);
2721     }
2722
2723   return value_ind (arr);
2724 }
2725
2726 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2727    actual type of ARRAY_PTR is ignored), returns the Ada slice of
2728    HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
2729    this array is LOW, as per Ada rules.  */
2730 static struct value *
2731 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2732                           int low, int high)
2733 {
2734   struct type *type0 = ada_check_typedef (type);
2735   struct type *base_index_type = TYPE_TARGET_TYPE (type0->index_type ());
2736   struct type *index_type
2737     = create_static_range_type (NULL, base_index_type, low, high);
2738   struct type *slice_type = create_array_type_with_stride
2739                               (NULL, TYPE_TARGET_TYPE (type0), index_type,
2740                                type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
2741                                TYPE_FIELD_BITSIZE (type0, 0));
2742   int base_low =  ada_discrete_type_low_bound (type0->index_type ());
2743   gdb::optional<LONGEST> base_low_pos, low_pos;
2744   CORE_ADDR base;
2745
2746   low_pos = discrete_position (base_index_type, low);
2747   base_low_pos = discrete_position (base_index_type, base_low);
2748
2749   if (!low_pos.has_value () || !base_low_pos.has_value ())
2750     {
2751       warning (_("unable to get positions in slice, use bounds instead"));
2752       low_pos = low;
2753       base_low_pos = base_low;
2754     }
2755
2756   ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
2757   if (stride == 0)
2758     stride = TYPE_LENGTH (TYPE_TARGET_TYPE (type0));
2759
2760   base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
2761   return value_at_lazy (slice_type, base);
2762 }
2763
2764
2765 static struct value *
2766 ada_value_slice (struct value *array, int low, int high)
2767 {
2768   struct type *type = ada_check_typedef (value_type (array));
2769   struct type *base_index_type = TYPE_TARGET_TYPE (type->index_type ());
2770   struct type *index_type
2771     = create_static_range_type (NULL, type->index_type (), low, high);
2772   struct type *slice_type = create_array_type_with_stride
2773                               (NULL, TYPE_TARGET_TYPE (type), index_type,
2774                                type->dyn_prop (DYN_PROP_BYTE_STRIDE),
2775                                TYPE_FIELD_BITSIZE (type, 0));
2776   gdb::optional<LONGEST> low_pos, high_pos;
2777
2778
2779   low_pos = discrete_position (base_index_type, low);
2780   high_pos = discrete_position (base_index_type, high);
2781
2782   if (!low_pos.has_value () || !high_pos.has_value ())
2783     {
2784       warning (_("unable to get positions in slice, use bounds instead"));
2785       low_pos = low;
2786       high_pos = high;
2787     }
2788
2789   return value_cast (slice_type,
2790                      value_slice (array, low, *high_pos - *low_pos + 1));
2791 }
2792
2793 /* If type is a record type in the form of a standard GNAT array
2794    descriptor, returns the number of dimensions for type.  If arr is a
2795    simple array, returns the number of "array of"s that prefix its
2796    type designation.  Otherwise, returns 0.  */
2797
2798 int
2799 ada_array_arity (struct type *type)
2800 {
2801   int arity;
2802
2803   if (type == NULL)
2804     return 0;
2805
2806   type = desc_base_type (type);
2807
2808   arity = 0;
2809   if (type->code () == TYPE_CODE_STRUCT)
2810     return desc_arity (desc_bounds_type (type));
2811   else
2812     while (type->code () == TYPE_CODE_ARRAY)
2813       {
2814         arity += 1;
2815         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2816       }
2817
2818   return arity;
2819 }
2820
2821 /* If TYPE is a record type in the form of a standard GNAT array
2822    descriptor or a simple array type, returns the element type for
2823    TYPE after indexing by NINDICES indices, or by all indices if
2824    NINDICES is -1.  Otherwise, returns NULL.  */
2825
2826 struct type *
2827 ada_array_element_type (struct type *type, int nindices)
2828 {
2829   type = desc_base_type (type);
2830
2831   if (type->code () == TYPE_CODE_STRUCT)
2832     {
2833       int k;
2834       struct type *p_array_type;
2835
2836       p_array_type = desc_data_target_type (type);
2837
2838       k = ada_array_arity (type);
2839       if (k == 0)
2840         return NULL;
2841
2842       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
2843       if (nindices >= 0 && k > nindices)
2844         k = nindices;
2845       while (k > 0 && p_array_type != NULL)
2846         {
2847           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2848           k -= 1;
2849         }
2850       return p_array_type;
2851     }
2852   else if (type->code () == TYPE_CODE_ARRAY)
2853     {
2854       while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
2855         {
2856           type = TYPE_TARGET_TYPE (type);
2857           nindices -= 1;
2858         }
2859       return type;
2860     }
2861
2862   return NULL;
2863 }
2864
2865 /* See ada-lang.h.  */
2866
2867 struct type *
2868 ada_index_type (struct type *type, int n, const char *name)
2869 {
2870   struct type *result_type;
2871
2872   type = desc_base_type (type);
2873
2874   if (n < 0 || n > ada_array_arity (type))
2875     error (_("invalid dimension number to '%s"), name);
2876
2877   if (ada_is_simple_array_type (type))
2878     {
2879       int i;
2880
2881       for (i = 1; i < n; i += 1)
2882         type = TYPE_TARGET_TYPE (type);
2883       result_type = TYPE_TARGET_TYPE (type->index_type ());
2884       /* FIXME: The stabs type r(0,0);bound;bound in an array type
2885          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
2886          perhaps stabsread.c would make more sense.  */
2887       if (result_type && result_type->code () == TYPE_CODE_UNDEF)
2888         result_type = NULL;
2889     }
2890   else
2891     {
2892       result_type = desc_index_type (desc_bounds_type (type), n);
2893       if (result_type == NULL)
2894         error (_("attempt to take bound of something that is not an array"));
2895     }
2896
2897   return result_type;
2898 }
2899
2900 /* Given that arr is an array type, returns the lower bound of the
2901    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2902    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
2903    array-descriptor type.  It works for other arrays with bounds supplied
2904    by run-time quantities other than discriminants.  */
2905
2906 static LONGEST
2907 ada_array_bound_from_type (struct type *arr_type, int n, int which)
2908 {
2909   struct type *type, *index_type_desc, *index_type;
2910   int i;
2911
2912   gdb_assert (which == 0 || which == 1);
2913
2914   if (ada_is_constrained_packed_array_type (arr_type))
2915     arr_type = decode_constrained_packed_array_type (arr_type);
2916
2917   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2918     return (LONGEST) - which;
2919
2920   if (arr_type->code () == TYPE_CODE_PTR)
2921     type = TYPE_TARGET_TYPE (arr_type);
2922   else
2923     type = arr_type;
2924
2925   if (type->is_fixed_instance ())
2926     {
2927       /* The array has already been fixed, so we do not need to
2928          check the parallel ___XA type again.  That encoding has
2929          already been applied, so ignore it now.  */
2930       index_type_desc = NULL;
2931     }
2932   else
2933     {
2934       index_type_desc = ada_find_parallel_type (type, "___XA");
2935       ada_fixup_array_indexes_type (index_type_desc);
2936     }
2937
2938   if (index_type_desc != NULL)
2939     index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
2940                                       NULL);
2941   else
2942     {
2943       struct type *elt_type = check_typedef (type);
2944
2945       for (i = 1; i < n; i++)
2946         elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
2947
2948       index_type = elt_type->index_type ();
2949     }
2950
2951   return
2952     (LONGEST) (which == 0
2953                ? ada_discrete_type_low_bound (index_type)
2954                : ada_discrete_type_high_bound (index_type));
2955 }
2956
2957 /* Given that arr is an array value, returns the lower bound of the
2958    nth index (numbering from 1) if WHICH is 0, and the upper bound if
2959    WHICH is 1.  This routine will also work for arrays with bounds
2960    supplied by run-time quantities other than discriminants.  */
2961
2962 static LONGEST
2963 ada_array_bound (struct value *arr, int n, int which)
2964 {
2965   struct type *arr_type;
2966
2967   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2968     arr = value_ind (arr);
2969   arr_type = value_enclosing_type (arr);
2970
2971   if (ada_is_constrained_packed_array_type (arr_type))
2972     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
2973   else if (ada_is_simple_array_type (arr_type))
2974     return ada_array_bound_from_type (arr_type, n, which);
2975   else
2976     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
2977 }
2978
2979 /* Given that arr is an array value, returns the length of the
2980    nth index.  This routine will also work for arrays with bounds
2981    supplied by run-time quantities other than discriminants.
2982    Does not work for arrays indexed by enumeration types with representation
2983    clauses at the moment.  */
2984
2985 static LONGEST
2986 ada_array_length (struct value *arr, int n)
2987 {
2988   struct type *arr_type, *index_type;
2989   int low, high;
2990
2991   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2992     arr = value_ind (arr);
2993   arr_type = value_enclosing_type (arr);
2994
2995   if (ada_is_constrained_packed_array_type (arr_type))
2996     return ada_array_length (decode_constrained_packed_array (arr), n);
2997
2998   if (ada_is_simple_array_type (arr_type))
2999     {
3000       low = ada_array_bound_from_type (arr_type, n, 0);
3001       high = ada_array_bound_from_type (arr_type, n, 1);
3002     }
3003   else
3004     {
3005       low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3006       high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3007     }
3008
3009   arr_type = check_typedef (arr_type);
3010   index_type = ada_index_type (arr_type, n, "length");
3011   if (index_type != NULL)
3012     {
3013       struct type *base_type;
3014       if (index_type->code () == TYPE_CODE_RANGE)
3015         base_type = TYPE_TARGET_TYPE (index_type);
3016       else
3017         base_type = index_type;
3018
3019       low = pos_atr (value_from_longest (base_type, low));
3020       high = pos_atr (value_from_longest (base_type, high));
3021     }
3022   return high - low + 1;
3023 }
3024
3025 /* An array whose type is that of ARR_TYPE (an array type), with
3026    bounds LOW to HIGH, but whose contents are unimportant.  If HIGH is
3027    less than LOW, then LOW-1 is used.  */
3028
3029 static struct value *
3030 empty_array (struct type *arr_type, int low, int high)
3031 {
3032   struct type *arr_type0 = ada_check_typedef (arr_type);
3033   struct type *index_type
3034     = create_static_range_type
3035         (NULL, TYPE_TARGET_TYPE (arr_type0->index_type ()), low,
3036          high < low ? low - 1 : high);
3037   struct type *elt_type = ada_array_element_type (arr_type0, 1);
3038
3039   return allocate_value (create_array_type (NULL, elt_type, index_type));
3040 }
3041 \f
3042
3043                                 /* Name resolution */
3044
3045 /* The "decoded" name for the user-definable Ada operator corresponding
3046    to OP.  */
3047
3048 static const char *
3049 ada_decoded_op_name (enum exp_opcode op)
3050 {
3051   int i;
3052
3053   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3054     {
3055       if (ada_opname_table[i].op == op)
3056         return ada_opname_table[i].decoded;
3057     }
3058   error (_("Could not find operator name for opcode"));
3059 }
3060
3061 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3062    in a listing of choices during disambiguation (see sort_choices, below).
3063    The idea is that overloadings of a subprogram name from the
3064    same package should sort in their source order.  We settle for ordering
3065    such symbols by their trailing number (__N  or $N).  */
3066
3067 static int
3068 encoded_ordered_before (const char *N0, const char *N1)
3069 {
3070   if (N1 == NULL)
3071     return 0;
3072   else if (N0 == NULL)
3073     return 1;
3074   else
3075     {
3076       int k0, k1;
3077
3078       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3079         ;
3080       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3081         ;
3082       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3083           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3084         {
3085           int n0, n1;
3086
3087           n0 = k0;
3088           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3089             n0 -= 1;
3090           n1 = k1;
3091           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3092             n1 -= 1;
3093           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3094             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3095         }
3096       return (strcmp (N0, N1) < 0);
3097     }
3098 }
3099
3100 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3101    encoded names.  */
3102
3103 static void
3104 sort_choices (struct block_symbol syms[], int nsyms)
3105 {
3106   int i;
3107
3108   for (i = 1; i < nsyms; i += 1)
3109     {
3110       struct block_symbol sym = syms[i];
3111       int j;
3112
3113       for (j = i - 1; j >= 0; j -= 1)
3114         {
3115           if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3116                                       sym.symbol->linkage_name ()))
3117             break;
3118           syms[j + 1] = syms[j];
3119         }
3120       syms[j + 1] = sym;
3121     }
3122 }
3123
3124 /* Whether GDB should display formals and return types for functions in the
3125    overloads selection menu.  */
3126 static bool print_signatures = true;
3127
3128 /* Print the signature for SYM on STREAM according to the FLAGS options.  For
3129    all but functions, the signature is just the name of the symbol.  For
3130    functions, this is the name of the function, the list of types for formals
3131    and the return type (if any).  */
3132
3133 static void
3134 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3135                             const struct type_print_options *flags)
3136 {
3137   struct type *type = SYMBOL_TYPE (sym);
3138
3139   fprintf_filtered (stream, "%s", sym->print_name ());
3140   if (!print_signatures
3141       || type == NULL
3142       || type->code () != TYPE_CODE_FUNC)
3143     return;
3144
3145   if (type->num_fields () > 0)
3146     {
3147       int i;
3148
3149       fprintf_filtered (stream, " (");
3150       for (i = 0; i < type->num_fields (); ++i)
3151         {
3152           if (i > 0)
3153             fprintf_filtered (stream, "; ");
3154           ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3155                           flags);
3156         }
3157       fprintf_filtered (stream, ")");
3158     }
3159   if (TYPE_TARGET_TYPE (type) != NULL
3160       && TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_VOID)
3161     {
3162       fprintf_filtered (stream, " return ");
3163       ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3164     }
3165 }
3166
3167 /* Read and validate a set of numeric choices from the user in the
3168    range 0 .. N_CHOICES-1.  Place the results in increasing
3169    order in CHOICES[0 .. N-1], and return N.
3170
3171    The user types choices as a sequence of numbers on one line
3172    separated by blanks, encoding them as follows:
3173
3174      + A choice of 0 means to cancel the selection, throwing an error.
3175      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3176      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3177
3178    The user is not allowed to choose more than MAX_RESULTS values.
3179
3180    ANNOTATION_SUFFIX, if present, is used to annotate the input
3181    prompts (for use with the -f switch).  */
3182
3183 static int
3184 get_selections (int *choices, int n_choices, int max_results,
3185                 int is_all_choice, const char *annotation_suffix)
3186 {
3187   const char *args;
3188   const char *prompt;
3189   int n_chosen;
3190   int first_choice = is_all_choice ? 2 : 1;
3191
3192   prompt = getenv ("PS2");
3193   if (prompt == NULL)
3194     prompt = "> ";
3195
3196   args = command_line_input (prompt, annotation_suffix);
3197
3198   if (args == NULL)
3199     error_no_arg (_("one or more choice numbers"));
3200
3201   n_chosen = 0;
3202
3203   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3204      order, as given in args.  Choices are validated.  */
3205   while (1)
3206     {
3207       char *args2;
3208       int choice, j;
3209
3210       args = skip_spaces (args);
3211       if (*args == '\0' && n_chosen == 0)
3212         error_no_arg (_("one or more choice numbers"));
3213       else if (*args == '\0')
3214         break;
3215
3216       choice = strtol (args, &args2, 10);
3217       if (args == args2 || choice < 0
3218           || choice > n_choices + first_choice - 1)
3219         error (_("Argument must be choice number"));
3220       args = args2;
3221
3222       if (choice == 0)
3223         error (_("cancelled"));
3224
3225       if (choice < first_choice)
3226         {
3227           n_chosen = n_choices;
3228           for (j = 0; j < n_choices; j += 1)
3229             choices[j] = j;
3230           break;
3231         }
3232       choice -= first_choice;
3233
3234       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3235         {
3236         }
3237
3238       if (j < 0 || choice != choices[j])
3239         {
3240           int k;
3241
3242           for (k = n_chosen - 1; k > j; k -= 1)
3243             choices[k + 1] = choices[k];
3244           choices[j + 1] = choice;
3245           n_chosen += 1;
3246         }
3247     }
3248
3249   if (n_chosen > max_results)
3250     error (_("Select no more than %d of the above"), max_results);
3251
3252   return n_chosen;
3253 }
3254
3255 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3256    by asking the user (if necessary), returning the number selected,
3257    and setting the first elements of SYMS items.  Error if no symbols
3258    selected.  */
3259
3260 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3261    to be re-integrated one of these days.  */
3262
3263 static int
3264 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3265 {
3266   int i;
3267   int *chosen = XALLOCAVEC (int , nsyms);
3268   int n_chosen;
3269   int first_choice = (max_results == 1) ? 1 : 2;
3270   const char *select_mode = multiple_symbols_select_mode ();
3271
3272   if (max_results < 1)
3273     error (_("Request to select 0 symbols!"));
3274   if (nsyms <= 1)
3275     return nsyms;
3276
3277   if (select_mode == multiple_symbols_cancel)
3278     error (_("\
3279 canceled because the command is ambiguous\n\
3280 See set/show multiple-symbol."));
3281
3282   /* If select_mode is "all", then return all possible symbols.
3283      Only do that if more than one symbol can be selected, of course.
3284      Otherwise, display the menu as usual.  */
3285   if (select_mode == multiple_symbols_all && max_results > 1)
3286     return nsyms;
3287
3288   printf_filtered (_("[0] cancel\n"));
3289   if (max_results > 1)
3290     printf_filtered (_("[1] all\n"));
3291
3292   sort_choices (syms, nsyms);
3293
3294   for (i = 0; i < nsyms; i += 1)
3295     {
3296       if (syms[i].symbol == NULL)
3297         continue;
3298
3299       if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
3300         {
3301           struct symtab_and_line sal =
3302             find_function_start_sal (syms[i].symbol, 1);
3303
3304           printf_filtered ("[%d] ", i + first_choice);
3305           ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3306                                       &type_print_raw_options);
3307           if (sal.symtab == NULL)
3308             printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3309                              metadata_style.style ().ptr (), nullptr, sal.line);
3310           else
3311             printf_filtered
3312               (_(" at %ps:%d\n"),
3313                styled_string (file_name_style.style (),
3314                               symtab_to_filename_for_display (sal.symtab)),
3315                sal.line);
3316           continue;
3317         }
3318       else
3319         {
3320           int is_enumeral =
3321             (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3322              && SYMBOL_TYPE (syms[i].symbol) != NULL
3323              && SYMBOL_TYPE (syms[i].symbol)->code () == TYPE_CODE_ENUM);
3324           struct symtab *symtab = NULL;
3325
3326           if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3327             symtab = symbol_symtab (syms[i].symbol);
3328
3329           if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
3330             {
3331               printf_filtered ("[%d] ", i + first_choice);
3332               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3333                                           &type_print_raw_options);
3334               printf_filtered (_(" at %s:%d\n"),
3335                                symtab_to_filename_for_display (symtab),
3336                                SYMBOL_LINE (syms[i].symbol));
3337             }
3338           else if (is_enumeral
3339                    && SYMBOL_TYPE (syms[i].symbol)->name () != NULL)
3340             {
3341               printf_filtered (("[%d] "), i + first_choice);
3342               ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
3343                               gdb_stdout, -1, 0, &type_print_raw_options);
3344               printf_filtered (_("'(%s) (enumeral)\n"),
3345                                syms[i].symbol->print_name ());
3346             }
3347           else
3348             {
3349               printf_filtered ("[%d] ", i + first_choice);
3350               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3351                                           &type_print_raw_options);
3352
3353               if (symtab != NULL)
3354                 printf_filtered (is_enumeral
3355                                  ? _(" in %s (enumeral)\n")
3356                                  : _(" at %s:?\n"),
3357                                  symtab_to_filename_for_display (symtab));
3358               else
3359                 printf_filtered (is_enumeral
3360                                  ? _(" (enumeral)\n")
3361                                  : _(" at ?\n"));
3362             }
3363         }
3364     }
3365
3366   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3367                              "overload-choice");
3368
3369   for (i = 0; i < n_chosen; i += 1)
3370     syms[i] = syms[chosen[i]];
3371
3372   return n_chosen;
3373 }
3374
3375 /* See ada-lang.h.  */
3376
3377 block_symbol
3378 ada_find_operator_symbol (enum exp_opcode op, int parse_completion,
3379                           int nargs, value *argvec[])
3380 {
3381   if (possible_user_operator_p (op, argvec))
3382     {
3383       std::vector<struct block_symbol> candidates
3384         = ada_lookup_symbol_list (ada_decoded_op_name (op),
3385                                   NULL, VAR_DOMAIN);
3386
3387       int i = ada_resolve_function (candidates, argvec,
3388                                     nargs, ada_decoded_op_name (op), NULL,
3389                                     parse_completion);
3390       if (i >= 0)
3391         return candidates[i];
3392     }
3393   return {};
3394 }
3395
3396 /* See ada-lang.h.  */
3397
3398 block_symbol
3399 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3400                      struct type *context_type,
3401                      int parse_completion,
3402                      int nargs, value *argvec[],
3403                      innermost_block_tracker *tracker)
3404 {
3405   std::vector<struct block_symbol> candidates
3406     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3407
3408   int i;
3409   if (candidates.size () == 1)
3410     i = 0;
3411   else
3412     {
3413       i = ada_resolve_function
3414         (candidates,
3415          argvec, nargs,
3416          sym->linkage_name (),
3417          context_type, parse_completion);
3418       if (i < 0)
3419         error (_("Could not find a match for %s"), sym->print_name ());
3420     }
3421
3422   tracker->update (candidates[i]);
3423   return candidates[i];
3424 }
3425
3426 /* See ada-lang.h.  */
3427
3428 block_symbol
3429 ada_resolve_variable (struct symbol *sym, const struct block *block,
3430                       struct type *context_type,
3431                       int parse_completion,
3432                       int deprocedure_p,
3433                       innermost_block_tracker *tracker)
3434 {
3435   std::vector<struct block_symbol> candidates
3436     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3437
3438   if (std::any_of (candidates.begin (),
3439                    candidates.end (),
3440                    [] (block_symbol &bsym)
3441                    {
3442                      switch (SYMBOL_CLASS (bsym.symbol))
3443                        {
3444                        case LOC_REGISTER:
3445                        case LOC_ARG:
3446                        case LOC_REF_ARG:
3447                        case LOC_REGPARM_ADDR:
3448                        case LOC_LOCAL:
3449                        case LOC_COMPUTED:
3450                          return true;
3451                        default:
3452                          return false;
3453                        }
3454                    }))
3455     {
3456       /* Types tend to get re-introduced locally, so if there
3457          are any local symbols that are not types, first filter
3458          out all types.  */
3459       candidates.erase
3460         (std::remove_if
3461          (candidates.begin (),
3462           candidates.end (),
3463           [] (block_symbol &bsym)
3464           {
3465             return SYMBOL_CLASS (bsym.symbol) == LOC_TYPEDEF;
3466           }),
3467          candidates.end ());
3468     }
3469
3470   int i;
3471   if (candidates.empty ())
3472     error (_("No definition found for %s"), sym->print_name ());
3473   else if (candidates.size () == 1)
3474     i = 0;
3475   else if (deprocedure_p && !is_nonfunction (candidates))
3476     {
3477       i = ada_resolve_function
3478         (candidates, NULL, 0,
3479          sym->linkage_name (),
3480          context_type, parse_completion);
3481       if (i < 0)
3482         error (_("Could not find a match for %s"), sym->print_name ());
3483     }
3484   else
3485     {
3486       printf_filtered (_("Multiple matches for %s\n"), sym->print_name ());
3487       user_select_syms (candidates.data (), candidates.size (), 1);
3488       i = 0;
3489     }
3490
3491   tracker->update (candidates[i]);
3492   return candidates[i];
3493 }
3494
3495 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  If
3496    MAY_DEREF is non-zero, the formal may be a pointer and the actual
3497    a non-pointer.  */
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, int may_deref)
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 ada_type_match (TYPE_TARGET_TYPE (ftype),
3519                                TYPE_TARGET_TYPE (atype), 0);
3520       else
3521         return (may_deref
3522                 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3523     case TYPE_CODE_INT:
3524     case TYPE_CODE_ENUM:
3525     case TYPE_CODE_RANGE:
3526       switch (atype->code ())
3527         {
3528         case TYPE_CODE_INT:
3529         case TYPE_CODE_ENUM:
3530         case TYPE_CODE_RANGE:
3531           return 1;
3532         default:
3533           return 0;
3534         }
3535
3536     case TYPE_CODE_ARRAY:
3537       return (atype->code () == TYPE_CODE_ARRAY
3538               || ada_is_array_descriptor_type (atype));
3539
3540     case TYPE_CODE_STRUCT:
3541       if (ada_is_array_descriptor_type (ftype))
3542         return (atype->code () == TYPE_CODE_ARRAY
3543                 || ada_is_array_descriptor_type (atype));
3544       else
3545         return (atype->code () == TYPE_CODE_STRUCT
3546                 && !ada_is_array_descriptor_type (atype));
3547
3548     case TYPE_CODE_UNION:
3549     case TYPE_CODE_FLT:
3550       return (atype->code () == ftype->code ());
3551     }
3552 }
3553
3554 /* Return non-zero if the formals of FUNC "sufficiently match" the
3555    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3556    may also be an enumeral, in which case it is treated as a 0-
3557    argument function.  */
3558
3559 static int
3560 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3561 {
3562   int i;
3563   struct type *func_type = SYMBOL_TYPE (func);
3564
3565   if (SYMBOL_CLASS (func) == LOC_CONST
3566       && func_type->code () == TYPE_CODE_ENUM)
3567     return (n_actuals == 0);
3568   else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3569     return 0;
3570
3571   if (func_type->num_fields () != n_actuals)
3572     return 0;
3573
3574   for (i = 0; i < n_actuals; i += 1)
3575     {
3576       if (actuals[i] == NULL)
3577         return 0;
3578       else
3579         {
3580           struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3581           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3582
3583           if (!ada_type_match (ftype, atype, 1))
3584             return 0;
3585         }
3586     }
3587   return 1;
3588 }
3589
3590 /* False iff function type FUNC_TYPE definitely does not produce a value
3591    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3592    FUNC_TYPE is not a valid function type with a non-null return type
3593    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3594
3595 static int
3596 return_match (struct type *func_type, struct type *context_type)
3597 {
3598   struct type *return_type;
3599
3600   if (func_type == NULL)
3601     return 1;
3602
3603   if (func_type->code () == TYPE_CODE_FUNC)
3604     return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3605   else
3606     return_type = get_base_type (func_type);
3607   if (return_type == NULL)
3608     return 1;
3609
3610   context_type = get_base_type (context_type);
3611
3612   if (return_type->code () == TYPE_CODE_ENUM)
3613     return context_type == NULL || return_type == context_type;
3614   else if (context_type == NULL)
3615     return return_type->code () != TYPE_CODE_VOID;
3616   else
3617     return return_type->code () == context_type->code ();
3618 }
3619
3620
3621 /* Returns the index in SYMS that contains the symbol for the
3622    function (if any) that matches the types of the NARGS arguments in
3623    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
3624    that returns that type, then eliminate matches that don't.  If
3625    CONTEXT_TYPE is void and there is at least one match that does not
3626    return void, eliminate all matches that do.
3627
3628    Asks the user if there is more than one match remaining.  Returns -1
3629    if there is no such symbol or none is selected.  NAME is used
3630    solely for messages.  May re-arrange and modify SYMS in
3631    the process; the index returned is for the modified vector.  */
3632
3633 static int
3634 ada_resolve_function (std::vector<struct block_symbol> &syms,
3635                       struct value **args, int nargs,
3636                       const char *name, struct type *context_type,
3637                       int parse_completion)
3638 {
3639   int fallback;
3640   int k;
3641   int m;                        /* Number of hits */
3642
3643   m = 0;
3644   /* In the first pass of the loop, we only accept functions matching
3645      context_type.  If none are found, we add a second pass of the loop
3646      where every function is accepted.  */
3647   for (fallback = 0; m == 0 && fallback < 2; fallback++)
3648     {
3649       for (k = 0; k < syms.size (); k += 1)
3650         {
3651           struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
3652
3653           if (ada_args_match (syms[k].symbol, args, nargs)
3654               && (fallback || return_match (type, context_type)))
3655             {
3656               syms[m] = syms[k];
3657               m += 1;
3658             }
3659         }
3660     }
3661
3662   /* If we got multiple matches, ask the user which one to use.  Don't do this
3663      interactive thing during completion, though, as the purpose of the
3664      completion is providing a list of all possible matches.  Prompting the
3665      user to filter it down would be completely unexpected in this case.  */
3666   if (m == 0)
3667     return -1;
3668   else if (m > 1 && !parse_completion)
3669     {
3670       printf_filtered (_("Multiple matches for %s\n"), name);
3671       user_select_syms (syms.data (), m, 1);
3672       return 0;
3673     }
3674   return 0;
3675 }
3676
3677 /* Type-class predicates */
3678
3679 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3680    or FLOAT).  */
3681
3682 static int
3683 numeric_type_p (struct type *type)
3684 {
3685   if (type == NULL)
3686     return 0;
3687   else
3688     {
3689       switch (type->code ())
3690         {
3691         case TYPE_CODE_INT:
3692         case TYPE_CODE_FLT:
3693           return 1;
3694         case TYPE_CODE_RANGE:
3695           return (type == TYPE_TARGET_TYPE (type)
3696                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
3697         default:
3698           return 0;
3699         }
3700     }
3701 }
3702
3703 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
3704
3705 static int
3706 integer_type_p (struct type *type)
3707 {
3708   if (type == NULL)
3709     return 0;
3710   else
3711     {
3712       switch (type->code ())
3713         {
3714         case TYPE_CODE_INT:
3715           return 1;
3716         case TYPE_CODE_RANGE:
3717           return (type == TYPE_TARGET_TYPE (type)
3718                   || integer_type_p (TYPE_TARGET_TYPE (type)));
3719         default:
3720           return 0;
3721         }
3722     }
3723 }
3724
3725 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
3726
3727 static int
3728 scalar_type_p (struct type *type)
3729 {
3730   if (type == NULL)
3731     return 0;
3732   else
3733     {
3734       switch (type->code ())
3735         {
3736         case TYPE_CODE_INT:
3737         case TYPE_CODE_RANGE:
3738         case TYPE_CODE_ENUM:
3739         case TYPE_CODE_FLT:
3740           return 1;
3741         default:
3742           return 0;
3743         }
3744     }
3745 }
3746
3747 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
3748
3749 static int
3750 discrete_type_p (struct type *type)
3751 {
3752   if (type == NULL)
3753     return 0;
3754   else
3755     {
3756       switch (type->code ())
3757         {
3758         case TYPE_CODE_INT:
3759         case TYPE_CODE_RANGE:
3760         case TYPE_CODE_ENUM:
3761         case TYPE_CODE_BOOL:
3762           return 1;
3763         default:
3764           return 0;
3765         }
3766     }
3767 }
3768
3769 /* Returns non-zero if OP with operands in the vector ARGS could be
3770    a user-defined function.  Errs on the side of pre-defined operators
3771    (i.e., result 0).  */
3772
3773 static int
3774 possible_user_operator_p (enum exp_opcode op, struct value *args[])
3775 {
3776   struct type *type0 =
3777     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
3778   struct type *type1 =
3779     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
3780
3781   if (type0 == NULL)
3782     return 0;
3783
3784   switch (op)
3785     {
3786     default:
3787       return 0;
3788
3789     case BINOP_ADD:
3790     case BINOP_SUB:
3791     case BINOP_MUL:
3792     case BINOP_DIV:
3793       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
3794
3795     case BINOP_REM:
3796     case BINOP_MOD:
3797     case BINOP_BITWISE_AND:
3798     case BINOP_BITWISE_IOR:
3799     case BINOP_BITWISE_XOR:
3800       return (!(integer_type_p (type0) && integer_type_p (type1)));
3801
3802     case BINOP_EQUAL:
3803     case BINOP_NOTEQUAL:
3804     case BINOP_LESS:
3805     case BINOP_GTR:
3806     case BINOP_LEQ:
3807     case BINOP_GEQ:
3808       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
3809
3810     case BINOP_CONCAT:
3811       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
3812
3813     case BINOP_EXP:
3814       return (!(numeric_type_p (type0) && integer_type_p (type1)));
3815
3816     case UNOP_NEG:
3817     case UNOP_PLUS:
3818     case UNOP_LOGICAL_NOT:
3819     case UNOP_ABS:
3820       return (!numeric_type_p (type0));
3821
3822     }
3823 }
3824 \f
3825                                 /* Renaming */
3826
3827 /* NOTES: 
3828
3829    1. In the following, we assume that a renaming type's name may
3830       have an ___XD suffix.  It would be nice if this went away at some
3831       point.
3832    2. We handle both the (old) purely type-based representation of 
3833       renamings and the (new) variable-based encoding.  At some point,
3834       it is devoutly to be hoped that the former goes away 
3835       (FIXME: hilfinger-2007-07-09).
3836    3. Subprogram renamings are not implemented, although the XRS
3837       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
3838
3839 /* If SYM encodes a renaming, 
3840
3841        <renaming> renames <renamed entity>,
3842
3843    sets *LEN to the length of the renamed entity's name,
3844    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3845    the string describing the subcomponent selected from the renamed
3846    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3847    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3848    are undefined).  Otherwise, returns a value indicating the category
3849    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3850    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3851    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
3852    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3853    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3854    may be NULL, in which case they are not assigned.
3855
3856    [Currently, however, GCC does not generate subprogram renamings.]  */
3857
3858 enum ada_renaming_category
3859 ada_parse_renaming (struct symbol *sym,
3860                     const char **renamed_entity, int *len, 
3861                     const char **renaming_expr)
3862 {
3863   enum ada_renaming_category kind;
3864   const char *info;
3865   const char *suffix;
3866
3867   if (sym == NULL)
3868     return ADA_NOT_RENAMING;
3869   switch (SYMBOL_CLASS (sym)) 
3870     {
3871     default:
3872       return ADA_NOT_RENAMING;
3873     case LOC_LOCAL:
3874     case LOC_STATIC:
3875     case LOC_COMPUTED:
3876     case LOC_OPTIMIZED_OUT:
3877       info = strstr (sym->linkage_name (), "___XR");
3878       if (info == NULL)
3879         return ADA_NOT_RENAMING;
3880       switch (info[5])
3881         {
3882         case '_':
3883           kind = ADA_OBJECT_RENAMING;
3884           info += 6;
3885           break;
3886         case 'E':
3887           kind = ADA_EXCEPTION_RENAMING;
3888           info += 7;
3889           break;
3890         case 'P':
3891           kind = ADA_PACKAGE_RENAMING;
3892           info += 7;
3893           break;
3894         case 'S':
3895           kind = ADA_SUBPROGRAM_RENAMING;
3896           info += 7;
3897           break;
3898         default:
3899           return ADA_NOT_RENAMING;
3900         }
3901     }
3902
3903   if (renamed_entity != NULL)
3904     *renamed_entity = info;
3905   suffix = strstr (info, "___XE");
3906   if (suffix == NULL || suffix == info)
3907     return ADA_NOT_RENAMING;
3908   if (len != NULL)
3909     *len = strlen (info) - strlen (suffix);
3910   suffix += 5;
3911   if (renaming_expr != NULL)
3912     *renaming_expr = suffix;
3913   return kind;
3914 }
3915
3916 /* Compute the value of the given RENAMING_SYM, which is expected to
3917    be a symbol encoding a renaming expression.  BLOCK is the block
3918    used to evaluate the renaming.  */
3919
3920 static struct value *
3921 ada_read_renaming_var_value (struct symbol *renaming_sym,
3922                              const struct block *block)
3923 {
3924   const char *sym_name;
3925
3926   sym_name = renaming_sym->linkage_name ();
3927   expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
3928   return evaluate_expression (expr.get ());
3929 }
3930 \f
3931
3932                                 /* Evaluation: Function Calls */
3933
3934 /* Return an lvalue containing the value VAL.  This is the identity on
3935    lvalues, and otherwise has the side-effect of allocating memory
3936    in the inferior where a copy of the value contents is copied.  */
3937
3938 static struct value *
3939 ensure_lval (struct value *val)
3940 {
3941   if (VALUE_LVAL (val) == not_lval
3942       || VALUE_LVAL (val) == lval_internalvar)
3943     {
3944       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
3945       const CORE_ADDR addr =
3946         value_as_long (value_allocate_space_in_inferior (len));
3947
3948       VALUE_LVAL (val) = lval_memory;
3949       set_value_address (val, addr);
3950       write_memory (addr, value_contents (val), len);
3951     }
3952
3953   return val;
3954 }
3955
3956 /* Given ARG, a value of type (pointer or reference to a)*
3957    structure/union, extract the component named NAME from the ultimate
3958    target structure/union and return it as a value with its
3959    appropriate type.
3960
3961    The routine searches for NAME among all members of the structure itself
3962    and (recursively) among all members of any wrapper members
3963    (e.g., '_parent').
3964
3965    If NO_ERR, then simply return NULL in case of error, rather than
3966    calling error.  */
3967
3968 static struct value *
3969 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
3970 {
3971   struct type *t, *t1;
3972   struct value *v;
3973   int check_tag;
3974
3975   v = NULL;
3976   t1 = t = ada_check_typedef (value_type (arg));
3977   if (t->code () == TYPE_CODE_REF)
3978     {
3979       t1 = TYPE_TARGET_TYPE (t);
3980       if (t1 == NULL)
3981         goto BadValue;
3982       t1 = ada_check_typedef (t1);
3983       if (t1->code () == TYPE_CODE_PTR)
3984         {
3985           arg = coerce_ref (arg);
3986           t = t1;
3987         }
3988     }
3989
3990   while (t->code () == TYPE_CODE_PTR)
3991     {
3992       t1 = TYPE_TARGET_TYPE (t);
3993       if (t1 == NULL)
3994         goto BadValue;
3995       t1 = ada_check_typedef (t1);
3996       if (t1->code () == TYPE_CODE_PTR)
3997         {
3998           arg = value_ind (arg);
3999           t = t1;
4000         }
4001       else
4002         break;
4003     }
4004
4005   if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4006     goto BadValue;
4007
4008   if (t1 == t)
4009     v = ada_search_struct_field (name, arg, 0, t);
4010   else
4011     {
4012       int bit_offset, bit_size, byte_offset;
4013       struct type *field_type;
4014       CORE_ADDR address;
4015
4016       if (t->code () == TYPE_CODE_PTR)
4017         address = value_address (ada_value_ind (arg));
4018       else
4019         address = value_address (ada_coerce_ref (arg));
4020
4021       /* Check to see if this is a tagged type.  We also need to handle
4022          the case where the type is a reference to a tagged type, but
4023          we have to be careful to exclude pointers to tagged types.
4024          The latter should be shown as usual (as a pointer), whereas
4025          a reference should mostly be transparent to the user.  */
4026
4027       if (ada_is_tagged_type (t1, 0)
4028           || (t1->code () == TYPE_CODE_REF
4029               && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
4030         {
4031           /* We first try to find the searched field in the current type.
4032              If not found then let's look in the fixed type.  */
4033
4034           if (!find_struct_field (name, t1, 0,
4035                                   &field_type, &byte_offset, &bit_offset,
4036                                   &bit_size, NULL))
4037             check_tag = 1;
4038           else
4039             check_tag = 0;
4040         }
4041       else
4042         check_tag = 0;
4043
4044       /* Convert to fixed type in all cases, so that we have proper
4045          offsets to each field in unconstrained record types.  */
4046       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4047                               address, NULL, check_tag);
4048
4049       /* Resolve the dynamic type as well.  */
4050       arg = value_from_contents_and_address (t1, nullptr, address);
4051       t1 = value_type (arg);
4052
4053       if (find_struct_field (name, t1, 0,
4054                              &field_type, &byte_offset, &bit_offset,
4055                              &bit_size, NULL))
4056         {
4057           if (bit_size != 0)
4058             {
4059               if (t->code () == TYPE_CODE_REF)
4060                 arg = ada_coerce_ref (arg);
4061               else
4062                 arg = ada_value_ind (arg);
4063               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4064                                                   bit_offset, bit_size,
4065                                                   field_type);
4066             }
4067           else
4068             v = value_at_lazy (field_type, address + byte_offset);
4069         }
4070     }
4071
4072   if (v != NULL || no_err)
4073     return v;
4074   else
4075     error (_("There is no member named %s."), name);
4076
4077  BadValue:
4078   if (no_err)
4079     return NULL;
4080   else
4081     error (_("Attempt to extract a component of "
4082              "a value that is not a record."));
4083 }
4084
4085 /* Return the value ACTUAL, converted to be an appropriate value for a
4086    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4087    allocating any necessary descriptors (fat pointers), or copies of
4088    values not residing in memory, updating it as needed.  */
4089
4090 struct value *
4091 ada_convert_actual (struct value *actual, struct type *formal_type0)
4092 {
4093   struct type *actual_type = ada_check_typedef (value_type (actual));
4094   struct type *formal_type = ada_check_typedef (formal_type0);
4095   struct type *formal_target =
4096     formal_type->code () == TYPE_CODE_PTR
4097     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4098   struct type *actual_target =
4099     actual_type->code () == TYPE_CODE_PTR
4100     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4101
4102   if (ada_is_array_descriptor_type (formal_target)
4103       && actual_target->code () == TYPE_CODE_ARRAY)
4104     return make_array_descriptor (formal_type, actual);
4105   else if (formal_type->code () == TYPE_CODE_PTR
4106            || formal_type->code () == TYPE_CODE_REF)
4107     {
4108       struct value *result;
4109
4110       if (formal_target->code () == TYPE_CODE_ARRAY
4111           && ada_is_array_descriptor_type (actual_target))
4112         result = desc_data (actual);
4113       else if (formal_type->code () != TYPE_CODE_PTR)
4114         {
4115           if (VALUE_LVAL (actual) != lval_memory)
4116             {
4117               struct value *val;
4118
4119               actual_type = ada_check_typedef (value_type (actual));
4120               val = allocate_value (actual_type);
4121               memcpy ((char *) value_contents_raw (val),
4122                       (char *) value_contents (actual),
4123                       TYPE_LENGTH (actual_type));
4124               actual = ensure_lval (val);
4125             }
4126           result = value_addr (actual);
4127         }
4128       else
4129         return actual;
4130       return value_cast_pointers (formal_type, result, 0);
4131     }
4132   else if (actual_type->code () == TYPE_CODE_PTR)
4133     return ada_value_ind (actual);
4134   else if (ada_is_aligner_type (formal_type))
4135     {
4136       /* We need to turn this parameter into an aligner type
4137          as well.  */
4138       struct value *aligner = allocate_value (formal_type);
4139       struct value *component = ada_value_struct_elt (aligner, "F", 0);
4140
4141       value_assign_to_component (aligner, component, actual);
4142       return aligner;
4143     }
4144
4145   return actual;
4146 }
4147
4148 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4149    type TYPE.  This is usually an inefficient no-op except on some targets
4150    (such as AVR) where the representation of a pointer and an address
4151    differs.  */
4152
4153 static CORE_ADDR
4154 value_pointer (struct value *value, struct type *type)
4155 {
4156   unsigned len = TYPE_LENGTH (type);
4157   gdb_byte *buf = (gdb_byte *) alloca (len);
4158   CORE_ADDR addr;
4159
4160   addr = value_address (value);
4161   gdbarch_address_to_pointer (type->arch (), type, buf, addr);
4162   addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4163   return addr;
4164 }
4165
4166
4167 /* Push a descriptor of type TYPE for array value ARR on the stack at
4168    *SP, updating *SP to reflect the new descriptor.  Return either
4169    an lvalue representing the new descriptor, or (if TYPE is a pointer-
4170    to-descriptor type rather than a descriptor type), a struct value *
4171    representing a pointer to this descriptor.  */
4172
4173 static struct value *
4174 make_array_descriptor (struct type *type, struct value *arr)
4175 {
4176   struct type *bounds_type = desc_bounds_type (type);
4177   struct type *desc_type = desc_base_type (type);
4178   struct value *descriptor = allocate_value (desc_type);
4179   struct value *bounds = allocate_value (bounds_type);
4180   int i;
4181
4182   for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4183        i > 0; i -= 1)
4184     {
4185       modify_field (value_type (bounds), value_contents_writeable (bounds),
4186                     ada_array_bound (arr, i, 0),
4187                     desc_bound_bitpos (bounds_type, i, 0),
4188                     desc_bound_bitsize (bounds_type, i, 0));
4189       modify_field (value_type (bounds), value_contents_writeable (bounds),
4190                     ada_array_bound (arr, i, 1),
4191                     desc_bound_bitpos (bounds_type, i, 1),
4192                     desc_bound_bitsize (bounds_type, i, 1));
4193     }
4194
4195   bounds = ensure_lval (bounds);
4196
4197   modify_field (value_type (descriptor),
4198                 value_contents_writeable (descriptor),
4199                 value_pointer (ensure_lval (arr),
4200                                desc_type->field (0).type ()),
4201                 fat_pntr_data_bitpos (desc_type),
4202                 fat_pntr_data_bitsize (desc_type));
4203
4204   modify_field (value_type (descriptor),
4205                 value_contents_writeable (descriptor),
4206                 value_pointer (bounds,
4207                                desc_type->field (1).type ()),
4208                 fat_pntr_bounds_bitpos (desc_type),
4209                 fat_pntr_bounds_bitsize (desc_type));
4210
4211   descriptor = ensure_lval (descriptor);
4212
4213   if (type->code () == TYPE_CODE_PTR)
4214     return value_addr (descriptor);
4215   else
4216     return descriptor;
4217 }
4218 \f
4219                                 /* Symbol Cache Module */
4220
4221 /* Performance measurements made as of 2010-01-15 indicate that
4222    this cache does bring some noticeable improvements.  Depending
4223    on the type of entity being printed, the cache can make it as much
4224    as an order of magnitude faster than without it.
4225
4226    The descriptive type DWARF extension has significantly reduced
4227    the need for this cache, at least when DWARF is being used.  However,
4228    even in this case, some expensive name-based symbol searches are still
4229    sometimes necessary - to find an XVZ variable, mostly.  */
4230
4231 /* Return the symbol cache associated to the given program space PSPACE.
4232    If not allocated for this PSPACE yet, allocate and initialize one.  */
4233
4234 static struct ada_symbol_cache *
4235 ada_get_symbol_cache (struct program_space *pspace)
4236 {
4237   struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4238
4239   if (pspace_data->sym_cache == nullptr)
4240     pspace_data->sym_cache.reset (new ada_symbol_cache);
4241
4242   return pspace_data->sym_cache.get ();
4243 }
4244
4245 /* Clear all entries from the symbol cache.  */
4246
4247 static void
4248 ada_clear_symbol_cache ()
4249 {
4250   struct ada_pspace_data *pspace_data
4251     = get_ada_pspace_data (current_program_space);
4252
4253   if (pspace_data->sym_cache != nullptr)
4254     pspace_data->sym_cache.reset ();
4255 }
4256
4257 /* Search our cache for an entry matching NAME and DOMAIN.
4258    Return it if found, or NULL otherwise.  */
4259
4260 static struct cache_entry **
4261 find_entry (const char *name, domain_enum domain)
4262 {
4263   struct ada_symbol_cache *sym_cache
4264     = ada_get_symbol_cache (current_program_space);
4265   int h = msymbol_hash (name) % HASH_SIZE;
4266   struct cache_entry **e;
4267
4268   for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4269     {
4270       if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4271         return e;
4272     }
4273   return NULL;
4274 }
4275
4276 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4277    Return 1 if found, 0 otherwise.
4278
4279    If an entry was found and SYM is not NULL, set *SYM to the entry's
4280    SYM.  Same principle for BLOCK if not NULL.  */
4281
4282 static int
4283 lookup_cached_symbol (const char *name, domain_enum domain,
4284                       struct symbol **sym, const struct block **block)
4285 {
4286   struct cache_entry **e = find_entry (name, domain);
4287
4288   if (e == NULL)
4289     return 0;
4290   if (sym != NULL)
4291     *sym = (*e)->sym;
4292   if (block != NULL)
4293     *block = (*e)->block;
4294   return 1;
4295 }
4296
4297 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4298    in domain DOMAIN, save this result in our symbol cache.  */
4299
4300 static void
4301 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4302               const struct block *block)
4303 {
4304   struct ada_symbol_cache *sym_cache
4305     = ada_get_symbol_cache (current_program_space);
4306   int h;
4307   struct cache_entry *e;
4308
4309   /* Symbols for builtin types don't have a block.
4310      For now don't cache such symbols.  */
4311   if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4312     return;
4313
4314   /* If the symbol is a local symbol, then do not cache it, as a search
4315      for that symbol depends on the context.  To determine whether
4316      the symbol is local or not, we check the block where we found it
4317      against the global and static blocks of its associated symtab.  */
4318   if (sym
4319       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4320                             GLOBAL_BLOCK) != block
4321       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4322                             STATIC_BLOCK) != block)
4323     return;
4324
4325   h = msymbol_hash (name) % HASH_SIZE;
4326   e = XOBNEW (&sym_cache->cache_space, cache_entry);
4327   e->next = sym_cache->root[h];
4328   sym_cache->root[h] = e;
4329   e->name = obstack_strdup (&sym_cache->cache_space, name);
4330   e->sym = sym;
4331   e->domain = domain;
4332   e->block = block;
4333 }
4334 \f
4335                                 /* Symbol Lookup */
4336
4337 /* Return the symbol name match type that should be used used when
4338    searching for all symbols matching LOOKUP_NAME.
4339
4340    LOOKUP_NAME is expected to be a symbol name after transformation
4341    for Ada lookups.  */
4342
4343 static symbol_name_match_type
4344 name_match_type_from_name (const char *lookup_name)
4345 {
4346   return (strstr (lookup_name, "__") == NULL
4347           ? symbol_name_match_type::WILD
4348           : symbol_name_match_type::FULL);
4349 }
4350
4351 /* Return the result of a standard (literal, C-like) lookup of NAME in
4352    given DOMAIN, visible from lexical block BLOCK.  */
4353
4354 static struct symbol *
4355 standard_lookup (const char *name, const struct block *block,
4356                  domain_enum domain)
4357 {
4358   /* Initialize it just to avoid a GCC false warning.  */
4359   struct block_symbol sym = {};
4360
4361   if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4362     return sym.symbol;
4363   ada_lookup_encoded_symbol (name, block, domain, &sym);
4364   cache_symbol (name, domain, sym.symbol, sym.block);
4365   return sym.symbol;
4366 }
4367
4368
4369 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4370    in the symbol fields of SYMS.  We treat enumerals as functions, 
4371    since they contend in overloading in the same way.  */
4372 static int
4373 is_nonfunction (const std::vector<struct block_symbol> &syms)
4374 {
4375   for (const block_symbol &sym : syms)
4376     if (SYMBOL_TYPE (sym.symbol)->code () != TYPE_CODE_FUNC
4377         && (SYMBOL_TYPE (sym.symbol)->code () != TYPE_CODE_ENUM
4378             || SYMBOL_CLASS (sym.symbol) != LOC_CONST))
4379       return 1;
4380
4381   return 0;
4382 }
4383
4384 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4385    struct types.  Otherwise, they may not.  */
4386
4387 static int
4388 equiv_types (struct type *type0, struct type *type1)
4389 {
4390   if (type0 == type1)
4391     return 1;
4392   if (type0 == NULL || type1 == NULL
4393       || type0->code () != type1->code ())
4394     return 0;
4395   if ((type0->code () == TYPE_CODE_STRUCT
4396        || type0->code () == TYPE_CODE_ENUM)
4397       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4398       && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4399     return 1;
4400
4401   return 0;
4402 }
4403
4404 /* True iff SYM0 represents the same entity as SYM1, or one that is
4405    no more defined than that of SYM1.  */
4406
4407 static int
4408 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4409 {
4410   if (sym0 == sym1)
4411     return 1;
4412   if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4413       || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4414     return 0;
4415
4416   switch (SYMBOL_CLASS (sym0))
4417     {
4418     case LOC_UNDEF:
4419       return 1;
4420     case LOC_TYPEDEF:
4421       {
4422         struct type *type0 = SYMBOL_TYPE (sym0);
4423         struct type *type1 = SYMBOL_TYPE (sym1);
4424         const char *name0 = sym0->linkage_name ();
4425         const char *name1 = sym1->linkage_name ();
4426         int len0 = strlen (name0);
4427
4428         return
4429           type0->code () == type1->code ()
4430           && (equiv_types (type0, type1)
4431               || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4432                   && startswith (name1 + len0, "___XV")));
4433       }
4434     case LOC_CONST:
4435       return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4436         && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4437
4438     case LOC_STATIC:
4439       {
4440         const char *name0 = sym0->linkage_name ();
4441         const char *name1 = sym1->linkage_name ();
4442         return (strcmp (name0, name1) == 0
4443                 && SYMBOL_VALUE_ADDRESS (sym0) == SYMBOL_VALUE_ADDRESS (sym1));
4444       }
4445
4446     default:
4447       return 0;
4448     }
4449 }
4450
4451 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4452    records in RESULT.  Do nothing if SYM is a duplicate.  */
4453
4454 static void
4455 add_defn_to_vec (std::vector<struct block_symbol> &result,
4456                  struct symbol *sym,
4457                  const struct block *block)
4458 {
4459   /* Do not try to complete stub types, as the debugger is probably
4460      already scanning all symbols matching a certain name at the
4461      time when this function is called.  Trying to replace the stub
4462      type by its associated full type will cause us to restart a scan
4463      which may lead to an infinite recursion.  Instead, the client
4464      collecting the matching symbols will end up collecting several
4465      matches, with at least one of them complete.  It can then filter
4466      out the stub ones if needed.  */
4467
4468   for (int i = result.size () - 1; i >= 0; i -= 1)
4469     {
4470       if (lesseq_defined_than (sym, result[i].symbol))
4471         return;
4472       else if (lesseq_defined_than (result[i].symbol, sym))
4473         {
4474           result[i].symbol = sym;
4475           result[i].block = block;
4476           return;
4477         }
4478     }
4479
4480   struct block_symbol info;
4481   info.symbol = sym;
4482   info.block = block;
4483   result.push_back (info);
4484 }
4485
4486 /* Return a bound minimal symbol matching NAME according to Ada
4487    decoding rules.  Returns an invalid symbol if there is no such
4488    minimal symbol.  Names prefixed with "standard__" are handled
4489    specially: "standard__" is first stripped off, and only static and
4490    global symbols are searched.  */
4491
4492 struct bound_minimal_symbol
4493 ada_lookup_simple_minsym (const char *name)
4494 {
4495   struct bound_minimal_symbol result;
4496
4497   memset (&result, 0, sizeof (result));
4498
4499   symbol_name_match_type match_type = name_match_type_from_name (name);
4500   lookup_name_info lookup_name (name, match_type);
4501
4502   symbol_name_matcher_ftype *match_name
4503     = ada_get_symbol_name_matcher (lookup_name);
4504
4505   for (objfile *objfile : current_program_space->objfiles ())
4506     {
4507       for (minimal_symbol *msymbol : objfile->msymbols ())
4508         {
4509           if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4510               && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4511             {
4512               result.minsym = msymbol;
4513               result.objfile = objfile;
4514               break;
4515             }
4516         }
4517     }
4518
4519   return result;
4520 }
4521
4522 /* For all subprograms that statically enclose the subprogram of the
4523    selected frame, add symbols matching identifier NAME in DOMAIN
4524    and their blocks to the list of data in RESULT, as for
4525    ada_add_block_symbols (q.v.).   If WILD_MATCH_P, treat as NAME
4526    with a wildcard prefix.  */
4527
4528 static void
4529 add_symbols_from_enclosing_procs (std::vector<struct block_symbol> &result,
4530                                   const lookup_name_info &lookup_name,
4531                                   domain_enum domain)
4532 {
4533 }
4534
4535 /* True if TYPE is definitely an artificial type supplied to a symbol
4536    for which no debugging information was given in the symbol file.  */
4537
4538 static int
4539 is_nondebugging_type (struct type *type)
4540 {
4541   const char *name = ada_type_name (type);
4542
4543   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4544 }
4545
4546 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4547    that are deemed "identical" for practical purposes.
4548
4549    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4550    types and that their number of enumerals is identical (in other
4551    words, type1->num_fields () == type2->num_fields ()).  */
4552
4553 static int
4554 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4555 {
4556   int i;
4557
4558   /* The heuristic we use here is fairly conservative.  We consider
4559      that 2 enumerate types are identical if they have the same
4560      number of enumerals and that all enumerals have the same
4561      underlying value and name.  */
4562
4563   /* All enums in the type should have an identical underlying value.  */
4564   for (i = 0; i < type1->num_fields (); i++)
4565     if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
4566       return 0;
4567
4568   /* All enumerals should also have the same name (modulo any numerical
4569      suffix).  */
4570   for (i = 0; i < type1->num_fields (); i++)
4571     {
4572       const char *name_1 = TYPE_FIELD_NAME (type1, i);
4573       const char *name_2 = TYPE_FIELD_NAME (type2, i);
4574       int len_1 = strlen (name_1);
4575       int len_2 = strlen (name_2);
4576
4577       ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4578       ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4579       if (len_1 != len_2
4580           || strncmp (TYPE_FIELD_NAME (type1, i),
4581                       TYPE_FIELD_NAME (type2, i),
4582                       len_1) != 0)
4583         return 0;
4584     }
4585
4586   return 1;
4587 }
4588
4589 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4590    that are deemed "identical" for practical purposes.  Sometimes,
4591    enumerals are not strictly identical, but their types are so similar
4592    that they can be considered identical.
4593
4594    For instance, consider the following code:
4595
4596       type Color is (Black, Red, Green, Blue, White);
4597       type RGB_Color is new Color range Red .. Blue;
4598
4599    Type RGB_Color is a subrange of an implicit type which is a copy
4600    of type Color. If we call that implicit type RGB_ColorB ("B" is
4601    for "Base Type"), then type RGB_ColorB is a copy of type Color.
4602    As a result, when an expression references any of the enumeral
4603    by name (Eg. "print green"), the expression is technically
4604    ambiguous and the user should be asked to disambiguate. But
4605    doing so would only hinder the user, since it wouldn't matter
4606    what choice he makes, the outcome would always be the same.
4607    So, for practical purposes, we consider them as the same.  */
4608
4609 static int
4610 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
4611 {
4612   int i;
4613
4614   /* Before performing a thorough comparison check of each type,
4615      we perform a series of inexpensive checks.  We expect that these
4616      checks will quickly fail in the vast majority of cases, and thus
4617      help prevent the unnecessary use of a more expensive comparison.
4618      Said comparison also expects us to make some of these checks
4619      (see ada_identical_enum_types_p).  */
4620
4621   /* Quick check: All symbols should have an enum type.  */
4622   for (i = 0; i < syms.size (); i++)
4623     if (SYMBOL_TYPE (syms[i].symbol)->code () != TYPE_CODE_ENUM)
4624       return 0;
4625
4626   /* Quick check: They should all have the same value.  */
4627   for (i = 1; i < syms.size (); i++)
4628     if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
4629       return 0;
4630
4631   /* Quick check: They should all have the same number of enumerals.  */
4632   for (i = 1; i < syms.size (); i++)
4633     if (SYMBOL_TYPE (syms[i].symbol)->num_fields ()
4634         != SYMBOL_TYPE (syms[0].symbol)->num_fields ())
4635       return 0;
4636
4637   /* All the sanity checks passed, so we might have a set of
4638      identical enumeration types.  Perform a more complete
4639      comparison of the type of each symbol.  */
4640   for (i = 1; i < syms.size (); i++)
4641     if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
4642                                      SYMBOL_TYPE (syms[0].symbol)))
4643       return 0;
4644
4645   return 1;
4646 }
4647
4648 /* Remove any non-debugging symbols in SYMS that definitely
4649    duplicate other symbols in the list (The only case I know of where
4650    this happens is when object files containing stabs-in-ecoff are
4651    linked with files containing ordinary ecoff debugging symbols (or no
4652    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.  */
4653
4654 static void
4655 remove_extra_symbols (std::vector<struct block_symbol> *syms)
4656 {
4657   int i, j;
4658
4659   /* We should never be called with less than 2 symbols, as there
4660      cannot be any extra symbol in that case.  But it's easy to
4661      handle, since we have nothing to do in that case.  */
4662   if (syms->size () < 2)
4663     return;
4664
4665   i = 0;
4666   while (i < syms->size ())
4667     {
4668       int remove_p = 0;
4669
4670       /* If two symbols have the same name and one of them is a stub type,
4671          the get rid of the stub.  */
4672
4673       if (SYMBOL_TYPE ((*syms)[i].symbol)->is_stub ()
4674           && (*syms)[i].symbol->linkage_name () != NULL)
4675         {
4676           for (j = 0; j < syms->size (); j++)
4677             {
4678               if (j != i
4679                   && !SYMBOL_TYPE ((*syms)[j].symbol)->is_stub ()
4680                   && (*syms)[j].symbol->linkage_name () != NULL
4681                   && strcmp ((*syms)[i].symbol->linkage_name (),
4682                              (*syms)[j].symbol->linkage_name ()) == 0)
4683                 remove_p = 1;
4684             }
4685         }
4686
4687       /* Two symbols with the same name, same class and same address
4688          should be identical.  */
4689
4690       else if ((*syms)[i].symbol->linkage_name () != NULL
4691           && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
4692           && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
4693         {
4694           for (j = 0; j < syms->size (); j += 1)
4695             {
4696               if (i != j
4697                   && (*syms)[j].symbol->linkage_name () != NULL
4698                   && strcmp ((*syms)[i].symbol->linkage_name (),
4699                              (*syms)[j].symbol->linkage_name ()) == 0
4700                   && SYMBOL_CLASS ((*syms)[i].symbol)
4701                        == SYMBOL_CLASS ((*syms)[j].symbol)
4702                   && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
4703                   == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
4704                 remove_p = 1;
4705             }
4706         }
4707       
4708       if (remove_p)
4709         syms->erase (syms->begin () + i);
4710       else
4711         i += 1;
4712     }
4713
4714   /* If all the remaining symbols are identical enumerals, then
4715      just keep the first one and discard the rest.
4716
4717      Unlike what we did previously, we do not discard any entry
4718      unless they are ALL identical.  This is because the symbol
4719      comparison is not a strict comparison, but rather a practical
4720      comparison.  If all symbols are considered identical, then
4721      we can just go ahead and use the first one and discard the rest.
4722      But if we cannot reduce the list to a single element, we have
4723      to ask the user to disambiguate anyways.  And if we have to
4724      present a multiple-choice menu, it's less confusing if the list
4725      isn't missing some choices that were identical and yet distinct.  */
4726   if (symbols_are_identical_enums (*syms))
4727     syms->resize (1);
4728 }
4729
4730 /* Given a type that corresponds to a renaming entity, use the type name
4731    to extract the scope (package name or function name, fully qualified,
4732    and following the GNAT encoding convention) where this renaming has been
4733    defined.  */
4734
4735 static std::string
4736 xget_renaming_scope (struct type *renaming_type)
4737 {
4738   /* The renaming types adhere to the following convention:
4739      <scope>__<rename>___<XR extension>.
4740      So, to extract the scope, we search for the "___XR" extension,
4741      and then backtrack until we find the first "__".  */
4742
4743   const char *name = renaming_type->name ();
4744   const char *suffix = strstr (name, "___XR");
4745   const char *last;
4746
4747   /* Now, backtrack a bit until we find the first "__".  Start looking
4748      at suffix - 3, as the <rename> part is at least one character long.  */
4749
4750   for (last = suffix - 3; last > name; last--)
4751     if (last[0] == '_' && last[1] == '_')
4752       break;
4753
4754   /* Make a copy of scope and return it.  */
4755   return std::string (name, last);
4756 }
4757
4758 /* Return nonzero if NAME corresponds to a package name.  */
4759
4760 static int
4761 is_package_name (const char *name)
4762 {
4763   /* Here, We take advantage of the fact that no symbols are generated
4764      for packages, while symbols are generated for each function.
4765      So the condition for NAME represent a package becomes equivalent
4766      to NAME not existing in our list of symbols.  There is only one
4767      small complication with library-level functions (see below).  */
4768
4769   /* If it is a function that has not been defined at library level,
4770      then we should be able to look it up in the symbols.  */
4771   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4772     return 0;
4773
4774   /* Library-level function names start with "_ada_".  See if function
4775      "_ada_" followed by NAME can be found.  */
4776
4777   /* Do a quick check that NAME does not contain "__", since library-level
4778      functions names cannot contain "__" in them.  */
4779   if (strstr (name, "__") != NULL)
4780     return 0;
4781
4782   std::string fun_name = string_printf ("_ada_%s", name);
4783
4784   return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
4785 }
4786
4787 /* Return nonzero if SYM corresponds to a renaming entity that is
4788    not visible from FUNCTION_NAME.  */
4789
4790 static int
4791 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
4792 {
4793   if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4794     return 0;
4795
4796   std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
4797
4798   /* If the rename has been defined in a package, then it is visible.  */
4799   if (is_package_name (scope.c_str ()))
4800     return 0;
4801
4802   /* Check that the rename is in the current function scope by checking
4803      that its name starts with SCOPE.  */
4804
4805   /* If the function name starts with "_ada_", it means that it is
4806      a library-level function.  Strip this prefix before doing the
4807      comparison, as the encoding for the renaming does not contain
4808      this prefix.  */
4809   if (startswith (function_name, "_ada_"))
4810     function_name += 5;
4811
4812   return !startswith (function_name, scope.c_str ());
4813 }
4814
4815 /* Remove entries from SYMS that corresponds to a renaming entity that
4816    is not visible from the function associated with CURRENT_BLOCK or
4817    that is superfluous due to the presence of more specific renaming
4818    information.  Places surviving symbols in the initial entries of
4819    SYMS.
4820
4821    Rationale:
4822    First, in cases where an object renaming is implemented as a
4823    reference variable, GNAT may produce both the actual reference
4824    variable and the renaming encoding.  In this case, we discard the
4825    latter.
4826
4827    Second, GNAT emits a type following a specified encoding for each renaming
4828    entity.  Unfortunately, STABS currently does not support the definition
4829    of types that are local to a given lexical block, so all renamings types
4830    are emitted at library level.  As a consequence, if an application
4831    contains two renaming entities using the same name, and a user tries to
4832    print the value of one of these entities, the result of the ada symbol
4833    lookup will also contain the wrong renaming type.
4834
4835    This function partially covers for this limitation by attempting to
4836    remove from the SYMS list renaming symbols that should be visible
4837    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
4838    method with the current information available.  The implementation
4839    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
4840    
4841       - When the user tries to print a rename in a function while there
4842         is another rename entity defined in a package:  Normally, the
4843         rename in the function has precedence over the rename in the
4844         package, so the latter should be removed from the list.  This is
4845         currently not the case.
4846         
4847       - This function will incorrectly remove valid renames if
4848         the CURRENT_BLOCK corresponds to a function which symbol name
4849         has been changed by an "Export" pragma.  As a consequence,
4850         the user will be unable to print such rename entities.  */
4851
4852 static void
4853 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
4854                              const struct block *current_block)
4855 {
4856   struct symbol *current_function;
4857   const char *current_function_name;
4858   int i;
4859   int is_new_style_renaming;
4860
4861   /* If there is both a renaming foo___XR... encoded as a variable and
4862      a simple variable foo in the same block, discard the latter.
4863      First, zero out such symbols, then compress.  */
4864   is_new_style_renaming = 0;
4865   for (i = 0; i < syms->size (); i += 1)
4866     {
4867       struct symbol *sym = (*syms)[i].symbol;
4868       const struct block *block = (*syms)[i].block;
4869       const char *name;
4870       const char *suffix;
4871
4872       if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4873         continue;
4874       name = sym->linkage_name ();
4875       suffix = strstr (name, "___XR");
4876
4877       if (suffix != NULL)
4878         {
4879           int name_len = suffix - name;
4880           int j;
4881
4882           is_new_style_renaming = 1;
4883           for (j = 0; j < syms->size (); j += 1)
4884             if (i != j && (*syms)[j].symbol != NULL
4885                 && strncmp (name, (*syms)[j].symbol->linkage_name (),
4886                             name_len) == 0
4887                 && block == (*syms)[j].block)
4888               (*syms)[j].symbol = NULL;
4889         }
4890     }
4891   if (is_new_style_renaming)
4892     {
4893       int j, k;
4894
4895       for (j = k = 0; j < syms->size (); j += 1)
4896         if ((*syms)[j].symbol != NULL)
4897             {
4898               (*syms)[k] = (*syms)[j];
4899               k += 1;
4900             }
4901       syms->resize (k);
4902       return;
4903     }
4904
4905   /* Extract the function name associated to CURRENT_BLOCK.
4906      Abort if unable to do so.  */
4907
4908   if (current_block == NULL)
4909     return;
4910
4911   current_function = block_linkage_function (current_block);
4912   if (current_function == NULL)
4913     return;
4914
4915   current_function_name = current_function->linkage_name ();
4916   if (current_function_name == NULL)
4917     return;
4918
4919   /* Check each of the symbols, and remove it from the list if it is
4920      a type corresponding to a renaming that is out of the scope of
4921      the current block.  */
4922
4923   i = 0;
4924   while (i < syms->size ())
4925     {
4926       if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
4927           == ADA_OBJECT_RENAMING
4928           && old_renaming_is_invisible ((*syms)[i].symbol,
4929                                         current_function_name))
4930         syms->erase (syms->begin () + i);
4931       else
4932         i += 1;
4933     }
4934 }
4935
4936 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
4937    whose name and domain match NAME and DOMAIN respectively.
4938    If no match was found, then extend the search to "enclosing"
4939    routines (in other words, if we're inside a nested function,
4940    search the symbols defined inside the enclosing functions).
4941    If WILD_MATCH_P is nonzero, perform the naming matching in
4942    "wild" mode (see function "wild_match" for more info).
4943
4944    Note: This function assumes that RESULT has 0 (zero) element in it.  */
4945
4946 static void
4947 ada_add_local_symbols (std::vector<struct block_symbol> &result,
4948                        const lookup_name_info &lookup_name,
4949                        const struct block *block, domain_enum domain)
4950 {
4951   int block_depth = 0;
4952
4953   while (block != NULL)
4954     {
4955       block_depth += 1;
4956       ada_add_block_symbols (result, block, lookup_name, domain, NULL);
4957
4958       /* If we found a non-function match, assume that's the one.  */
4959       if (is_nonfunction (result))
4960         return;
4961
4962       block = BLOCK_SUPERBLOCK (block);
4963     }
4964
4965   /* If no luck so far, try to find NAME as a local symbol in some lexically
4966      enclosing subprogram.  */
4967   if (result.empty () && block_depth > 2)
4968     add_symbols_from_enclosing_procs (result, lookup_name, domain);
4969 }
4970
4971 /* An object of this type is used as the user_data argument when
4972    calling the map_matching_symbols method.  */
4973
4974 struct match_data
4975 {
4976   explicit match_data (std::vector<struct block_symbol> *rp)
4977     : resultp (rp)
4978   {
4979   }
4980   DISABLE_COPY_AND_ASSIGN (match_data);
4981
4982   struct objfile *objfile = nullptr;
4983   std::vector<struct block_symbol> *resultp;
4984   struct symbol *arg_sym = nullptr;
4985   bool found_sym = false;
4986 };
4987
4988 /* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
4989    to a list of symbols.  DATA is a pointer to a struct match_data *
4990    containing the vector that collects the symbol list, the file that SYM
4991    must come from, a flag indicating whether a non-argument symbol has
4992    been found in the current block, and the last argument symbol
4993    passed in SYM within the current block (if any).  When SYM is null,
4994    marking the end of a block, the argument symbol is added if no
4995    other has been found.  */
4996
4997 static bool
4998 aux_add_nonlocal_symbols (struct block_symbol *bsym,
4999                           struct match_data *data)
5000 {
5001   const struct block *block = bsym->block;
5002   struct symbol *sym = bsym->symbol;
5003
5004   if (sym == NULL)
5005     {
5006       if (!data->found_sym && data->arg_sym != NULL) 
5007         add_defn_to_vec (*data->resultp,
5008                          fixup_symbol_section (data->arg_sym, data->objfile),
5009                          block);
5010       data->found_sym = false;
5011       data->arg_sym = NULL;
5012     }
5013   else 
5014     {
5015       if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5016         return true;
5017       else if (SYMBOL_IS_ARGUMENT (sym))
5018         data->arg_sym = sym;
5019       else
5020         {
5021           data->found_sym = true;
5022           add_defn_to_vec (*data->resultp,
5023                            fixup_symbol_section (sym, data->objfile),
5024                            block);
5025         }
5026     }
5027   return true;
5028 }
5029
5030 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5031    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5032    symbols to RESULT.  Return whether we found such symbols.  */
5033
5034 static int
5035 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5036                          const struct block *block,
5037                          const lookup_name_info &lookup_name,
5038                          domain_enum domain)
5039 {
5040   struct using_direct *renaming;
5041   int defns_mark = result.size ();
5042
5043   symbol_name_matcher_ftype *name_match
5044     = ada_get_symbol_name_matcher (lookup_name);
5045
5046   for (renaming = block_using (block);
5047        renaming != NULL;
5048        renaming = renaming->next)
5049     {
5050       const char *r_name;
5051
5052       /* Avoid infinite recursions: skip this renaming if we are actually
5053          already traversing it.
5054
5055          Currently, symbol lookup in Ada don't use the namespace machinery from
5056          C++/Fortran support: skip namespace imports that use them.  */
5057       if (renaming->searched
5058           || (renaming->import_src != NULL
5059               && renaming->import_src[0] != '\0')
5060           || (renaming->import_dest != NULL
5061               && renaming->import_dest[0] != '\0'))
5062         continue;
5063       renaming->searched = 1;
5064
5065       /* TODO: here, we perform another name-based symbol lookup, which can
5066          pull its own multiple overloads.  In theory, we should be able to do
5067          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5068          not a simple name.  But in order to do this, we would need to enhance
5069          the DWARF reader to associate a symbol to this renaming, instead of a
5070          name.  So, for now, we do something simpler: re-use the C++/Fortran
5071          namespace machinery.  */
5072       r_name = (renaming->alias != NULL
5073                 ? renaming->alias
5074                 : renaming->declaration);
5075       if (name_match (r_name, lookup_name, NULL))
5076         {
5077           lookup_name_info decl_lookup_name (renaming->declaration,
5078                                              lookup_name.match_type ());
5079           ada_add_all_symbols (result, block, decl_lookup_name, domain,
5080                                1, NULL);
5081         }
5082       renaming->searched = 0;
5083     }
5084   return result.size () != defns_mark;
5085 }
5086
5087 /* Implements compare_names, but only applying the comparision using
5088    the given CASING.  */
5089
5090 static int
5091 compare_names_with_case (const char *string1, const char *string2,
5092                          enum case_sensitivity casing)
5093 {
5094   while (*string1 != '\0' && *string2 != '\0')
5095     {
5096       char c1, c2;
5097
5098       if (isspace (*string1) || isspace (*string2))
5099         return strcmp_iw_ordered (string1, string2);
5100
5101       if (casing == case_sensitive_off)
5102         {
5103           c1 = tolower (*string1);
5104           c2 = tolower (*string2);
5105         }
5106       else
5107         {
5108           c1 = *string1;
5109           c2 = *string2;
5110         }
5111       if (c1 != c2)
5112         break;
5113
5114       string1 += 1;
5115       string2 += 1;
5116     }
5117
5118   switch (*string1)
5119     {
5120     case '(':
5121       return strcmp_iw_ordered (string1, string2);
5122     case '_':
5123       if (*string2 == '\0')
5124         {
5125           if (is_name_suffix (string1))
5126             return 0;
5127           else
5128             return 1;
5129         }
5130       /* FALLTHROUGH */
5131     default:
5132       if (*string2 == '(')
5133         return strcmp_iw_ordered (string1, string2);
5134       else
5135         {
5136           if (casing == case_sensitive_off)
5137             return tolower (*string1) - tolower (*string2);
5138           else
5139             return *string1 - *string2;
5140         }
5141     }
5142 }
5143
5144 /* Compare STRING1 to STRING2, with results as for strcmp.
5145    Compatible with strcmp_iw_ordered in that...
5146
5147        strcmp_iw_ordered (STRING1, STRING2) <= 0
5148
5149    ... implies...
5150
5151        compare_names (STRING1, STRING2) <= 0
5152
5153    (they may differ as to what symbols compare equal).  */
5154
5155 static int
5156 compare_names (const char *string1, const char *string2)
5157 {
5158   int result;
5159
5160   /* Similar to what strcmp_iw_ordered does, we need to perform
5161      a case-insensitive comparison first, and only resort to
5162      a second, case-sensitive, comparison if the first one was
5163      not sufficient to differentiate the two strings.  */
5164
5165   result = compare_names_with_case (string1, string2, case_sensitive_off);
5166   if (result == 0)
5167     result = compare_names_with_case (string1, string2, case_sensitive_on);
5168
5169   return result;
5170 }
5171
5172 /* Convenience function to get at the Ada encoded lookup name for
5173    LOOKUP_NAME, as a C string.  */
5174
5175 static const char *
5176 ada_lookup_name (const lookup_name_info &lookup_name)
5177 {
5178   return lookup_name.ada ().lookup_name ().c_str ();
5179 }
5180
5181 /* Add to RESULT all non-local symbols whose name and domain match
5182    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5183    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5184    symbols otherwise.  */
5185
5186 static void
5187 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5188                       const lookup_name_info &lookup_name,
5189                       domain_enum domain, int global)
5190 {
5191   struct match_data data (&result);
5192
5193   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5194
5195   auto callback = [&] (struct block_symbol *bsym)
5196     {
5197       return aux_add_nonlocal_symbols (bsym, &data);
5198     };
5199
5200   for (objfile *objfile : current_program_space->objfiles ())
5201     {
5202       data.objfile = objfile;
5203
5204       if (objfile->sf != nullptr)
5205         objfile->sf->qf->map_matching_symbols (objfile, lookup_name,
5206                                                domain, global, callback,
5207                                                (is_wild_match
5208                                                 ? NULL : compare_names));
5209
5210       for (compunit_symtab *cu : objfile->compunits ())
5211         {
5212           const struct block *global_block
5213             = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5214
5215           if (ada_add_block_renamings (result, global_block, lookup_name,
5216                                        domain))
5217             data.found_sym = true;
5218         }
5219     }
5220
5221   if (result.empty () && global && !is_wild_match)
5222     {
5223       const char *name = ada_lookup_name (lookup_name);
5224       std::string bracket_name = std::string ("<_ada_") + name + '>';
5225       lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5226
5227       for (objfile *objfile : current_program_space->objfiles ())
5228         {
5229           data.objfile = objfile;
5230           if (objfile->sf != nullptr)
5231             objfile->sf->qf->map_matching_symbols (objfile, name1,
5232                                                    domain, global, callback,
5233                                                    compare_names);
5234         }
5235     }           
5236 }
5237
5238 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5239    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5240    returning the number of matches.  Add these to RESULT.
5241
5242    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5243    symbol match within the nest of blocks whose innermost member is BLOCK,
5244    is the one match returned (no other matches in that or
5245    enclosing blocks is returned).  If there are any matches in or
5246    surrounding BLOCK, then these alone are returned.
5247
5248    Names prefixed with "standard__" are handled specially:
5249    "standard__" is first stripped off (by the lookup_name
5250    constructor), and only static and global symbols are searched.
5251
5252    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5253    to lookup global symbols.  */
5254
5255 static void
5256 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5257                      const struct block *block,
5258                      const lookup_name_info &lookup_name,
5259                      domain_enum domain,
5260                      int full_search,
5261                      int *made_global_lookup_p)
5262 {
5263   struct symbol *sym;
5264
5265   if (made_global_lookup_p)
5266     *made_global_lookup_p = 0;
5267
5268   /* Special case: If the user specifies a symbol name inside package
5269      Standard, do a non-wild matching of the symbol name without
5270      the "standard__" prefix.  This was primarily introduced in order
5271      to allow the user to specifically access the standard exceptions
5272      using, for instance, Standard.Constraint_Error when Constraint_Error
5273      is ambiguous (due to the user defining its own Constraint_Error
5274      entity inside its program).  */
5275   if (lookup_name.ada ().standard_p ())
5276     block = NULL;
5277
5278   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5279
5280   if (block != NULL)
5281     {
5282       if (full_search)
5283         ada_add_local_symbols (result, lookup_name, block, domain);
5284       else
5285         {
5286           /* In the !full_search case we're are being called by
5287              iterate_over_symbols, and we don't want to search
5288              superblocks.  */
5289           ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5290         }
5291       if (!result.empty () || !full_search)
5292         return;
5293     }
5294
5295   /* No non-global symbols found.  Check our cache to see if we have
5296      already performed this search before.  If we have, then return
5297      the same result.  */
5298
5299   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5300                             domain, &sym, &block))
5301     {
5302       if (sym != NULL)
5303         add_defn_to_vec (result, sym, block);
5304       return;
5305     }
5306
5307   if (made_global_lookup_p)
5308     *made_global_lookup_p = 1;
5309
5310   /* Search symbols from all global blocks.  */
5311  
5312   add_nonlocal_symbols (result, lookup_name, domain, 1);
5313
5314   /* Now add symbols from all per-file blocks if we've gotten no hits
5315      (not strictly correct, but perhaps better than an error).  */
5316
5317   if (result.empty ())
5318     add_nonlocal_symbols (result, lookup_name, domain, 0);
5319 }
5320
5321 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5322    is non-zero, enclosing scope and in global scopes.
5323
5324    Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5325    blocks and symbol tables (if any) in which they were found.
5326
5327    When full_search is non-zero, any non-function/non-enumeral
5328    symbol match within the nest of blocks whose innermost member is BLOCK,
5329    is the one match returned (no other matches in that or
5330    enclosing blocks is returned).  If there are any matches in or
5331    surrounding BLOCK, then these alone are returned.
5332
5333    Names prefixed with "standard__" are handled specially: "standard__"
5334    is first stripped off, and only static and global symbols are searched.  */
5335
5336 static std::vector<struct block_symbol>
5337 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5338                                const struct block *block,
5339                                domain_enum domain,
5340                                int full_search)
5341 {
5342   int syms_from_global_search;
5343   std::vector<struct block_symbol> results;
5344
5345   ada_add_all_symbols (results, block, lookup_name,
5346                        domain, full_search, &syms_from_global_search);
5347
5348   remove_extra_symbols (&results);
5349
5350   if (results.empty () && full_search && syms_from_global_search)
5351     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5352
5353   if (results.size () == 1 && full_search && syms_from_global_search)
5354     cache_symbol (ada_lookup_name (lookup_name), domain,
5355                   results[0].symbol, results[0].block);
5356
5357   remove_irrelevant_renamings (&results, block);
5358   return results;
5359 }
5360
5361 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5362    in global scopes, returning (SYM,BLOCK) tuples.
5363
5364    See ada_lookup_symbol_list_worker for further details.  */
5365
5366 std::vector<struct block_symbol>
5367 ada_lookup_symbol_list (const char *name, const struct block *block,
5368                         domain_enum domain)
5369 {
5370   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5371   lookup_name_info lookup_name (name, name_match_type);
5372
5373   return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5374 }
5375
5376 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5377    to 1, but choosing the first symbol found if there are multiple
5378    choices.
5379
5380    The result is stored in *INFO, which must be non-NULL.
5381    If no match is found, INFO->SYM is set to NULL.  */
5382
5383 void
5384 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5385                            domain_enum domain,
5386                            struct block_symbol *info)
5387 {
5388   /* Since we already have an encoded name, wrap it in '<>' to force a
5389      verbatim match.  Otherwise, if the name happens to not look like
5390      an encoded name (because it doesn't include a "__"),
5391      ada_lookup_name_info would re-encode/fold it again, and that
5392      would e.g., incorrectly lowercase object renaming names like
5393      "R28b" -> "r28b".  */
5394   std::string verbatim = add_angle_brackets (name);
5395
5396   gdb_assert (info != NULL);
5397   *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5398 }
5399
5400 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5401    scope and in global scopes, or NULL if none.  NAME is folded and
5402    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5403    choosing the first symbol if there are multiple choices.  */
5404
5405 struct block_symbol
5406 ada_lookup_symbol (const char *name, const struct block *block0,
5407                    domain_enum domain)
5408 {
5409   std::vector<struct block_symbol> candidates
5410     = ada_lookup_symbol_list (name, block0, domain);
5411
5412   if (candidates.empty ())
5413     return {};
5414
5415   block_symbol info = candidates[0];
5416   info.symbol = fixup_symbol_section (info.symbol, NULL);
5417   return info;
5418 }
5419
5420
5421 /* True iff STR is a possible encoded suffix of a normal Ada name
5422    that is to be ignored for matching purposes.  Suffixes of parallel
5423    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5424    are given by any of the regular expressions:
5425
5426    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5427    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5428    TKB              [subprogram suffix for task bodies]
5429    _E[0-9]+[bs]$    [protected object entry suffixes]
5430    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5431
5432    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5433    match is performed.  This sequence is used to differentiate homonyms,
5434    is an optional part of a valid name suffix.  */
5435
5436 static int
5437 is_name_suffix (const char *str)
5438 {
5439   int k;
5440   const char *matching;
5441   const int len = strlen (str);
5442
5443   /* Skip optional leading __[0-9]+.  */
5444
5445   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5446     {
5447       str += 3;
5448       while (isdigit (str[0]))
5449         str += 1;
5450     }
5451   
5452   /* [.$][0-9]+ */
5453
5454   if (str[0] == '.' || str[0] == '$')
5455     {
5456       matching = str + 1;
5457       while (isdigit (matching[0]))
5458         matching += 1;
5459       if (matching[0] == '\0')
5460         return 1;
5461     }
5462
5463   /* ___[0-9]+ */
5464
5465   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5466     {
5467       matching = str + 3;
5468       while (isdigit (matching[0]))
5469         matching += 1;
5470       if (matching[0] == '\0')
5471         return 1;
5472     }
5473
5474   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
5475
5476   if (strcmp (str, "TKB") == 0)
5477     return 1;
5478
5479 #if 0
5480   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5481      with a N at the end.  Unfortunately, the compiler uses the same
5482      convention for other internal types it creates.  So treating
5483      all entity names that end with an "N" as a name suffix causes
5484      some regressions.  For instance, consider the case of an enumerated
5485      type.  To support the 'Image attribute, it creates an array whose
5486      name ends with N.
5487      Having a single character like this as a suffix carrying some
5488      information is a bit risky.  Perhaps we should change the encoding
5489      to be something like "_N" instead.  In the meantime, do not do
5490      the following check.  */
5491   /* Protected Object Subprograms */
5492   if (len == 1 && str [0] == 'N')
5493     return 1;
5494 #endif
5495
5496   /* _E[0-9]+[bs]$ */
5497   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5498     {
5499       matching = str + 3;
5500       while (isdigit (matching[0]))
5501         matching += 1;
5502       if ((matching[0] == 'b' || matching[0] == 's')
5503           && matching [1] == '\0')
5504         return 1;
5505     }
5506
5507   /* ??? We should not modify STR directly, as we are doing below.  This
5508      is fine in this case, but may become problematic later if we find
5509      that this alternative did not work, and want to try matching
5510      another one from the begining of STR.  Since we modified it, we
5511      won't be able to find the begining of the string anymore!  */
5512   if (str[0] == 'X')
5513     {
5514       str += 1;
5515       while (str[0] != '_' && str[0] != '\0')
5516         {
5517           if (str[0] != 'n' && str[0] != 'b')
5518             return 0;
5519           str += 1;
5520         }
5521     }
5522
5523   if (str[0] == '\000')
5524     return 1;
5525
5526   if (str[0] == '_')
5527     {
5528       if (str[1] != '_' || str[2] == '\000')
5529         return 0;
5530       if (str[2] == '_')
5531         {
5532           if (strcmp (str + 3, "JM") == 0)
5533             return 1;
5534           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5535              the LJM suffix in favor of the JM one.  But we will
5536              still accept LJM as a valid suffix for a reasonable
5537              amount of time, just to allow ourselves to debug programs
5538              compiled using an older version of GNAT.  */
5539           if (strcmp (str + 3, "LJM") == 0)
5540             return 1;
5541           if (str[3] != 'X')
5542             return 0;
5543           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5544               || str[4] == 'U' || str[4] == 'P')
5545             return 1;
5546           if (str[4] == 'R' && str[5] != 'T')
5547             return 1;
5548           return 0;
5549         }
5550       if (!isdigit (str[2]))
5551         return 0;
5552       for (k = 3; str[k] != '\0'; k += 1)
5553         if (!isdigit (str[k]) && str[k] != '_')
5554           return 0;
5555       return 1;
5556     }
5557   if (str[0] == '$' && isdigit (str[1]))
5558     {
5559       for (k = 2; str[k] != '\0'; k += 1)
5560         if (!isdigit (str[k]) && str[k] != '_')
5561           return 0;
5562       return 1;
5563     }
5564   return 0;
5565 }
5566
5567 /* Return non-zero if the string starting at NAME and ending before
5568    NAME_END contains no capital letters.  */
5569
5570 static int
5571 is_valid_name_for_wild_match (const char *name0)
5572 {
5573   std::string decoded_name = ada_decode (name0);
5574   int i;
5575
5576   /* If the decoded name starts with an angle bracket, it means that
5577      NAME0 does not follow the GNAT encoding format.  It should then
5578      not be allowed as a possible wild match.  */
5579   if (decoded_name[0] == '<')
5580     return 0;
5581
5582   for (i=0; decoded_name[i] != '\0'; i++)
5583     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5584       return 0;
5585
5586   return 1;
5587 }
5588
5589 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5590    character which could start a simple name.  Assumes that *NAMEP points
5591    somewhere inside the string beginning at NAME0.  */
5592
5593 static int
5594 advance_wild_match (const char **namep, const char *name0, char target0)
5595 {
5596   const char *name = *namep;
5597
5598   while (1)
5599     {
5600       char t0, t1;
5601
5602       t0 = *name;
5603       if (t0 == '_')
5604         {
5605           t1 = name[1];
5606           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5607             {
5608               name += 1;
5609               if (name == name0 + 5 && startswith (name0, "_ada"))
5610                 break;
5611               else
5612                 name += 1;
5613             }
5614           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5615                                  || name[2] == target0))
5616             {
5617               name += 2;
5618               break;
5619             }
5620           else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
5621             {
5622               /* Names like "pkg__B_N__name", where N is a number, are
5623                  block-local.  We can handle these by simply skipping
5624                  the "B_" here.  */
5625               name += 4;
5626             }
5627           else
5628             return 0;
5629         }
5630       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5631         name += 1;
5632       else
5633         return 0;
5634     }
5635
5636   *namep = name;
5637   return 1;
5638 }
5639
5640 /* Return true iff NAME encodes a name of the form prefix.PATN.
5641    Ignores any informational suffixes of NAME (i.e., for which
5642    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
5643    simple name.  */
5644
5645 static bool
5646 wild_match (const char *name, const char *patn)
5647 {
5648   const char *p;
5649   const char *name0 = name;
5650
5651   while (1)
5652     {
5653       const char *match = name;
5654
5655       if (*name == *patn)
5656         {
5657           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5658             if (*p != *name)
5659               break;
5660           if (*p == '\0' && is_name_suffix (name))
5661             return match == name0 || is_valid_name_for_wild_match (name0);
5662
5663           if (name[-1] == '_')
5664             name -= 1;
5665         }
5666       if (!advance_wild_match (&name, name0, *patn))
5667         return false;
5668     }
5669 }
5670
5671 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
5672    necessary).  OBJFILE is the section containing BLOCK.  */
5673
5674 static void
5675 ada_add_block_symbols (std::vector<struct block_symbol> &result,
5676                        const struct block *block,
5677                        const lookup_name_info &lookup_name,
5678                        domain_enum domain, struct objfile *objfile)
5679 {
5680   struct block_iterator iter;
5681   /* A matching argument symbol, if any.  */
5682   struct symbol *arg_sym;
5683   /* Set true when we find a matching non-argument symbol.  */
5684   bool found_sym;
5685   struct symbol *sym;
5686
5687   arg_sym = NULL;
5688   found_sym = false;
5689   for (sym = block_iter_match_first (block, lookup_name, &iter);
5690        sym != NULL;
5691        sym = block_iter_match_next (lookup_name, &iter))
5692     {
5693       if (symbol_matches_domain (sym->language (), SYMBOL_DOMAIN (sym), domain))
5694         {
5695           if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5696             {
5697               if (SYMBOL_IS_ARGUMENT (sym))
5698                 arg_sym = sym;
5699               else
5700                 {
5701                   found_sym = true;
5702                   add_defn_to_vec (result,
5703                                    fixup_symbol_section (sym, objfile),
5704                                    block);
5705                 }
5706             }
5707         }
5708     }
5709
5710   /* Handle renamings.  */
5711
5712   if (ada_add_block_renamings (result, block, lookup_name, domain))
5713     found_sym = true;
5714
5715   if (!found_sym && arg_sym != NULL)
5716     {
5717       add_defn_to_vec (result,
5718                        fixup_symbol_section (arg_sym, objfile),
5719                        block);
5720     }
5721
5722   if (!lookup_name.ada ().wild_match_p ())
5723     {
5724       arg_sym = NULL;
5725       found_sym = false;
5726       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
5727       const char *name = ada_lookup_name.c_str ();
5728       size_t name_len = ada_lookup_name.size ();
5729
5730       ALL_BLOCK_SYMBOLS (block, iter, sym)
5731       {
5732         if (symbol_matches_domain (sym->language (),
5733                                    SYMBOL_DOMAIN (sym), domain))
5734           {
5735             int cmp;
5736
5737             cmp = (int) '_' - (int) sym->linkage_name ()[0];
5738             if (cmp == 0)
5739               {
5740                 cmp = !startswith (sym->linkage_name (), "_ada_");
5741                 if (cmp == 0)
5742                   cmp = strncmp (name, sym->linkage_name () + 5,
5743                                  name_len);
5744               }
5745
5746             if (cmp == 0
5747                 && is_name_suffix (sym->linkage_name () + name_len + 5))
5748               {
5749                 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5750                   {
5751                     if (SYMBOL_IS_ARGUMENT (sym))
5752                       arg_sym = sym;
5753                     else
5754                       {
5755                         found_sym = true;
5756                         add_defn_to_vec (result,
5757                                          fixup_symbol_section (sym, objfile),
5758                                          block);
5759                       }
5760                   }
5761               }
5762           }
5763       }
5764
5765       /* NOTE: This really shouldn't be needed for _ada_ symbols.
5766          They aren't parameters, right?  */
5767       if (!found_sym && arg_sym != NULL)
5768         {
5769           add_defn_to_vec (result,
5770                            fixup_symbol_section (arg_sym, objfile),
5771                            block);
5772         }
5773     }
5774 }
5775 \f
5776
5777                                 /* Symbol Completion */
5778
5779 /* See symtab.h.  */
5780
5781 bool
5782 ada_lookup_name_info::matches
5783   (const char *sym_name,
5784    symbol_name_match_type match_type,
5785    completion_match_result *comp_match_res) const
5786 {
5787   bool match = false;
5788   const char *text = m_encoded_name.c_str ();
5789   size_t text_len = m_encoded_name.size ();
5790
5791   /* First, test against the fully qualified name of the symbol.  */
5792
5793   if (strncmp (sym_name, text, text_len) == 0)
5794     match = true;
5795
5796   std::string decoded_name = ada_decode (sym_name);
5797   if (match && !m_encoded_p)
5798     {
5799       /* One needed check before declaring a positive match is to verify
5800          that iff we are doing a verbatim match, the decoded version
5801          of the symbol name starts with '<'.  Otherwise, this symbol name
5802          is not a suitable completion.  */
5803
5804       bool has_angle_bracket = (decoded_name[0] == '<');
5805       match = (has_angle_bracket == m_verbatim_p);
5806     }
5807
5808   if (match && !m_verbatim_p)
5809     {
5810       /* When doing non-verbatim match, another check that needs to
5811          be done is to verify that the potentially matching symbol name
5812          does not include capital letters, because the ada-mode would
5813          not be able to understand these symbol names without the
5814          angle bracket notation.  */
5815       const char *tmp;
5816
5817       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5818       if (*tmp != '\0')
5819         match = false;
5820     }
5821
5822   /* Second: Try wild matching...  */
5823
5824   if (!match && m_wild_match_p)
5825     {
5826       /* Since we are doing wild matching, this means that TEXT
5827          may represent an unqualified symbol name.  We therefore must
5828          also compare TEXT against the unqualified name of the symbol.  */
5829       sym_name = ada_unqualified_name (decoded_name.c_str ());
5830
5831       if (strncmp (sym_name, text, text_len) == 0)
5832         match = true;
5833     }
5834
5835   /* Finally: If we found a match, prepare the result to return.  */
5836
5837   if (!match)
5838     return false;
5839
5840   if (comp_match_res != NULL)
5841     {
5842       std::string &match_str = comp_match_res->match.storage ();
5843
5844       if (!m_encoded_p)
5845         match_str = ada_decode (sym_name);
5846       else
5847         {
5848           if (m_verbatim_p)
5849             match_str = add_angle_brackets (sym_name);
5850           else
5851             match_str = sym_name;
5852
5853         }
5854
5855       comp_match_res->set_match (match_str.c_str ());
5856     }
5857
5858   return true;
5859 }
5860
5861                                 /* Field Access */
5862
5863 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5864    for tagged types.  */
5865
5866 static int
5867 ada_is_dispatch_table_ptr_type (struct type *type)
5868 {
5869   const char *name;
5870
5871   if (type->code () != TYPE_CODE_PTR)
5872     return 0;
5873
5874   name = TYPE_TARGET_TYPE (type)->name ();
5875   if (name == NULL)
5876     return 0;
5877
5878   return (strcmp (name, "ada__tags__dispatch_table") == 0);
5879 }
5880
5881 /* Return non-zero if TYPE is an interface tag.  */
5882
5883 static int
5884 ada_is_interface_tag (struct type *type)
5885 {
5886   const char *name = type->name ();
5887
5888   if (name == NULL)
5889     return 0;
5890
5891   return (strcmp (name, "ada__tags__interface_tag") == 0);
5892 }
5893
5894 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5895    to be invisible to users.  */
5896
5897 int
5898 ada_is_ignored_field (struct type *type, int field_num)
5899 {
5900   if (field_num < 0 || field_num > type->num_fields ())
5901     return 1;
5902
5903   /* Check the name of that field.  */
5904   {
5905     const char *name = TYPE_FIELD_NAME (type, field_num);
5906
5907     /* Anonymous field names should not be printed.
5908        brobecker/2007-02-20: I don't think this can actually happen
5909        but we don't want to print the value of anonymous fields anyway.  */
5910     if (name == NULL)
5911       return 1;
5912
5913     /* Normally, fields whose name start with an underscore ("_")
5914        are fields that have been internally generated by the compiler,
5915        and thus should not be printed.  The "_parent" field is special,
5916        however: This is a field internally generated by the compiler
5917        for tagged types, and it contains the components inherited from
5918        the parent type.  This field should not be printed as is, but
5919        should not be ignored either.  */
5920     if (name[0] == '_' && !startswith (name, "_parent"))
5921       return 1;
5922   }
5923
5924   /* If this is the dispatch table of a tagged type or an interface tag,
5925      then ignore.  */
5926   if (ada_is_tagged_type (type, 1)
5927       && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
5928           || ada_is_interface_tag (type->field (field_num).type ())))
5929     return 1;
5930
5931   /* Not a special field, so it should not be ignored.  */
5932   return 0;
5933 }
5934
5935 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
5936    pointer or reference type whose ultimate target has a tag field.  */
5937
5938 int
5939 ada_is_tagged_type (struct type *type, int refok)
5940 {
5941   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
5942 }
5943
5944 /* True iff TYPE represents the type of X'Tag */
5945
5946 int
5947 ada_is_tag_type (struct type *type)
5948 {
5949   type = ada_check_typedef (type);
5950
5951   if (type == NULL || type->code () != TYPE_CODE_PTR)
5952     return 0;
5953   else
5954     {
5955       const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5956
5957       return (name != NULL
5958               && strcmp (name, "ada__tags__dispatch_table") == 0);
5959     }
5960 }
5961
5962 /* The type of the tag on VAL.  */
5963
5964 static struct type *
5965 ada_tag_type (struct value *val)
5966 {
5967   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
5968 }
5969
5970 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
5971    retired at Ada 05).  */
5972
5973 static int
5974 is_ada95_tag (struct value *tag)
5975 {
5976   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
5977 }
5978
5979 /* The value of the tag on VAL.  */
5980
5981 static struct value *
5982 ada_value_tag (struct value *val)
5983 {
5984   return ada_value_struct_elt (val, "_tag", 0);
5985 }
5986
5987 /* The value of the tag on the object of type TYPE whose contents are
5988    saved at VALADDR, if it is non-null, or is at memory address
5989    ADDRESS.  */
5990
5991 static struct value *
5992 value_tag_from_contents_and_address (struct type *type,
5993                                      const gdb_byte *valaddr,
5994                                      CORE_ADDR address)
5995 {
5996   int tag_byte_offset;
5997   struct type *tag_type;
5998
5999   if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
6000                          NULL, NULL, NULL))
6001     {
6002       const gdb_byte *valaddr1 = ((valaddr == NULL)
6003                                   ? NULL
6004                                   : valaddr + tag_byte_offset);
6005       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6006
6007       return value_from_contents_and_address (tag_type, valaddr1, address1);
6008     }
6009   return NULL;
6010 }
6011
6012 static struct type *
6013 type_from_tag (struct value *tag)
6014 {
6015   gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6016
6017   if (type_name != NULL)
6018     return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6019   return NULL;
6020 }
6021
6022 /* Given a value OBJ of a tagged type, return a value of this
6023    type at the base address of the object.  The base address, as
6024    defined in Ada.Tags, it is the address of the primary tag of
6025    the object, and therefore where the field values of its full
6026    view can be fetched.  */
6027
6028 struct value *
6029 ada_tag_value_at_base_address (struct value *obj)
6030 {
6031   struct value *val;
6032   LONGEST offset_to_top = 0;
6033   struct type *ptr_type, *obj_type;
6034   struct value *tag;
6035   CORE_ADDR base_address;
6036
6037   obj_type = value_type (obj);
6038
6039   /* It is the responsability of the caller to deref pointers.  */
6040
6041   if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6042     return obj;
6043
6044   tag = ada_value_tag (obj);
6045   if (!tag)
6046     return obj;
6047
6048   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6049
6050   if (is_ada95_tag (tag))
6051     return obj;
6052
6053   ptr_type = language_lookup_primitive_type
6054     (language_def (language_ada), target_gdbarch(), "storage_offset");
6055   ptr_type = lookup_pointer_type (ptr_type);
6056   val = value_cast (ptr_type, tag);
6057   if (!val)
6058     return obj;
6059
6060   /* It is perfectly possible that an exception be raised while
6061      trying to determine the base address, just like for the tag;
6062      see ada_tag_name for more details.  We do not print the error
6063      message for the same reason.  */
6064
6065   try
6066     {
6067       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6068     }
6069
6070   catch (const gdb_exception_error &e)
6071     {
6072       return obj;
6073     }
6074
6075   /* If offset is null, nothing to do.  */
6076
6077   if (offset_to_top == 0)
6078     return obj;
6079
6080   /* -1 is a special case in Ada.Tags; however, what should be done
6081      is not quite clear from the documentation.  So do nothing for
6082      now.  */
6083
6084   if (offset_to_top == -1)
6085     return obj;
6086
6087   /* OFFSET_TO_TOP used to be a positive value to be subtracted
6088      from the base address.  This was however incompatible with
6089      C++ dispatch table: C++ uses a *negative* value to *add*
6090      to the base address.  Ada's convention has therefore been
6091      changed in GNAT 19.0w 20171023: since then, C++ and Ada
6092      use the same convention.  Here, we support both cases by
6093      checking the sign of OFFSET_TO_TOP.  */
6094
6095   if (offset_to_top > 0)
6096     offset_to_top = -offset_to_top;
6097
6098   base_address = value_address (obj) + offset_to_top;
6099   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6100
6101   /* Make sure that we have a proper tag at the new address.
6102      Otherwise, offset_to_top is bogus (which can happen when
6103      the object is not initialized yet).  */
6104
6105   if (!tag)
6106     return obj;
6107
6108   obj_type = type_from_tag (tag);
6109
6110   if (!obj_type)
6111     return obj;
6112
6113   return value_from_contents_and_address (obj_type, NULL, base_address);
6114 }
6115
6116 /* Return the "ada__tags__type_specific_data" type.  */
6117
6118 static struct type *
6119 ada_get_tsd_type (struct inferior *inf)
6120 {
6121   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6122
6123   if (data->tsd_type == 0)
6124     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6125   return data->tsd_type;
6126 }
6127
6128 /* Return the TSD (type-specific data) associated to the given TAG.
6129    TAG is assumed to be the tag of a tagged-type entity.
6130
6131    May return NULL if we are unable to get the TSD.  */
6132
6133 static struct value *
6134 ada_get_tsd_from_tag (struct value *tag)
6135 {
6136   struct value *val;
6137   struct type *type;
6138
6139   /* First option: The TSD is simply stored as a field of our TAG.
6140      Only older versions of GNAT would use this format, but we have
6141      to test it first, because there are no visible markers for
6142      the current approach except the absence of that field.  */
6143
6144   val = ada_value_struct_elt (tag, "tsd", 1);
6145   if (val)
6146     return val;
6147
6148   /* Try the second representation for the dispatch table (in which
6149      there is no explicit 'tsd' field in the referent of the tag pointer,
6150      and instead the tsd pointer is stored just before the dispatch
6151      table.  */
6152
6153   type = ada_get_tsd_type (current_inferior());
6154   if (type == NULL)
6155     return NULL;
6156   type = lookup_pointer_type (lookup_pointer_type (type));
6157   val = value_cast (type, tag);
6158   if (val == NULL)
6159     return NULL;
6160   return value_ind (value_ptradd (val, -1));
6161 }
6162
6163 /* Given the TSD of a tag (type-specific data), return a string
6164    containing the name of the associated type.
6165
6166    May return NULL if we are unable to determine the tag name.  */
6167
6168 static gdb::unique_xmalloc_ptr<char>
6169 ada_tag_name_from_tsd (struct value *tsd)
6170 {
6171   char *p;
6172   struct value *val;
6173
6174   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6175   if (val == NULL)
6176     return NULL;
6177   gdb::unique_xmalloc_ptr<char> buffer
6178     = target_read_string (value_as_address (val), INT_MAX);
6179   if (buffer == nullptr)
6180     return nullptr;
6181
6182   for (p = buffer.get (); *p != '\0'; ++p)
6183     {
6184       if (isalpha (*p))
6185         *p = tolower (*p);
6186     }
6187
6188   return buffer;
6189 }
6190
6191 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6192    a C string.
6193
6194    Return NULL if the TAG is not an Ada tag, or if we were unable to
6195    determine the name of that tag.  */
6196
6197 gdb::unique_xmalloc_ptr<char>
6198 ada_tag_name (struct value *tag)
6199 {
6200   gdb::unique_xmalloc_ptr<char> name;
6201
6202   if (!ada_is_tag_type (value_type (tag)))
6203     return NULL;
6204
6205   /* It is perfectly possible that an exception be raised while trying
6206      to determine the TAG's name, even under normal circumstances:
6207      The associated variable may be uninitialized or corrupted, for
6208      instance. We do not let any exception propagate past this point.
6209      instead we return NULL.
6210
6211      We also do not print the error message either (which often is very
6212      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6213      the caller print a more meaningful message if necessary.  */
6214   try
6215     {
6216       struct value *tsd = ada_get_tsd_from_tag (tag);
6217
6218       if (tsd != NULL)
6219         name = ada_tag_name_from_tsd (tsd);
6220     }
6221   catch (const gdb_exception_error &e)
6222     {
6223     }
6224
6225   return name;
6226 }
6227
6228 /* The parent type of TYPE, or NULL if none.  */
6229
6230 struct type *
6231 ada_parent_type (struct type *type)
6232 {
6233   int i;
6234
6235   type = ada_check_typedef (type);
6236
6237   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6238     return NULL;
6239
6240   for (i = 0; i < type->num_fields (); i += 1)
6241     if (ada_is_parent_field (type, i))
6242       {
6243         struct type *parent_type = type->field (i).type ();
6244
6245         /* If the _parent field is a pointer, then dereference it.  */
6246         if (parent_type->code () == TYPE_CODE_PTR)
6247           parent_type = TYPE_TARGET_TYPE (parent_type);
6248         /* If there is a parallel XVS type, get the actual base type.  */
6249         parent_type = ada_get_base_type (parent_type);
6250
6251         return ada_check_typedef (parent_type);
6252       }
6253
6254   return NULL;
6255 }
6256
6257 /* True iff field number FIELD_NUM of structure type TYPE contains the
6258    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6259    a structure type with at least FIELD_NUM+1 fields.  */
6260
6261 int
6262 ada_is_parent_field (struct type *type, int field_num)
6263 {
6264   const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
6265
6266   return (name != NULL
6267           && (startswith (name, "PARENT")
6268               || startswith (name, "_parent")));
6269 }
6270
6271 /* True iff field number FIELD_NUM of structure type TYPE is a
6272    transparent wrapper field (which should be silently traversed when doing
6273    field selection and flattened when printing).  Assumes TYPE is a
6274    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6275    structures.  */
6276
6277 int
6278 ada_is_wrapper_field (struct type *type, int field_num)
6279 {
6280   const char *name = TYPE_FIELD_NAME (type, field_num);
6281
6282   if (name != NULL && strcmp (name, "RETVAL") == 0)
6283     {
6284       /* This happens in functions with "out" or "in out" parameters
6285          which are passed by copy.  For such functions, GNAT describes
6286          the function's return type as being a struct where the return
6287          value is in a field called RETVAL, and where the other "out"
6288          or "in out" parameters are fields of that struct.  This is not
6289          a wrapper.  */
6290       return 0;
6291     }
6292
6293   return (name != NULL
6294           && (startswith (name, "PARENT")
6295               || strcmp (name, "REP") == 0
6296               || startswith (name, "_parent")
6297               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6298 }
6299
6300 /* True iff field number FIELD_NUM of structure or union type TYPE
6301    is a variant wrapper.  Assumes TYPE is a structure type with at least
6302    FIELD_NUM+1 fields.  */
6303
6304 int
6305 ada_is_variant_part (struct type *type, int field_num)
6306 {
6307   /* Only Ada types are eligible.  */
6308   if (!ADA_TYPE_P (type))
6309     return 0;
6310
6311   struct type *field_type = type->field (field_num).type ();
6312
6313   return (field_type->code () == TYPE_CODE_UNION
6314           || (is_dynamic_field (type, field_num)
6315               && (TYPE_TARGET_TYPE (field_type)->code ()
6316                   == TYPE_CODE_UNION)));
6317 }
6318
6319 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6320    whose discriminants are contained in the record type OUTER_TYPE,
6321    returns the type of the controlling discriminant for the variant.
6322    May return NULL if the type could not be found.  */
6323
6324 struct type *
6325 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6326 {
6327   const char *name = ada_variant_discrim_name (var_type);
6328
6329   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6330 }
6331
6332 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6333    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6334    represents a 'when others' clause; otherwise 0.  */
6335
6336 static int
6337 ada_is_others_clause (struct type *type, int field_num)
6338 {
6339   const char *name = TYPE_FIELD_NAME (type, field_num);
6340
6341   return (name != NULL && name[0] == 'O');
6342 }
6343
6344 /* Assuming that TYPE0 is the type of the variant part of a record,
6345    returns the name of the discriminant controlling the variant.
6346    The value is valid until the next call to ada_variant_discrim_name.  */
6347
6348 const char *
6349 ada_variant_discrim_name (struct type *type0)
6350 {
6351   static std::string result;
6352   struct type *type;
6353   const char *name;
6354   const char *discrim_end;
6355   const char *discrim_start;
6356
6357   if (type0->code () == TYPE_CODE_PTR)
6358     type = TYPE_TARGET_TYPE (type0);
6359   else
6360     type = type0;
6361
6362   name = ada_type_name (type);
6363
6364   if (name == NULL || name[0] == '\000')
6365     return "";
6366
6367   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6368        discrim_end -= 1)
6369     {
6370       if (startswith (discrim_end, "___XVN"))
6371         break;
6372     }
6373   if (discrim_end == name)
6374     return "";
6375
6376   for (discrim_start = discrim_end; discrim_start != name + 3;
6377        discrim_start -= 1)
6378     {
6379       if (discrim_start == name + 1)
6380         return "";
6381       if ((discrim_start > name + 3
6382            && startswith (discrim_start - 3, "___"))
6383           || discrim_start[-1] == '.')
6384         break;
6385     }
6386
6387   result = std::string (discrim_start, discrim_end - discrim_start);
6388   return result.c_str ();
6389 }
6390
6391 /* Scan STR for a subtype-encoded number, beginning at position K.
6392    Put the position of the character just past the number scanned in
6393    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
6394    Return 1 if there was a valid number at the given position, and 0
6395    otherwise.  A "subtype-encoded" number consists of the absolute value
6396    in decimal, followed by the letter 'm' to indicate a negative number.
6397    Assumes 0m does not occur.  */
6398
6399 int
6400 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6401 {
6402   ULONGEST RU;
6403
6404   if (!isdigit (str[k]))
6405     return 0;
6406
6407   /* Do it the hard way so as not to make any assumption about
6408      the relationship of unsigned long (%lu scan format code) and
6409      LONGEST.  */
6410   RU = 0;
6411   while (isdigit (str[k]))
6412     {
6413       RU = RU * 10 + (str[k] - '0');
6414       k += 1;
6415     }
6416
6417   if (str[k] == 'm')
6418     {
6419       if (R != NULL)
6420         *R = (-(LONGEST) (RU - 1)) - 1;
6421       k += 1;
6422     }
6423   else if (R != NULL)
6424     *R = (LONGEST) RU;
6425
6426   /* NOTE on the above: Technically, C does not say what the results of
6427      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6428      number representable as a LONGEST (although either would probably work
6429      in most implementations).  When RU>0, the locution in the then branch
6430      above is always equivalent to the negative of RU.  */
6431
6432   if (new_k != NULL)
6433     *new_k = k;
6434   return 1;
6435 }
6436
6437 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6438    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6439    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
6440
6441 static int
6442 ada_in_variant (LONGEST val, struct type *type, int field_num)
6443 {
6444   const char *name = TYPE_FIELD_NAME (type, field_num);
6445   int p;
6446
6447   p = 0;
6448   while (1)
6449     {
6450       switch (name[p])
6451         {
6452         case '\0':
6453           return 0;
6454         case 'S':
6455           {
6456             LONGEST W;
6457
6458             if (!ada_scan_number (name, p + 1, &W, &p))
6459               return 0;
6460             if (val == W)
6461               return 1;
6462             break;
6463           }
6464         case 'R':
6465           {
6466             LONGEST L, U;
6467
6468             if (!ada_scan_number (name, p + 1, &L, &p)
6469                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6470               return 0;
6471             if (val >= L && val <= U)
6472               return 1;
6473             break;
6474           }
6475         case 'O':
6476           return 1;
6477         default:
6478           return 0;
6479         }
6480     }
6481 }
6482
6483 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
6484
6485 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6486    ARG_TYPE, extract and return the value of one of its (non-static)
6487    fields.  FIELDNO says which field.   Differs from value_primitive_field
6488    only in that it can handle packed values of arbitrary type.  */
6489
6490 struct value *
6491 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6492                            struct type *arg_type)
6493 {
6494   struct type *type;
6495
6496   arg_type = ada_check_typedef (arg_type);
6497   type = arg_type->field (fieldno).type ();
6498
6499   /* Handle packed fields.  It might be that the field is not packed
6500      relative to its containing structure, but the structure itself is
6501      packed; in this case we must take the bit-field path.  */
6502   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6503     {
6504       int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6505       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6506
6507       return ada_value_primitive_packed_val (arg1, value_contents (arg1),
6508                                              offset + bit_pos / 8,
6509                                              bit_pos % 8, bit_size, type);
6510     }
6511   else
6512     return value_primitive_field (arg1, offset, fieldno, arg_type);
6513 }
6514
6515 /* Find field with name NAME in object of type TYPE.  If found, 
6516    set the following for each argument that is non-null:
6517     - *FIELD_TYPE_P to the field's type; 
6518     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
6519       an object of that type;
6520     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
6521     - *BIT_SIZE_P to its size in bits if the field is packed, and 
6522       0 otherwise;
6523    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6524    fields up to but not including the desired field, or by the total
6525    number of fields if not found.   A NULL value of NAME never
6526    matches; the function just counts visible fields in this case.
6527    
6528    Notice that we need to handle when a tagged record hierarchy
6529    has some components with the same name, like in this scenario:
6530
6531       type Top_T is tagged record
6532          N : Integer := 1;
6533          U : Integer := 974;
6534          A : Integer := 48;
6535       end record;
6536
6537       type Middle_T is new Top.Top_T with record
6538          N : Character := 'a';
6539          C : Integer := 3;
6540       end record;
6541
6542      type Bottom_T is new Middle.Middle_T with record
6543         N : Float := 4.0;
6544         C : Character := '5';
6545         X : Integer := 6;
6546         A : Character := 'J';
6547      end record;
6548
6549    Let's say we now have a variable declared and initialized as follow:
6550
6551      TC : Top_A := new Bottom_T;
6552
6553    And then we use this variable to call this function
6554
6555      procedure Assign (Obj: in out Top_T; TV : Integer);
6556
6557    as follow:
6558
6559       Assign (Top_T (B), 12);
6560
6561    Now, we're in the debugger, and we're inside that procedure
6562    then and we want to print the value of obj.c:
6563
6564    Usually, the tagged record or one of the parent type owns the
6565    component to print and there's no issue but in this particular
6566    case, what does it mean to ask for Obj.C? Since the actual
6567    type for object is type Bottom_T, it could mean two things: type
6568    component C from the Middle_T view, but also component C from
6569    Bottom_T.  So in that "undefined" case, when the component is
6570    not found in the non-resolved type (which includes all the
6571    components of the parent type), then resolve it and see if we
6572    get better luck once expanded.
6573
6574    In the case of homonyms in the derived tagged type, we don't
6575    guaranty anything, and pick the one that's easiest for us
6576    to program.
6577
6578    Returns 1 if found, 0 otherwise.  */
6579
6580 static int
6581 find_struct_field (const char *name, struct type *type, int offset,
6582                    struct type **field_type_p,
6583                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6584                    int *index_p)
6585 {
6586   int i;
6587   int parent_offset = -1;
6588
6589   type = ada_check_typedef (type);
6590
6591   if (field_type_p != NULL)
6592     *field_type_p = NULL;
6593   if (byte_offset_p != NULL)
6594     *byte_offset_p = 0;
6595   if (bit_offset_p != NULL)
6596     *bit_offset_p = 0;
6597   if (bit_size_p != NULL)
6598     *bit_size_p = 0;
6599
6600   for (i = 0; i < type->num_fields (); i += 1)
6601     {
6602       int bit_pos = TYPE_FIELD_BITPOS (type, i);
6603       int fld_offset = offset + bit_pos / 8;
6604       const char *t_field_name = TYPE_FIELD_NAME (type, i);
6605
6606       if (t_field_name == NULL)
6607         continue;
6608
6609       else if (ada_is_parent_field (type, i))
6610         {
6611           /* This is a field pointing us to the parent type of a tagged
6612              type.  As hinted in this function's documentation, we give
6613              preference to fields in the current record first, so what
6614              we do here is just record the index of this field before
6615              we skip it.  If it turns out we couldn't find our field
6616              in the current record, then we'll get back to it and search
6617              inside it whether the field might exist in the parent.  */
6618
6619           parent_offset = i;
6620           continue;
6621         }
6622
6623       else if (name != NULL && field_name_match (t_field_name, name))
6624         {
6625           int bit_size = TYPE_FIELD_BITSIZE (type, i);
6626
6627           if (field_type_p != NULL)
6628             *field_type_p = type->field (i).type ();
6629           if (byte_offset_p != NULL)
6630             *byte_offset_p = fld_offset;
6631           if (bit_offset_p != NULL)
6632             *bit_offset_p = bit_pos % 8;
6633           if (bit_size_p != NULL)
6634             *bit_size_p = bit_size;
6635           return 1;
6636         }
6637       else if (ada_is_wrapper_field (type, i))
6638         {
6639           if (find_struct_field (name, type->field (i).type (), fld_offset,
6640                                  field_type_p, byte_offset_p, bit_offset_p,
6641                                  bit_size_p, index_p))
6642             return 1;
6643         }
6644       else if (ada_is_variant_part (type, i))
6645         {
6646           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
6647              fixed type?? */
6648           int j;
6649           struct type *field_type
6650             = ada_check_typedef (type->field (i).type ());
6651
6652           for (j = 0; j < field_type->num_fields (); j += 1)
6653             {
6654               if (find_struct_field (name, field_type->field (j).type (),
6655                                      fld_offset
6656                                      + TYPE_FIELD_BITPOS (field_type, j) / 8,
6657                                      field_type_p, byte_offset_p,
6658                                      bit_offset_p, bit_size_p, index_p))
6659                 return 1;
6660             }
6661         }
6662       else if (index_p != NULL)
6663         *index_p += 1;
6664     }
6665
6666   /* Field not found so far.  If this is a tagged type which
6667      has a parent, try finding that field in the parent now.  */
6668
6669   if (parent_offset != -1)
6670     {
6671       int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
6672       int fld_offset = offset + bit_pos / 8;
6673
6674       if (find_struct_field (name, type->field (parent_offset).type (),
6675                              fld_offset, field_type_p, byte_offset_p,
6676                              bit_offset_p, bit_size_p, index_p))
6677         return 1;
6678     }
6679
6680   return 0;
6681 }
6682
6683 /* Number of user-visible fields in record type TYPE.  */
6684
6685 static int
6686 num_visible_fields (struct type *type)
6687 {
6688   int n;
6689
6690   n = 0;
6691   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6692   return n;
6693 }
6694
6695 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
6696    and search in it assuming it has (class) type TYPE.
6697    If found, return value, else return NULL.
6698
6699    Searches recursively through wrapper fields (e.g., '_parent').
6700
6701    In the case of homonyms in the tagged types, please refer to the
6702    long explanation in find_struct_field's function documentation.  */
6703
6704 static struct value *
6705 ada_search_struct_field (const char *name, struct value *arg, int offset,
6706                          struct type *type)
6707 {
6708   int i;
6709   int parent_offset = -1;
6710
6711   type = ada_check_typedef (type);
6712   for (i = 0; i < type->num_fields (); i += 1)
6713     {
6714       const char *t_field_name = TYPE_FIELD_NAME (type, i);
6715
6716       if (t_field_name == NULL)
6717         continue;
6718
6719       else if (ada_is_parent_field (type, i))
6720         {
6721           /* This is a field pointing us to the parent type of a tagged
6722              type.  As hinted in this function's documentation, we give
6723              preference to fields in the current record first, so what
6724              we do here is just record the index of this field before
6725              we skip it.  If it turns out we couldn't find our field
6726              in the current record, then we'll get back to it and search
6727              inside it whether the field might exist in the parent.  */
6728
6729           parent_offset = i;
6730           continue;
6731         }
6732
6733       else if (field_name_match (t_field_name, name))
6734         return ada_value_primitive_field (arg, offset, i, type);
6735
6736       else if (ada_is_wrapper_field (type, i))
6737         {
6738           struct value *v =     /* Do not let indent join lines here.  */
6739             ada_search_struct_field (name, arg,
6740                                      offset + TYPE_FIELD_BITPOS (type, i) / 8,
6741                                      type->field (i).type ());
6742
6743           if (v != NULL)
6744             return v;
6745         }
6746
6747       else if (ada_is_variant_part (type, i))
6748         {
6749           /* PNH: Do we ever get here?  See find_struct_field.  */
6750           int j;
6751           struct type *field_type = ada_check_typedef (type->field (i).type ());
6752           int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6753
6754           for (j = 0; j < field_type->num_fields (); j += 1)
6755             {
6756               struct value *v = ada_search_struct_field /* Force line
6757                                                            break.  */
6758                 (name, arg,
6759                  var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6760                  field_type->field (j).type ());
6761
6762               if (v != NULL)
6763                 return v;
6764             }
6765         }
6766     }
6767
6768   /* Field not found so far.  If this is a tagged type which
6769      has a parent, try finding that field in the parent now.  */
6770
6771   if (parent_offset != -1)
6772     {
6773       struct value *v = ada_search_struct_field (
6774         name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
6775         type->field (parent_offset).type ());
6776
6777       if (v != NULL)
6778         return v;
6779     }
6780
6781   return NULL;
6782 }
6783
6784 static struct value *ada_index_struct_field_1 (int *, struct value *,
6785                                                int, struct type *);
6786
6787
6788 /* Return field #INDEX in ARG, where the index is that returned by
6789  * find_struct_field through its INDEX_P argument.  Adjust the address
6790  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6791  * If found, return value, else return NULL.  */
6792
6793 static struct value *
6794 ada_index_struct_field (int index, struct value *arg, int offset,
6795                         struct type *type)
6796 {
6797   return ada_index_struct_field_1 (&index, arg, offset, type);
6798 }
6799
6800
6801 /* Auxiliary function for ada_index_struct_field.  Like
6802  * ada_index_struct_field, but takes index from *INDEX_P and modifies
6803  * *INDEX_P.  */
6804
6805 static struct value *
6806 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6807                           struct type *type)
6808 {
6809   int i;
6810   type = ada_check_typedef (type);
6811
6812   for (i = 0; i < type->num_fields (); i += 1)
6813     {
6814       if (TYPE_FIELD_NAME (type, i) == NULL)
6815         continue;
6816       else if (ada_is_wrapper_field (type, i))
6817         {
6818           struct value *v =     /* Do not let indent join lines here.  */
6819             ada_index_struct_field_1 (index_p, arg,
6820                                       offset + TYPE_FIELD_BITPOS (type, i) / 8,
6821                                       type->field (i).type ());
6822
6823           if (v != NULL)
6824             return v;
6825         }
6826
6827       else if (ada_is_variant_part (type, i))
6828         {
6829           /* PNH: Do we ever get here?  See ada_search_struct_field,
6830              find_struct_field.  */
6831           error (_("Cannot assign this kind of variant record"));
6832         }
6833       else if (*index_p == 0)
6834         return ada_value_primitive_field (arg, offset, i, type);
6835       else
6836         *index_p -= 1;
6837     }
6838   return NULL;
6839 }
6840
6841 /* Return a string representation of type TYPE.  */
6842
6843 static std::string
6844 type_as_string (struct type *type)
6845 {
6846   string_file tmp_stream;
6847
6848   type_print (type, "", &tmp_stream, -1);
6849
6850   return std::move (tmp_stream.string ());
6851 }
6852
6853 /* Given a type TYPE, look up the type of the component of type named NAME.
6854    If DISPP is non-null, add its byte displacement from the beginning of a
6855    structure (pointed to by a value) of type TYPE to *DISPP (does not
6856    work for packed fields).
6857
6858    Matches any field whose name has NAME as a prefix, possibly
6859    followed by "___".
6860
6861    TYPE can be either a struct or union.  If REFOK, TYPE may also 
6862    be a (pointer or reference)+ to a struct or union, and the
6863    ultimate target type will be searched.
6864
6865    Looks recursively into variant clauses and parent types.
6866
6867    In the case of homonyms in the tagged types, please refer to the
6868    long explanation in find_struct_field's function documentation.
6869
6870    If NOERR is nonzero, return NULL if NAME is not suitably defined or
6871    TYPE is not a type of the right kind.  */
6872
6873 static struct type *
6874 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
6875                             int noerr)
6876 {
6877   int i;
6878   int parent_offset = -1;
6879
6880   if (name == NULL)
6881     goto BadName;
6882
6883   if (refok && type != NULL)
6884     while (1)
6885       {
6886         type = ada_check_typedef (type);
6887         if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
6888           break;
6889         type = TYPE_TARGET_TYPE (type);
6890       }
6891
6892   if (type == NULL
6893       || (type->code () != TYPE_CODE_STRUCT
6894           && type->code () != TYPE_CODE_UNION))
6895     {
6896       if (noerr)
6897         return NULL;
6898
6899       error (_("Type %s is not a structure or union type"),
6900              type != NULL ? type_as_string (type).c_str () : _("(null)"));
6901     }
6902
6903   type = to_static_fixed_type (type);
6904
6905   for (i = 0; i < type->num_fields (); i += 1)
6906     {
6907       const char *t_field_name = TYPE_FIELD_NAME (type, i);
6908       struct type *t;
6909
6910       if (t_field_name == NULL)
6911         continue;
6912
6913       else if (ada_is_parent_field (type, i))
6914         {
6915           /* This is a field pointing us to the parent type of a tagged
6916              type.  As hinted in this function's documentation, we give
6917              preference to fields in the current record first, so what
6918              we do here is just record the index of this field before
6919              we skip it.  If it turns out we couldn't find our field
6920              in the current record, then we'll get back to it and search
6921              inside it whether the field might exist in the parent.  */
6922
6923           parent_offset = i;
6924           continue;
6925         }
6926
6927       else if (field_name_match (t_field_name, name))
6928         return type->field (i).type ();
6929
6930       else if (ada_is_wrapper_field (type, i))
6931         {
6932           t = ada_lookup_struct_elt_type (type->field (i).type (), name,
6933                                           0, 1);
6934           if (t != NULL)
6935             return t;
6936         }
6937
6938       else if (ada_is_variant_part (type, i))
6939         {
6940           int j;
6941           struct type *field_type = ada_check_typedef (type->field (i).type ());
6942
6943           for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
6944             {
6945               /* FIXME pnh 2008/01/26: We check for a field that is
6946                  NOT wrapped in a struct, since the compiler sometimes
6947                  generates these for unchecked variant types.  Revisit
6948                  if the compiler changes this practice.  */
6949               const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
6950
6951               if (v_field_name != NULL 
6952                   && field_name_match (v_field_name, name))
6953                 t = field_type->field (j).type ();
6954               else
6955                 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
6956                                                 name, 0, 1);
6957
6958               if (t != NULL)
6959                 return t;
6960             }
6961         }
6962
6963     }
6964
6965     /* Field not found so far.  If this is a tagged type which
6966        has a parent, try finding that field in the parent now.  */
6967
6968     if (parent_offset != -1)
6969       {
6970         struct type *t;
6971
6972         t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
6973                                         name, 0, 1);
6974         if (t != NULL)
6975           return t;
6976       }
6977
6978 BadName:
6979   if (!noerr)
6980     {
6981       const char *name_str = name != NULL ? name : _("<null>");
6982
6983       error (_("Type %s has no component named %s"),
6984              type_as_string (type).c_str (), name_str);
6985     }
6986
6987   return NULL;
6988 }
6989
6990 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6991    within a value of type OUTER_TYPE, return true iff VAR_TYPE
6992    represents an unchecked union (that is, the variant part of a
6993    record that is named in an Unchecked_Union pragma).  */
6994
6995 static int
6996 is_unchecked_variant (struct type *var_type, struct type *outer_type)
6997 {
6998   const char *discrim_name = ada_variant_discrim_name (var_type);
6999
7000   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7001 }
7002
7003
7004 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7005    within OUTER, determine which variant clause (field number in VAR_TYPE,
7006    numbering from 0) is applicable.  Returns -1 if none are.  */
7007
7008 int
7009 ada_which_variant_applies (struct type *var_type, struct value *outer)
7010 {
7011   int others_clause;
7012   int i;
7013   const char *discrim_name = ada_variant_discrim_name (var_type);
7014   struct value *discrim;
7015   LONGEST discrim_val;
7016
7017   /* Using plain value_from_contents_and_address here causes problems
7018      because we will end up trying to resolve a type that is currently
7019      being constructed.  */
7020   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7021   if (discrim == NULL)
7022     return -1;
7023   discrim_val = value_as_long (discrim);
7024
7025   others_clause = -1;
7026   for (i = 0; i < var_type->num_fields (); i += 1)
7027     {
7028       if (ada_is_others_clause (var_type, i))
7029         others_clause = i;
7030       else if (ada_in_variant (discrim_val, var_type, i))
7031         return i;
7032     }
7033
7034   return others_clause;
7035 }
7036 \f
7037
7038
7039                                 /* Dynamic-Sized Records */
7040
7041 /* Strategy: The type ostensibly attached to a value with dynamic size
7042    (i.e., a size that is not statically recorded in the debugging
7043    data) does not accurately reflect the size or layout of the value.
7044    Our strategy is to convert these values to values with accurate,
7045    conventional types that are constructed on the fly.  */
7046
7047 /* There is a subtle and tricky problem here.  In general, we cannot
7048    determine the size of dynamic records without its data.  However,
7049    the 'struct value' data structure, which GDB uses to represent
7050    quantities in the inferior process (the target), requires the size
7051    of the type at the time of its allocation in order to reserve space
7052    for GDB's internal copy of the data.  That's why the
7053    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7054    rather than struct value*s.
7055
7056    However, GDB's internal history variables ($1, $2, etc.) are
7057    struct value*s containing internal copies of the data that are not, in
7058    general, the same as the data at their corresponding addresses in
7059    the target.  Fortunately, the types we give to these values are all
7060    conventional, fixed-size types (as per the strategy described
7061    above), so that we don't usually have to perform the
7062    'to_fixed_xxx_type' conversions to look at their values.
7063    Unfortunately, there is one exception: if one of the internal
7064    history variables is an array whose elements are unconstrained
7065    records, then we will need to create distinct fixed types for each
7066    element selected.  */
7067
7068 /* The upshot of all of this is that many routines take a (type, host
7069    address, target address) triple as arguments to represent a value.
7070    The host address, if non-null, is supposed to contain an internal
7071    copy of the relevant data; otherwise, the program is to consult the
7072    target at the target address.  */
7073
7074 /* Assuming that VAL0 represents a pointer value, the result of
7075    dereferencing it.  Differs from value_ind in its treatment of
7076    dynamic-sized types.  */
7077
7078 struct value *
7079 ada_value_ind (struct value *val0)
7080 {
7081   struct value *val = value_ind (val0);
7082
7083   if (ada_is_tagged_type (value_type (val), 0))
7084     val = ada_tag_value_at_base_address (val);
7085
7086   return ada_to_fixed_value (val);
7087 }
7088
7089 /* The value resulting from dereferencing any "reference to"
7090    qualifiers on VAL0.  */
7091
7092 static struct value *
7093 ada_coerce_ref (struct value *val0)
7094 {
7095   if (value_type (val0)->code () == TYPE_CODE_REF)
7096     {
7097       struct value *val = val0;
7098
7099       val = coerce_ref (val);
7100
7101       if (ada_is_tagged_type (value_type (val), 0))
7102         val = ada_tag_value_at_base_address (val);
7103
7104       return ada_to_fixed_value (val);
7105     }
7106   else
7107     return val0;
7108 }
7109
7110 /* Return the bit alignment required for field #F of template type TYPE.  */
7111
7112 static unsigned int
7113 field_alignment (struct type *type, int f)
7114 {
7115   const char *name = TYPE_FIELD_NAME (type, f);
7116   int len;
7117   int align_offset;
7118
7119   /* The field name should never be null, unless the debugging information
7120      is somehow malformed.  In this case, we assume the field does not
7121      require any alignment.  */
7122   if (name == NULL)
7123     return 1;
7124
7125   len = strlen (name);
7126
7127   if (!isdigit (name[len - 1]))
7128     return 1;
7129
7130   if (isdigit (name[len - 2]))
7131     align_offset = len - 2;
7132   else
7133     align_offset = len - 1;
7134
7135   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7136     return TARGET_CHAR_BIT;
7137
7138   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7139 }
7140
7141 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7142
7143 static struct symbol *
7144 ada_find_any_type_symbol (const char *name)
7145 {
7146   struct symbol *sym;
7147
7148   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7149   if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7150     return sym;
7151
7152   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7153   return sym;
7154 }
7155
7156 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7157    solely for types defined by debug info, it will not search the GDB
7158    primitive types.  */
7159
7160 static struct type *
7161 ada_find_any_type (const char *name)
7162 {
7163   struct symbol *sym = ada_find_any_type_symbol (name);
7164
7165   if (sym != NULL)
7166     return SYMBOL_TYPE (sym);
7167
7168   return NULL;
7169 }
7170
7171 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7172    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
7173    symbol, in which case it is returned.  Otherwise, this looks for
7174    symbols whose name is that of NAME_SYM suffixed with  "___XR".
7175    Return symbol if found, and NULL otherwise.  */
7176
7177 static bool
7178 ada_is_renaming_symbol (struct symbol *name_sym)
7179 {
7180   const char *name = name_sym->linkage_name ();
7181   return strstr (name, "___XR") != NULL;
7182 }
7183
7184 /* Because of GNAT encoding conventions, several GDB symbols may match a
7185    given type name.  If the type denoted by TYPE0 is to be preferred to
7186    that of TYPE1 for purposes of type printing, return non-zero;
7187    otherwise return 0.  */
7188
7189 int
7190 ada_prefer_type (struct type *type0, struct type *type1)
7191 {
7192   if (type1 == NULL)
7193     return 1;
7194   else if (type0 == NULL)
7195     return 0;
7196   else if (type1->code () == TYPE_CODE_VOID)
7197     return 1;
7198   else if (type0->code () == TYPE_CODE_VOID)
7199     return 0;
7200   else if (type1->name () == NULL && type0->name () != NULL)
7201     return 1;
7202   else if (ada_is_constrained_packed_array_type (type0))
7203     return 1;
7204   else if (ada_is_array_descriptor_type (type0)
7205            && !ada_is_array_descriptor_type (type1))
7206     return 1;
7207   else
7208     {
7209       const char *type0_name = type0->name ();
7210       const char *type1_name = type1->name ();
7211
7212       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7213           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7214         return 1;
7215     }
7216   return 0;
7217 }
7218
7219 /* The name of TYPE, which is its TYPE_NAME.  Null if TYPE is
7220    null.  */
7221
7222 const char *
7223 ada_type_name (struct type *type)
7224 {
7225   if (type == NULL)
7226     return NULL;
7227   return type->name ();
7228 }
7229
7230 /* Search the list of "descriptive" types associated to TYPE for a type
7231    whose name is NAME.  */
7232
7233 static struct type *
7234 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7235 {
7236   struct type *result, *tmp;
7237
7238   if (ada_ignore_descriptive_types_p)
7239     return NULL;
7240
7241   /* If there no descriptive-type info, then there is no parallel type
7242      to be found.  */
7243   if (!HAVE_GNAT_AUX_INFO (type))
7244     return NULL;
7245
7246   result = TYPE_DESCRIPTIVE_TYPE (type);
7247   while (result != NULL)
7248     {
7249       const char *result_name = ada_type_name (result);
7250
7251       if (result_name == NULL)
7252         {
7253           warning (_("unexpected null name on descriptive type"));
7254           return NULL;
7255         }
7256
7257       /* If the names match, stop.  */
7258       if (strcmp (result_name, name) == 0)
7259         break;
7260
7261       /* Otherwise, look at the next item on the list, if any.  */
7262       if (HAVE_GNAT_AUX_INFO (result))
7263         tmp = TYPE_DESCRIPTIVE_TYPE (result);
7264       else
7265         tmp = NULL;
7266
7267       /* If not found either, try after having resolved the typedef.  */
7268       if (tmp != NULL)
7269         result = tmp;
7270       else
7271         {
7272           result = check_typedef (result);
7273           if (HAVE_GNAT_AUX_INFO (result))
7274             result = TYPE_DESCRIPTIVE_TYPE (result);
7275           else
7276             result = NULL;
7277         }
7278     }
7279
7280   /* If we didn't find a match, see whether this is a packed array.  With
7281      older compilers, the descriptive type information is either absent or
7282      irrelevant when it comes to packed arrays so the above lookup fails.
7283      Fall back to using a parallel lookup by name in this case.  */
7284   if (result == NULL && ada_is_constrained_packed_array_type (type))
7285     return ada_find_any_type (name);
7286
7287   return result;
7288 }
7289
7290 /* Find a parallel type to TYPE with the specified NAME, using the
7291    descriptive type taken from the debugging information, if available,
7292    and otherwise using the (slower) name-based method.  */
7293
7294 static struct type *
7295 ada_find_parallel_type_with_name (struct type *type, const char *name)
7296 {
7297   struct type *result = NULL;
7298
7299   if (HAVE_GNAT_AUX_INFO (type))
7300     result = find_parallel_type_by_descriptive_type (type, name);
7301   else
7302     result = ada_find_any_type (name);
7303
7304   return result;
7305 }
7306
7307 /* Same as above, but specify the name of the parallel type by appending
7308    SUFFIX to the name of TYPE.  */
7309
7310 struct type *
7311 ada_find_parallel_type (struct type *type, const char *suffix)
7312 {
7313   char *name;
7314   const char *type_name = ada_type_name (type);
7315   int len;
7316
7317   if (type_name == NULL)
7318     return NULL;
7319
7320   len = strlen (type_name);
7321
7322   name = (char *) alloca (len + strlen (suffix) + 1);
7323
7324   strcpy (name, type_name);
7325   strcpy (name + len, suffix);
7326
7327   return ada_find_parallel_type_with_name (type, name);
7328 }
7329
7330 /* If TYPE is a variable-size record type, return the corresponding template
7331    type describing its fields.  Otherwise, return NULL.  */
7332
7333 static struct type *
7334 dynamic_template_type (struct type *type)
7335 {
7336   type = ada_check_typedef (type);
7337
7338   if (type == NULL || type->code () != TYPE_CODE_STRUCT
7339       || ada_type_name (type) == NULL)
7340     return NULL;
7341   else
7342     {
7343       int len = strlen (ada_type_name (type));
7344
7345       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7346         return type;
7347       else
7348         return ada_find_parallel_type (type, "___XVE");
7349     }
7350 }
7351
7352 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7353    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
7354
7355 static int
7356 is_dynamic_field (struct type *templ_type, int field_num)
7357 {
7358   const char *name = TYPE_FIELD_NAME (templ_type, field_num);
7359
7360   return name != NULL
7361     && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7362     && strstr (name, "___XVL") != NULL;
7363 }
7364
7365 /* The index of the variant field of TYPE, or -1 if TYPE does not
7366    represent a variant record type.  */
7367
7368 static int
7369 variant_field_index (struct type *type)
7370 {
7371   int f;
7372
7373   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7374     return -1;
7375
7376   for (f = 0; f < type->num_fields (); f += 1)
7377     {
7378       if (ada_is_variant_part (type, f))
7379         return f;
7380     }
7381   return -1;
7382 }
7383
7384 /* A record type with no fields.  */
7385
7386 static struct type *
7387 empty_record (struct type *templ)
7388 {
7389   struct type *type = alloc_type_copy (templ);
7390
7391   type->set_code (TYPE_CODE_STRUCT);
7392   INIT_NONE_SPECIFIC (type);
7393   type->set_name ("<empty>");
7394   TYPE_LENGTH (type) = 0;
7395   return type;
7396 }
7397
7398 /* An ordinary record type (with fixed-length fields) that describes
7399    the value of type TYPE at VALADDR or ADDRESS (see comments at
7400    the beginning of this section) VAL according to GNAT conventions.
7401    DVAL0 should describe the (portion of a) record that contains any
7402    necessary discriminants.  It should be NULL if value_type (VAL) is
7403    an outer-level type (i.e., as opposed to a branch of a variant.)  A
7404    variant field (unless unchecked) is replaced by a particular branch
7405    of the variant.
7406
7407    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7408    length are not statically known are discarded.  As a consequence,
7409    VALADDR, ADDRESS and DVAL0 are ignored.
7410
7411    NOTE: Limitations: For now, we assume that dynamic fields and
7412    variants occupy whole numbers of bytes.  However, they need not be
7413    byte-aligned.  */
7414
7415 struct type *
7416 ada_template_to_fixed_record_type_1 (struct type *type,
7417                                      const gdb_byte *valaddr,
7418                                      CORE_ADDR address, struct value *dval0,
7419                                      int keep_dynamic_fields)
7420 {
7421   struct value *mark = value_mark ();
7422   struct value *dval;
7423   struct type *rtype;
7424   int nfields, bit_len;
7425   int variant_field;
7426   long off;
7427   int fld_bit_len;
7428   int f;
7429
7430   /* Compute the number of fields in this record type that are going
7431      to be processed: unless keep_dynamic_fields, this includes only
7432      fields whose position and length are static will be processed.  */
7433   if (keep_dynamic_fields)
7434     nfields = type->num_fields ();
7435   else
7436     {
7437       nfields = 0;
7438       while (nfields < type->num_fields ()
7439              && !ada_is_variant_part (type, nfields)
7440              && !is_dynamic_field (type, nfields))
7441         nfields++;
7442     }
7443
7444   rtype = alloc_type_copy (type);
7445   rtype->set_code (TYPE_CODE_STRUCT);
7446   INIT_NONE_SPECIFIC (rtype);
7447   rtype->set_num_fields (nfields);
7448   rtype->set_fields
7449    ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7450   rtype->set_name (ada_type_name (type));
7451   rtype->set_is_fixed_instance (true);
7452
7453   off = 0;
7454   bit_len = 0;
7455   variant_field = -1;
7456
7457   for (f = 0; f < nfields; f += 1)
7458     {
7459       off = align_up (off, field_alignment (type, f))
7460         + TYPE_FIELD_BITPOS (type, f);
7461       SET_FIELD_BITPOS (rtype->field (f), off);
7462       TYPE_FIELD_BITSIZE (rtype, f) = 0;
7463
7464       if (ada_is_variant_part (type, f))
7465         {
7466           variant_field = f;
7467           fld_bit_len = 0;
7468         }
7469       else if (is_dynamic_field (type, f))
7470         {
7471           const gdb_byte *field_valaddr = valaddr;
7472           CORE_ADDR field_address = address;
7473           struct type *field_type =
7474             TYPE_TARGET_TYPE (type->field (f).type ());
7475
7476           if (dval0 == NULL)
7477             {
7478               /* rtype's length is computed based on the run-time
7479                  value of discriminants.  If the discriminants are not
7480                  initialized, the type size may be completely bogus and
7481                  GDB may fail to allocate a value for it.  So check the
7482                  size first before creating the value.  */
7483               ada_ensure_varsize_limit (rtype);
7484               /* Using plain value_from_contents_and_address here
7485                  causes problems because we will end up trying to
7486                  resolve a type that is currently being
7487                  constructed.  */
7488               dval = value_from_contents_and_address_unresolved (rtype,
7489                                                                  valaddr,
7490                                                                  address);
7491               rtype = value_type (dval);
7492             }
7493           else
7494             dval = dval0;
7495
7496           /* If the type referenced by this field is an aligner type, we need
7497              to unwrap that aligner type, because its size might not be set.
7498              Keeping the aligner type would cause us to compute the wrong
7499              size for this field, impacting the offset of the all the fields
7500              that follow this one.  */
7501           if (ada_is_aligner_type (field_type))
7502             {
7503               long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7504
7505               field_valaddr = cond_offset_host (field_valaddr, field_offset);
7506               field_address = cond_offset_target (field_address, field_offset);
7507               field_type = ada_aligned_type (field_type);
7508             }
7509
7510           field_valaddr = cond_offset_host (field_valaddr,
7511                                             off / TARGET_CHAR_BIT);
7512           field_address = cond_offset_target (field_address,
7513                                               off / TARGET_CHAR_BIT);
7514
7515           /* Get the fixed type of the field.  Note that, in this case,
7516              we do not want to get the real type out of the tag: if
7517              the current field is the parent part of a tagged record,
7518              we will get the tag of the object.  Clearly wrong: the real
7519              type of the parent is not the real type of the child.  We
7520              would end up in an infinite loop.  */
7521           field_type = ada_get_base_type (field_type);
7522           field_type = ada_to_fixed_type (field_type, field_valaddr,
7523                                           field_address, dval, 0);
7524           /* If the field size is already larger than the maximum
7525              object size, then the record itself will necessarily
7526              be larger than the maximum object size.  We need to make
7527              this check now, because the size might be so ridiculously
7528              large (due to an uninitialized variable in the inferior)
7529              that it would cause an overflow when adding it to the
7530              record size.  */
7531           ada_ensure_varsize_limit (field_type);
7532
7533           rtype->field (f).set_type (field_type);
7534           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7535           /* The multiplication can potentially overflow.  But because
7536              the field length has been size-checked just above, and
7537              assuming that the maximum size is a reasonable value,
7538              an overflow should not happen in practice.  So rather than
7539              adding overflow recovery code to this already complex code,
7540              we just assume that it's not going to happen.  */
7541           fld_bit_len =
7542             TYPE_LENGTH (rtype->field (f).type ()) * TARGET_CHAR_BIT;
7543         }
7544       else
7545         {
7546           /* Note: If this field's type is a typedef, it is important
7547              to preserve the typedef layer.
7548
7549              Otherwise, we might be transforming a typedef to a fat
7550              pointer (encoding a pointer to an unconstrained array),
7551              into a basic fat pointer (encoding an unconstrained
7552              array).  As both types are implemented using the same
7553              structure, the typedef is the only clue which allows us
7554              to distinguish between the two options.  Stripping it
7555              would prevent us from printing this field appropriately.  */
7556           rtype->field (f).set_type (type->field (f).type ());
7557           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7558           if (TYPE_FIELD_BITSIZE (type, f) > 0)
7559             fld_bit_len =
7560               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7561           else
7562             {
7563               struct type *field_type = type->field (f).type ();
7564
7565               /* We need to be careful of typedefs when computing
7566                  the length of our field.  If this is a typedef,
7567                  get the length of the target type, not the length
7568                  of the typedef.  */
7569               if (field_type->code () == TYPE_CODE_TYPEDEF)
7570                 field_type = ada_typedef_target_type (field_type);
7571
7572               fld_bit_len =
7573                 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7574             }
7575         }
7576       if (off + fld_bit_len > bit_len)
7577         bit_len = off + fld_bit_len;
7578       off += fld_bit_len;
7579       TYPE_LENGTH (rtype) =
7580         align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7581     }
7582
7583   /* We handle the variant part, if any, at the end because of certain
7584      odd cases in which it is re-ordered so as NOT to be the last field of
7585      the record.  This can happen in the presence of representation
7586      clauses.  */
7587   if (variant_field >= 0)
7588     {
7589       struct type *branch_type;
7590
7591       off = TYPE_FIELD_BITPOS (rtype, variant_field);
7592
7593       if (dval0 == NULL)
7594         {
7595           /* Using plain value_from_contents_and_address here causes
7596              problems because we will end up trying to resolve a type
7597              that is currently being constructed.  */
7598           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
7599                                                              address);
7600           rtype = value_type (dval);
7601         }
7602       else
7603         dval = dval0;
7604
7605       branch_type =
7606         to_fixed_variant_branch_type
7607         (type->field (variant_field).type (),
7608          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7609          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7610       if (branch_type == NULL)
7611         {
7612           for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
7613             rtype->field (f - 1) = rtype->field (f);
7614           rtype->set_num_fields (rtype->num_fields () - 1);
7615         }
7616       else
7617         {
7618           rtype->field (variant_field).set_type (branch_type);
7619           TYPE_FIELD_NAME (rtype, variant_field) = "S";
7620           fld_bit_len =
7621             TYPE_LENGTH (rtype->field (variant_field).type ()) *
7622             TARGET_CHAR_BIT;
7623           if (off + fld_bit_len > bit_len)
7624             bit_len = off + fld_bit_len;
7625           TYPE_LENGTH (rtype) =
7626             align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7627         }
7628     }
7629
7630   /* According to exp_dbug.ads, the size of TYPE for variable-size records
7631      should contain the alignment of that record, which should be a strictly
7632      positive value.  If null or negative, then something is wrong, most
7633      probably in the debug info.  In that case, we don't round up the size
7634      of the resulting type.  If this record is not part of another structure,
7635      the current RTYPE length might be good enough for our purposes.  */
7636   if (TYPE_LENGTH (type) <= 0)
7637     {
7638       if (rtype->name ())
7639         warning (_("Invalid type size for `%s' detected: %s."),
7640                  rtype->name (), pulongest (TYPE_LENGTH (type)));
7641       else
7642         warning (_("Invalid type size for <unnamed> detected: %s."),
7643                  pulongest (TYPE_LENGTH (type)));
7644     }
7645   else
7646     {
7647       TYPE_LENGTH (rtype) = align_up (TYPE_LENGTH (rtype),
7648                                       TYPE_LENGTH (type));
7649     }
7650
7651   value_free_to_mark (mark);
7652   if (TYPE_LENGTH (rtype) > varsize_limit)
7653     error (_("record type with dynamic size is larger than varsize-limit"));
7654   return rtype;
7655 }
7656
7657 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7658    of 1.  */
7659
7660 static struct type *
7661 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
7662                                CORE_ADDR address, struct value *dval0)
7663 {
7664   return ada_template_to_fixed_record_type_1 (type, valaddr,
7665                                               address, dval0, 1);
7666 }
7667
7668 /* An ordinary record type in which ___XVL-convention fields and
7669    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7670    static approximations, containing all possible fields.  Uses
7671    no runtime values.  Useless for use in values, but that's OK,
7672    since the results are used only for type determinations.   Works on both
7673    structs and unions.  Representation note: to save space, we memorize
7674    the result of this function in the TYPE_TARGET_TYPE of the
7675    template type.  */
7676
7677 static struct type *
7678 template_to_static_fixed_type (struct type *type0)
7679 {
7680   struct type *type;
7681   int nfields;
7682   int f;
7683
7684   /* No need no do anything if the input type is already fixed.  */
7685   if (type0->is_fixed_instance ())
7686     return type0;
7687
7688   /* Likewise if we already have computed the static approximation.  */
7689   if (TYPE_TARGET_TYPE (type0) != NULL)
7690     return TYPE_TARGET_TYPE (type0);
7691
7692   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
7693   type = type0;
7694   nfields = type0->num_fields ();
7695
7696   /* Whether or not we cloned TYPE0, cache the result so that we don't do
7697      recompute all over next time.  */
7698   TYPE_TARGET_TYPE (type0) = type;
7699
7700   for (f = 0; f < nfields; f += 1)
7701     {
7702       struct type *field_type = type0->field (f).type ();
7703       struct type *new_type;
7704
7705       if (is_dynamic_field (type0, f))
7706         {
7707           field_type = ada_check_typedef (field_type);
7708           new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
7709         }
7710       else
7711         new_type = static_unwrap_type (field_type);
7712
7713       if (new_type != field_type)
7714         {
7715           /* Clone TYPE0 only the first time we get a new field type.  */
7716           if (type == type0)
7717             {
7718               TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
7719               type->set_code (type0->code ());
7720               INIT_NONE_SPECIFIC (type);
7721               type->set_num_fields (nfields);
7722
7723               field *fields =
7724                 ((struct field *)
7725                  TYPE_ALLOC (type, nfields * sizeof (struct field)));
7726               memcpy (fields, type0->fields (),
7727                       sizeof (struct field) * nfields);
7728               type->set_fields (fields);
7729
7730               type->set_name (ada_type_name (type0));
7731               type->set_is_fixed_instance (true);
7732               TYPE_LENGTH (type) = 0;
7733             }
7734           type->field (f).set_type (new_type);
7735           TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
7736         }
7737     }
7738
7739   return type;
7740 }
7741
7742 /* Given an object of type TYPE whose contents are at VALADDR and
7743    whose address in memory is ADDRESS, returns a revision of TYPE,
7744    which should be a non-dynamic-sized record, in which the variant
7745    part, if any, is replaced with the appropriate branch.  Looks
7746    for discriminant values in DVAL0, which can be NULL if the record
7747    contains the necessary discriminant values.  */
7748
7749 static struct type *
7750 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
7751                                    CORE_ADDR address, struct value *dval0)
7752 {
7753   struct value *mark = value_mark ();
7754   struct value *dval;
7755   struct type *rtype;
7756   struct type *branch_type;
7757   int nfields = type->num_fields ();
7758   int variant_field = variant_field_index (type);
7759
7760   if (variant_field == -1)
7761     return type;
7762
7763   if (dval0 == NULL)
7764     {
7765       dval = value_from_contents_and_address (type, valaddr, address);
7766       type = value_type (dval);
7767     }
7768   else
7769     dval = dval0;
7770
7771   rtype = alloc_type_copy (type);
7772   rtype->set_code (TYPE_CODE_STRUCT);
7773   INIT_NONE_SPECIFIC (rtype);
7774   rtype->set_num_fields (nfields);
7775
7776   field *fields =
7777     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7778   memcpy (fields, type->fields (), sizeof (struct field) * nfields);
7779   rtype->set_fields (fields);
7780
7781   rtype->set_name (ada_type_name (type));
7782   rtype->set_is_fixed_instance (true);
7783   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7784
7785   branch_type = to_fixed_variant_branch_type
7786     (type->field (variant_field).type (),
7787      cond_offset_host (valaddr,
7788                        TYPE_FIELD_BITPOS (type, variant_field)
7789                        / TARGET_CHAR_BIT),
7790      cond_offset_target (address,
7791                          TYPE_FIELD_BITPOS (type, variant_field)
7792                          / TARGET_CHAR_BIT), dval);
7793   if (branch_type == NULL)
7794     {
7795       int f;
7796
7797       for (f = variant_field + 1; f < nfields; f += 1)
7798         rtype->field (f - 1) = rtype->field (f);
7799       rtype->set_num_fields (rtype->num_fields () - 1);
7800     }
7801   else
7802     {
7803       rtype->field (variant_field).set_type (branch_type);
7804       TYPE_FIELD_NAME (rtype, variant_field) = "S";
7805       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
7806       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
7807     }
7808   TYPE_LENGTH (rtype) -= TYPE_LENGTH (type->field (variant_field).type ());
7809
7810   value_free_to_mark (mark);
7811   return rtype;
7812 }
7813
7814 /* An ordinary record type (with fixed-length fields) that describes
7815    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7816    beginning of this section].   Any necessary discriminants' values
7817    should be in DVAL, a record value; it may be NULL if the object
7818    at ADDR itself contains any necessary discriminant values.
7819    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7820    values from the record are needed.  Except in the case that DVAL,
7821    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7822    unchecked) is replaced by a particular branch of the variant.
7823
7824    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7825    is questionable and may be removed.  It can arise during the
7826    processing of an unconstrained-array-of-record type where all the
7827    variant branches have exactly the same size.  This is because in
7828    such cases, the compiler does not bother to use the XVS convention
7829    when encoding the record.  I am currently dubious of this
7830    shortcut and suspect the compiler should be altered.  FIXME.  */
7831
7832 static struct type *
7833 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
7834                       CORE_ADDR address, struct value *dval)
7835 {
7836   struct type *templ_type;
7837
7838   if (type0->is_fixed_instance ())
7839     return type0;
7840
7841   templ_type = dynamic_template_type (type0);
7842
7843   if (templ_type != NULL)
7844     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
7845   else if (variant_field_index (type0) >= 0)
7846     {
7847       if (dval == NULL && valaddr == NULL && address == 0)
7848         return type0;
7849       return to_record_with_fixed_variant_part (type0, valaddr, address,
7850                                                 dval);
7851     }
7852   else
7853     {
7854       type0->set_is_fixed_instance (true);
7855       return type0;
7856     }
7857
7858 }
7859
7860 /* An ordinary record type (with fixed-length fields) that describes
7861    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7862    union type.  Any necessary discriminants' values should be in DVAL,
7863    a record value.  That is, this routine selects the appropriate
7864    branch of the union at ADDR according to the discriminant value
7865    indicated in the union's type name.  Returns VAR_TYPE0 itself if
7866    it represents a variant subject to a pragma Unchecked_Union.  */
7867
7868 static struct type *
7869 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
7870                               CORE_ADDR address, struct value *dval)
7871 {
7872   int which;
7873   struct type *templ_type;
7874   struct type *var_type;
7875
7876   if (var_type0->code () == TYPE_CODE_PTR)
7877     var_type = TYPE_TARGET_TYPE (var_type0);
7878   else
7879     var_type = var_type0;
7880
7881   templ_type = ada_find_parallel_type (var_type, "___XVU");
7882
7883   if (templ_type != NULL)
7884     var_type = templ_type;
7885
7886   if (is_unchecked_variant (var_type, value_type (dval)))
7887       return var_type0;
7888   which = ada_which_variant_applies (var_type, dval);
7889
7890   if (which < 0)
7891     return empty_record (var_type);
7892   else if (is_dynamic_field (var_type, which))
7893     return to_fixed_record_type
7894       (TYPE_TARGET_TYPE (var_type->field (which).type ()),
7895        valaddr, address, dval);
7896   else if (variant_field_index (var_type->field (which).type ()) >= 0)
7897     return
7898       to_fixed_record_type
7899       (var_type->field (which).type (), valaddr, address, dval);
7900   else
7901     return var_type->field (which).type ();
7902 }
7903
7904 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
7905    ENCODING_TYPE, a type following the GNAT conventions for discrete
7906    type encodings, only carries redundant information.  */
7907
7908 static int
7909 ada_is_redundant_range_encoding (struct type *range_type,
7910                                  struct type *encoding_type)
7911 {
7912   const char *bounds_str;
7913   int n;
7914   LONGEST lo, hi;
7915
7916   gdb_assert (range_type->code () == TYPE_CODE_RANGE);
7917
7918   if (get_base_type (range_type)->code ()
7919       != get_base_type (encoding_type)->code ())
7920     {
7921       /* The compiler probably used a simple base type to describe
7922          the range type instead of the range's actual base type,
7923          expecting us to get the real base type from the encoding
7924          anyway.  In this situation, the encoding cannot be ignored
7925          as redundant.  */
7926       return 0;
7927     }
7928
7929   if (is_dynamic_type (range_type))
7930     return 0;
7931
7932   if (encoding_type->name () == NULL)
7933     return 0;
7934
7935   bounds_str = strstr (encoding_type->name (), "___XDLU_");
7936   if (bounds_str == NULL)
7937     return 0;
7938
7939   n = 8; /* Skip "___XDLU_".  */
7940   if (!ada_scan_number (bounds_str, n, &lo, &n))
7941     return 0;
7942   if (range_type->bounds ()->low.const_val () != lo)
7943     return 0;
7944
7945   n += 2; /* Skip the "__" separator between the two bounds.  */
7946   if (!ada_scan_number (bounds_str, n, &hi, &n))
7947     return 0;
7948   if (range_type->bounds ()->high.const_val () != hi)
7949     return 0;
7950
7951   return 1;
7952 }
7953
7954 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
7955    a type following the GNAT encoding for describing array type
7956    indices, only carries redundant information.  */
7957
7958 static int
7959 ada_is_redundant_index_type_desc (struct type *array_type,
7960                                   struct type *desc_type)
7961 {
7962   struct type *this_layer = check_typedef (array_type);
7963   int i;
7964
7965   for (i = 0; i < desc_type->num_fields (); i++)
7966     {
7967       if (!ada_is_redundant_range_encoding (this_layer->index_type (),
7968                                             desc_type->field (i).type ()))
7969         return 0;
7970       this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
7971     }
7972
7973   return 1;
7974 }
7975
7976 /* Assuming that TYPE0 is an array type describing the type of a value
7977    at ADDR, and that DVAL describes a record containing any
7978    discriminants used in TYPE0, returns a type for the value that
7979    contains no dynamic components (that is, no components whose sizes
7980    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
7981    true, gives an error message if the resulting type's size is over
7982    varsize_limit.  */
7983
7984 static struct type *
7985 to_fixed_array_type (struct type *type0, struct value *dval,
7986                      int ignore_too_big)
7987 {
7988   struct type *index_type_desc;
7989   struct type *result;
7990   int constrained_packed_array_p;
7991   static const char *xa_suffix = "___XA";
7992
7993   type0 = ada_check_typedef (type0);
7994   if (type0->is_fixed_instance ())
7995     return type0;
7996
7997   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
7998   if (constrained_packed_array_p)
7999     {
8000       type0 = decode_constrained_packed_array_type (type0);
8001       if (type0 == nullptr)
8002         error (_("could not decode constrained packed array type"));
8003     }
8004
8005   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8006
8007   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8008      encoding suffixed with 'P' may still be generated.  If so,
8009      it should be used to find the XA type.  */
8010
8011   if (index_type_desc == NULL)
8012     {
8013       const char *type_name = ada_type_name (type0);
8014
8015       if (type_name != NULL)
8016         {
8017           const int len = strlen (type_name);
8018           char *name = (char *) alloca (len + strlen (xa_suffix));
8019
8020           if (type_name[len - 1] == 'P')
8021             {
8022               strcpy (name, type_name);
8023               strcpy (name + len - 1, xa_suffix);
8024               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8025             }
8026         }
8027     }
8028
8029   ada_fixup_array_indexes_type (index_type_desc);
8030   if (index_type_desc != NULL
8031       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8032     {
8033       /* Ignore this ___XA parallel type, as it does not bring any
8034          useful information.  This allows us to avoid creating fixed
8035          versions of the array's index types, which would be identical
8036          to the original ones.  This, in turn, can also help avoid
8037          the creation of fixed versions of the array itself.  */
8038       index_type_desc = NULL;
8039     }
8040
8041   if (index_type_desc == NULL)
8042     {
8043       struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8044
8045       /* NOTE: elt_type---the fixed version of elt_type0---should never
8046          depend on the contents of the array in properly constructed
8047          debugging data.  */
8048       /* Create a fixed version of the array element type.
8049          We're not providing the address of an element here,
8050          and thus the actual object value cannot be inspected to do
8051          the conversion.  This should not be a problem, since arrays of
8052          unconstrained objects are not allowed.  In particular, all
8053          the elements of an array of a tagged type should all be of
8054          the same type specified in the debugging info.  No need to
8055          consult the object tag.  */
8056       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8057
8058       /* Make sure we always create a new array type when dealing with
8059          packed array types, since we're going to fix-up the array
8060          type length and element bitsize a little further down.  */
8061       if (elt_type0 == elt_type && !constrained_packed_array_p)
8062         result = type0;
8063       else
8064         result = create_array_type (alloc_type_copy (type0),
8065                                     elt_type, type0->index_type ());
8066     }
8067   else
8068     {
8069       int i;
8070       struct type *elt_type0;
8071
8072       elt_type0 = type0;
8073       for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8074         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8075
8076       /* NOTE: result---the fixed version of elt_type0---should never
8077          depend on the contents of the array in properly constructed
8078          debugging data.  */
8079       /* Create a fixed version of the array element type.
8080          We're not providing the address of an element here,
8081          and thus the actual object value cannot be inspected to do
8082          the conversion.  This should not be a problem, since arrays of
8083          unconstrained objects are not allowed.  In particular, all
8084          the elements of an array of a tagged type should all be of
8085          the same type specified in the debugging info.  No need to
8086          consult the object tag.  */
8087       result =
8088         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8089
8090       elt_type0 = type0;
8091       for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8092         {
8093           struct type *range_type =
8094             to_fixed_range_type (index_type_desc->field (i).type (), dval);
8095
8096           result = create_array_type (alloc_type_copy (elt_type0),
8097                                       result, range_type);
8098           elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8099         }
8100       if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
8101         error (_("array type with dynamic size is larger than varsize-limit"));
8102     }
8103
8104   /* We want to preserve the type name.  This can be useful when
8105      trying to get the type name of a value that has already been
8106      printed (for instance, if the user did "print VAR; whatis $".  */
8107   result->set_name (type0->name ());
8108
8109   if (constrained_packed_array_p)
8110     {
8111       /* So far, the resulting type has been created as if the original
8112          type was a regular (non-packed) array type.  As a result, the
8113          bitsize of the array elements needs to be set again, and the array
8114          length needs to be recomputed based on that bitsize.  */
8115       int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8116       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8117
8118       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8119       TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8120       if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8121         TYPE_LENGTH (result)++;
8122     }
8123
8124   result->set_is_fixed_instance (true);
8125   return result;
8126 }
8127
8128
8129 /* A standard type (containing no dynamically sized components)
8130    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8131    DVAL describes a record containing any discriminants used in TYPE0,
8132    and may be NULL if there are none, or if the object of type TYPE at
8133    ADDRESS or in VALADDR contains these discriminants.
8134    
8135    If CHECK_TAG is not null, in the case of tagged types, this function
8136    attempts to locate the object's tag and use it to compute the actual
8137    type.  However, when ADDRESS is null, we cannot use it to determine the
8138    location of the tag, and therefore compute the tagged type's actual type.
8139    So we return the tagged type without consulting the tag.  */
8140    
8141 static struct type *
8142 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8143                    CORE_ADDR address, struct value *dval, int check_tag)
8144 {
8145   type = ada_check_typedef (type);
8146
8147   /* Only un-fixed types need to be handled here.  */
8148   if (!HAVE_GNAT_AUX_INFO (type))
8149     return type;
8150
8151   switch (type->code ())
8152     {
8153     default:
8154       return type;
8155     case TYPE_CODE_STRUCT:
8156       {
8157         struct type *static_type = to_static_fixed_type (type);
8158         struct type *fixed_record_type =
8159           to_fixed_record_type (type, valaddr, address, NULL);
8160
8161         /* If STATIC_TYPE is a tagged type and we know the object's address,
8162            then we can determine its tag, and compute the object's actual
8163            type from there.  Note that we have to use the fixed record
8164            type (the parent part of the record may have dynamic fields
8165            and the way the location of _tag is expressed may depend on
8166            them).  */
8167
8168         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8169           {
8170             struct value *tag =
8171               value_tag_from_contents_and_address
8172               (fixed_record_type,
8173                valaddr,
8174                address);
8175             struct type *real_type = type_from_tag (tag);
8176             struct value *obj =
8177               value_from_contents_and_address (fixed_record_type,
8178                                                valaddr,
8179                                                address);
8180             fixed_record_type = value_type (obj);
8181             if (real_type != NULL)
8182               return to_fixed_record_type
8183                 (real_type, NULL,
8184                  value_address (ada_tag_value_at_base_address (obj)), NULL);
8185           }
8186
8187         /* Check to see if there is a parallel ___XVZ variable.
8188            If there is, then it provides the actual size of our type.  */
8189         else if (ada_type_name (fixed_record_type) != NULL)
8190           {
8191             const char *name = ada_type_name (fixed_record_type);
8192             char *xvz_name
8193               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8194             bool xvz_found = false;
8195             LONGEST size;
8196
8197             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8198             try
8199               {
8200                 xvz_found = get_int_var_value (xvz_name, size);
8201               }
8202             catch (const gdb_exception_error &except)
8203               {
8204                 /* We found the variable, but somehow failed to read
8205                    its value.  Rethrow the same error, but with a little
8206                    bit more information, to help the user understand
8207                    what went wrong (Eg: the variable might have been
8208                    optimized out).  */
8209                 throw_error (except.error,
8210                              _("unable to read value of %s (%s)"),
8211                              xvz_name, except.what ());
8212               }
8213
8214             if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8215               {
8216                 fixed_record_type = copy_type (fixed_record_type);
8217                 TYPE_LENGTH (fixed_record_type) = size;
8218
8219                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
8220                    observed this when the debugging info is STABS, and
8221                    apparently it is something that is hard to fix.
8222
8223                    In practice, we don't need the actual type definition
8224                    at all, because the presence of the XVZ variable allows us
8225                    to assume that there must be a XVS type as well, which we
8226                    should be able to use later, when we need the actual type
8227                    definition.
8228
8229                    In the meantime, pretend that the "fixed" type we are
8230                    returning is NOT a stub, because this can cause trouble
8231                    when using this type to create new types targeting it.
8232                    Indeed, the associated creation routines often check
8233                    whether the target type is a stub and will try to replace
8234                    it, thus using a type with the wrong size.  This, in turn,
8235                    might cause the new type to have the wrong size too.
8236                    Consider the case of an array, for instance, where the size
8237                    of the array is computed from the number of elements in
8238                    our array multiplied by the size of its element.  */
8239                 fixed_record_type->set_is_stub (false);
8240               }
8241           }
8242         return fixed_record_type;
8243       }
8244     case TYPE_CODE_ARRAY:
8245       return to_fixed_array_type (type, dval, 1);
8246     case TYPE_CODE_UNION:
8247       if (dval == NULL)
8248         return type;
8249       else
8250         return to_fixed_variant_branch_type (type, valaddr, address, dval);
8251     }
8252 }
8253
8254 /* The same as ada_to_fixed_type_1, except that it preserves the type
8255    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8256
8257    The typedef layer needs be preserved in order to differentiate between
8258    arrays and array pointers when both types are implemented using the same
8259    fat pointer.  In the array pointer case, the pointer is encoded as
8260    a typedef of the pointer type.  For instance, considering:
8261
8262           type String_Access is access String;
8263           S1 : String_Access := null;
8264
8265    To the debugger, S1 is defined as a typedef of type String.  But
8266    to the user, it is a pointer.  So if the user tries to print S1,
8267    we should not dereference the array, but print the array address
8268    instead.
8269
8270    If we didn't preserve the typedef layer, we would lose the fact that
8271    the type is to be presented as a pointer (needs de-reference before
8272    being printed).  And we would also use the source-level type name.  */
8273
8274 struct type *
8275 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8276                    CORE_ADDR address, struct value *dval, int check_tag)
8277
8278 {
8279   struct type *fixed_type =
8280     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8281
8282   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8283       then preserve the typedef layer.
8284
8285       Implementation note: We can only check the main-type portion of
8286       the TYPE and FIXED_TYPE, because eliminating the typedef layer
8287       from TYPE now returns a type that has the same instance flags
8288       as TYPE.  For instance, if TYPE is a "typedef const", and its
8289       target type is a "struct", then the typedef elimination will return
8290       a "const" version of the target type.  See check_typedef for more
8291       details about how the typedef layer elimination is done.
8292
8293       brobecker/2010-11-19: It seems to me that the only case where it is
8294       useful to preserve the typedef layer is when dealing with fat pointers.
8295       Perhaps, we could add a check for that and preserve the typedef layer
8296       only in that situation.  But this seems unnecessary so far, probably
8297       because we call check_typedef/ada_check_typedef pretty much everywhere.
8298       */
8299   if (type->code () == TYPE_CODE_TYPEDEF
8300       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8301           == TYPE_MAIN_TYPE (fixed_type)))
8302     return type;
8303
8304   return fixed_type;
8305 }
8306
8307 /* A standard (static-sized) type corresponding as well as possible to
8308    TYPE0, but based on no runtime data.  */
8309
8310 static struct type *
8311 to_static_fixed_type (struct type *type0)
8312 {
8313   struct type *type;
8314
8315   if (type0 == NULL)
8316     return NULL;
8317
8318   if (type0->is_fixed_instance ())
8319     return type0;
8320
8321   type0 = ada_check_typedef (type0);
8322
8323   switch (type0->code ())
8324     {
8325     default:
8326       return type0;
8327     case TYPE_CODE_STRUCT:
8328       type = dynamic_template_type (type0);
8329       if (type != NULL)
8330         return template_to_static_fixed_type (type);
8331       else
8332         return template_to_static_fixed_type (type0);
8333     case TYPE_CODE_UNION:
8334       type = ada_find_parallel_type (type0, "___XVU");
8335       if (type != NULL)
8336         return template_to_static_fixed_type (type);
8337       else
8338         return template_to_static_fixed_type (type0);
8339     }
8340 }
8341
8342 /* A static approximation of TYPE with all type wrappers removed.  */
8343
8344 static struct type *
8345 static_unwrap_type (struct type *type)
8346 {
8347   if (ada_is_aligner_type (type))
8348     {
8349       struct type *type1 = ada_check_typedef (type)->field (0).type ();
8350       if (ada_type_name (type1) == NULL)
8351         type1->set_name (ada_type_name (type));
8352
8353       return static_unwrap_type (type1);
8354     }
8355   else
8356     {
8357       struct type *raw_real_type = ada_get_base_type (type);
8358
8359       if (raw_real_type == type)
8360         return type;
8361       else
8362         return to_static_fixed_type (raw_real_type);
8363     }
8364 }
8365
8366 /* In some cases, incomplete and private types require
8367    cross-references that are not resolved as records (for example,
8368       type Foo;
8369       type FooP is access Foo;
8370       V: FooP;
8371       type Foo is array ...;
8372    ).  In these cases, since there is no mechanism for producing
8373    cross-references to such types, we instead substitute for FooP a
8374    stub enumeration type that is nowhere resolved, and whose tag is
8375    the name of the actual type.  Call these types "non-record stubs".  */
8376
8377 /* A type equivalent to TYPE that is not a non-record stub, if one
8378    exists, otherwise TYPE.  */
8379
8380 struct type *
8381 ada_check_typedef (struct type *type)
8382 {
8383   if (type == NULL)
8384     return NULL;
8385
8386   /* If our type is an access to an unconstrained array, which is encoded
8387      as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8388      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8389      what allows us to distinguish between fat pointers that represent
8390      array types, and fat pointers that represent array access types
8391      (in both cases, the compiler implements them as fat pointers).  */
8392   if (ada_is_access_to_unconstrained_array (type))
8393     return type;
8394
8395   type = check_typedef (type);
8396   if (type == NULL || type->code () != TYPE_CODE_ENUM
8397       || !type->is_stub ()
8398       || type->name () == NULL)
8399     return type;
8400   else
8401     {
8402       const char *name = type->name ();
8403       struct type *type1 = ada_find_any_type (name);
8404
8405       if (type1 == NULL)
8406         return type;
8407
8408       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8409          stubs pointing to arrays, as we don't create symbols for array
8410          types, only for the typedef-to-array types).  If that's the case,
8411          strip the typedef layer.  */
8412       if (type1->code () == TYPE_CODE_TYPEDEF)
8413         type1 = ada_check_typedef (type1);
8414
8415       return type1;
8416     }
8417 }
8418
8419 /* A value representing the data at VALADDR/ADDRESS as described by
8420    type TYPE0, but with a standard (static-sized) type that correctly
8421    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
8422    type, then return VAL0 [this feature is simply to avoid redundant
8423    creation of struct values].  */
8424
8425 static struct value *
8426 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8427                            struct value *val0)
8428 {
8429   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8430
8431   if (type == type0 && val0 != NULL)
8432     return val0;
8433
8434   if (VALUE_LVAL (val0) != lval_memory)
8435     {
8436       /* Our value does not live in memory; it could be a convenience
8437          variable, for instance.  Create a not_lval value using val0's
8438          contents.  */
8439       return value_from_contents (type, value_contents (val0));
8440     }
8441
8442   return value_from_contents_and_address (type, 0, address);
8443 }
8444
8445 /* A value representing VAL, but with a standard (static-sized) type
8446    that correctly describes it.  Does not necessarily create a new
8447    value.  */
8448
8449 struct value *
8450 ada_to_fixed_value (struct value *val)
8451 {
8452   val = unwrap_value (val);
8453   val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8454   return val;
8455 }
8456 \f
8457
8458 /* Attributes */
8459
8460 /* Table mapping attribute numbers to names.
8461    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
8462
8463 static const char * const attribute_names[] = {
8464   "<?>",
8465
8466   "first",
8467   "last",
8468   "length",
8469   "image",
8470   "max",
8471   "min",
8472   "modulus",
8473   "pos",
8474   "size",
8475   "tag",
8476   "val",
8477   0
8478 };
8479
8480 static const char *
8481 ada_attribute_name (enum exp_opcode n)
8482 {
8483   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8484     return attribute_names[n - OP_ATR_FIRST + 1];
8485   else
8486     return attribute_names[0];
8487 }
8488
8489 /* Evaluate the 'POS attribute applied to ARG.  */
8490
8491 static LONGEST
8492 pos_atr (struct value *arg)
8493 {
8494   struct value *val = coerce_ref (arg);
8495   struct type *type = value_type (val);
8496
8497   if (!discrete_type_p (type))
8498     error (_("'POS only defined on discrete types"));
8499
8500   gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8501   if (!result.has_value ())
8502     error (_("enumeration value is invalid: can't find 'POS"));
8503
8504   return *result;
8505 }
8506
8507 struct value *
8508 ada_pos_atr (struct type *expect_type,
8509              struct expression *exp,
8510              enum noside noside, enum exp_opcode op,
8511              struct value *arg)
8512 {
8513   struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8514   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8515     return value_zero (type, not_lval);
8516   return value_from_longest (type, pos_atr (arg));
8517 }
8518
8519 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
8520
8521 static struct value *
8522 val_atr (struct type *type, LONGEST val)
8523 {
8524   gdb_assert (discrete_type_p (type));
8525   if (type->code () == TYPE_CODE_RANGE)
8526     type = TYPE_TARGET_TYPE (type);
8527   if (type->code () == TYPE_CODE_ENUM)
8528     {
8529       if (val < 0 || val >= type->num_fields ())
8530         error (_("argument to 'VAL out of range"));
8531       val = TYPE_FIELD_ENUMVAL (type, val);
8532     }
8533   return value_from_longest (type, val);
8534 }
8535
8536 struct value *
8537 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8538 {
8539   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8540     return value_zero (type, not_lval);
8541
8542   if (!discrete_type_p (type))
8543     error (_("'VAL only defined on discrete types"));
8544   if (!integer_type_p (value_type (arg)))
8545     error (_("'VAL requires integral argument"));
8546
8547   return val_atr (type, value_as_long (arg));
8548 }
8549 \f
8550
8551                                 /* Evaluation */
8552
8553 /* True if TYPE appears to be an Ada character type.
8554    [At the moment, this is true only for Character and Wide_Character;
8555    It is a heuristic test that could stand improvement].  */
8556
8557 bool
8558 ada_is_character_type (struct type *type)
8559 {
8560   const char *name;
8561
8562   /* If the type code says it's a character, then assume it really is,
8563      and don't check any further.  */
8564   if (type->code () == TYPE_CODE_CHAR)
8565     return true;
8566   
8567   /* Otherwise, assume it's a character type iff it is a discrete type
8568      with a known character type name.  */
8569   name = ada_type_name (type);
8570   return (name != NULL
8571           && (type->code () == TYPE_CODE_INT
8572               || type->code () == TYPE_CODE_RANGE)
8573           && (strcmp (name, "character") == 0
8574               || strcmp (name, "wide_character") == 0
8575               || strcmp (name, "wide_wide_character") == 0
8576               || strcmp (name, "unsigned char") == 0));
8577 }
8578
8579 /* True if TYPE appears to be an Ada string type.  */
8580
8581 bool
8582 ada_is_string_type (struct type *type)
8583 {
8584   type = ada_check_typedef (type);
8585   if (type != NULL
8586       && type->code () != TYPE_CODE_PTR
8587       && (ada_is_simple_array_type (type)
8588           || ada_is_array_descriptor_type (type))
8589       && ada_array_arity (type) == 1)
8590     {
8591       struct type *elttype = ada_array_element_type (type, 1);
8592
8593       return ada_is_character_type (elttype);
8594     }
8595   else
8596     return false;
8597 }
8598
8599 /* The compiler sometimes provides a parallel XVS type for a given
8600    PAD type.  Normally, it is safe to follow the PAD type directly,
8601    but older versions of the compiler have a bug that causes the offset
8602    of its "F" field to be wrong.  Following that field in that case
8603    would lead to incorrect results, but this can be worked around
8604    by ignoring the PAD type and using the associated XVS type instead.
8605
8606    Set to True if the debugger should trust the contents of PAD types.
8607    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
8608 static bool trust_pad_over_xvs = true;
8609
8610 /* True if TYPE is a struct type introduced by the compiler to force the
8611    alignment of a value.  Such types have a single field with a
8612    distinctive name.  */
8613
8614 int
8615 ada_is_aligner_type (struct type *type)
8616 {
8617   type = ada_check_typedef (type);
8618
8619   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
8620     return 0;
8621
8622   return (type->code () == TYPE_CODE_STRUCT
8623           && type->num_fields () == 1
8624           && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
8625 }
8626
8627 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8628    the parallel type.  */
8629
8630 struct type *
8631 ada_get_base_type (struct type *raw_type)
8632 {
8633   struct type *real_type_namer;
8634   struct type *raw_real_type;
8635
8636   if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
8637     return raw_type;
8638
8639   if (ada_is_aligner_type (raw_type))
8640     /* The encoding specifies that we should always use the aligner type.
8641        So, even if this aligner type has an associated XVS type, we should
8642        simply ignore it.
8643
8644        According to the compiler gurus, an XVS type parallel to an aligner
8645        type may exist because of a stabs limitation.  In stabs, aligner
8646        types are empty because the field has a variable-sized type, and
8647        thus cannot actually be used as an aligner type.  As a result,
8648        we need the associated parallel XVS type to decode the type.
8649        Since the policy in the compiler is to not change the internal
8650        representation based on the debugging info format, we sometimes
8651        end up having a redundant XVS type parallel to the aligner type.  */
8652     return raw_type;
8653
8654   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
8655   if (real_type_namer == NULL
8656       || real_type_namer->code () != TYPE_CODE_STRUCT
8657       || real_type_namer->num_fields () != 1)
8658     return raw_type;
8659
8660   if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
8661     {
8662       /* This is an older encoding form where the base type needs to be
8663          looked up by name.  We prefer the newer encoding because it is
8664          more efficient.  */
8665       raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
8666       if (raw_real_type == NULL)
8667         return raw_type;
8668       else
8669         return raw_real_type;
8670     }
8671
8672   /* The field in our XVS type is a reference to the base type.  */
8673   return TYPE_TARGET_TYPE (real_type_namer->field (0).type ());
8674 }
8675
8676 /* The type of value designated by TYPE, with all aligners removed.  */
8677
8678 struct type *
8679 ada_aligned_type (struct type *type)
8680 {
8681   if (ada_is_aligner_type (type))
8682     return ada_aligned_type (type->field (0).type ());
8683   else
8684     return ada_get_base_type (type);
8685 }
8686
8687
8688 /* The address of the aligned value in an object at address VALADDR
8689    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
8690
8691 const gdb_byte *
8692 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
8693 {
8694   if (ada_is_aligner_type (type))
8695     return ada_aligned_value_addr (type->field (0).type (),
8696                                    valaddr +
8697                                    TYPE_FIELD_BITPOS (type,
8698                                                       0) / TARGET_CHAR_BIT);
8699   else
8700     return valaddr;
8701 }
8702
8703
8704
8705 /* The printed representation of an enumeration literal with encoded
8706    name NAME.  The value is good to the next call of ada_enum_name.  */
8707 const char *
8708 ada_enum_name (const char *name)
8709 {
8710   static std::string storage;
8711   const char *tmp;
8712
8713   /* First, unqualify the enumeration name:
8714      1. Search for the last '.' character.  If we find one, then skip
8715      all the preceding characters, the unqualified name starts
8716      right after that dot.
8717      2. Otherwise, we may be debugging on a target where the compiler
8718      translates dots into "__".  Search forward for double underscores,
8719      but stop searching when we hit an overloading suffix, which is
8720      of the form "__" followed by digits.  */
8721
8722   tmp = strrchr (name, '.');
8723   if (tmp != NULL)
8724     name = tmp + 1;
8725   else
8726     {
8727       while ((tmp = strstr (name, "__")) != NULL)
8728         {
8729           if (isdigit (tmp[2]))
8730             break;
8731           else
8732             name = tmp + 2;
8733         }
8734     }
8735
8736   if (name[0] == 'Q')
8737     {
8738       int v;
8739
8740       if (name[1] == 'U' || name[1] == 'W')
8741         {
8742           if (sscanf (name + 2, "%x", &v) != 1)
8743             return name;
8744         }
8745       else if (((name[1] >= '0' && name[1] <= '9')
8746                 || (name[1] >= 'a' && name[1] <= 'z'))
8747                && name[2] == '\0')
8748         {
8749           storage = string_printf ("'%c'", name[1]);
8750           return storage.c_str ();
8751         }
8752       else
8753         return name;
8754
8755       if (isascii (v) && isprint (v))
8756         storage = string_printf ("'%c'", v);
8757       else if (name[1] == 'U')
8758         storage = string_printf ("[\"%02x\"]", v);
8759       else
8760         storage = string_printf ("[\"%04x\"]", v);
8761
8762       return storage.c_str ();
8763     }
8764   else
8765     {
8766       tmp = strstr (name, "__");
8767       if (tmp == NULL)
8768         tmp = strstr (name, "$");
8769       if (tmp != NULL)
8770         {
8771           storage = std::string (name, tmp - name);
8772           return storage.c_str ();
8773         }
8774
8775       return name;
8776     }
8777 }
8778
8779 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8780    value it wraps.  */
8781
8782 static struct value *
8783 unwrap_value (struct value *val)
8784 {
8785   struct type *type = ada_check_typedef (value_type (val));
8786
8787   if (ada_is_aligner_type (type))
8788     {
8789       struct value *v = ada_value_struct_elt (val, "F", 0);
8790       struct type *val_type = ada_check_typedef (value_type (v));
8791
8792       if (ada_type_name (val_type) == NULL)
8793         val_type->set_name (ada_type_name (type));
8794
8795       return unwrap_value (v);
8796     }
8797   else
8798     {
8799       struct type *raw_real_type =
8800         ada_check_typedef (ada_get_base_type (type));
8801
8802       /* If there is no parallel XVS or XVE type, then the value is
8803          already unwrapped.  Return it without further modification.  */
8804       if ((type == raw_real_type)
8805           && ada_find_parallel_type (type, "___XVE") == NULL)
8806         return val;
8807
8808       return
8809         coerce_unspec_val_to_type
8810         (val, ada_to_fixed_type (raw_real_type, 0,
8811                                  value_address (val),
8812                                  NULL, 1));
8813     }
8814 }
8815
8816 /* Given two array types T1 and T2, return nonzero iff both arrays
8817    contain the same number of elements.  */
8818
8819 static int
8820 ada_same_array_size_p (struct type *t1, struct type *t2)
8821 {
8822   LONGEST lo1, hi1, lo2, hi2;
8823
8824   /* Get the array bounds in order to verify that the size of
8825      the two arrays match.  */
8826   if (!get_array_bounds (t1, &lo1, &hi1)
8827       || !get_array_bounds (t2, &lo2, &hi2))
8828     error (_("unable to determine array bounds"));
8829
8830   /* To make things easier for size comparison, normalize a bit
8831      the case of empty arrays by making sure that the difference
8832      between upper bound and lower bound is always -1.  */
8833   if (lo1 > hi1)
8834     hi1 = lo1 - 1;
8835   if (lo2 > hi2)
8836     hi2 = lo2 - 1;
8837
8838   return (hi1 - lo1 == hi2 - lo2);
8839 }
8840
8841 /* Assuming that VAL is an array of integrals, and TYPE represents
8842    an array with the same number of elements, but with wider integral
8843    elements, return an array "casted" to TYPE.  In practice, this
8844    means that the returned array is built by casting each element
8845    of the original array into TYPE's (wider) element type.  */
8846
8847 static struct value *
8848 ada_promote_array_of_integrals (struct type *type, struct value *val)
8849 {
8850   struct type *elt_type = TYPE_TARGET_TYPE (type);
8851   LONGEST lo, hi;
8852   struct value *res;
8853   LONGEST i;
8854
8855   /* Verify that both val and type are arrays of scalars, and
8856      that the size of val's elements is smaller than the size
8857      of type's element.  */
8858   gdb_assert (type->code () == TYPE_CODE_ARRAY);
8859   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
8860   gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
8861   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
8862   gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
8863               > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
8864
8865   if (!get_array_bounds (type, &lo, &hi))
8866     error (_("unable to determine array bounds"));
8867
8868   res = allocate_value (type);
8869
8870   /* Promote each array element.  */
8871   for (i = 0; i < hi - lo + 1; i++)
8872     {
8873       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
8874
8875       memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
8876               value_contents_all (elt), TYPE_LENGTH (elt_type));
8877     }
8878
8879   return res;
8880 }
8881
8882 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8883    return the converted value.  */
8884
8885 static struct value *
8886 coerce_for_assign (struct type *type, struct value *val)
8887 {
8888   struct type *type2 = value_type (val);
8889
8890   if (type == type2)
8891     return val;
8892
8893   type2 = ada_check_typedef (type2);
8894   type = ada_check_typedef (type);
8895
8896   if (type2->code () == TYPE_CODE_PTR
8897       && type->code () == TYPE_CODE_ARRAY)
8898     {
8899       val = ada_value_ind (val);
8900       type2 = value_type (val);
8901     }
8902
8903   if (type2->code () == TYPE_CODE_ARRAY
8904       && type->code () == TYPE_CODE_ARRAY)
8905     {
8906       if (!ada_same_array_size_p (type, type2))
8907         error (_("cannot assign arrays of different length"));
8908
8909       if (is_integral_type (TYPE_TARGET_TYPE (type))
8910           && is_integral_type (TYPE_TARGET_TYPE (type2))
8911           && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8912                < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8913         {
8914           /* Allow implicit promotion of the array elements to
8915              a wider type.  */
8916           return ada_promote_array_of_integrals (type, val);
8917         }
8918
8919       if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8920           != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8921         error (_("Incompatible types in assignment"));
8922       deprecated_set_value_type (val, type);
8923     }
8924   return val;
8925 }
8926
8927 static struct value *
8928 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
8929 {
8930   struct value *val;
8931   struct type *type1, *type2;
8932   LONGEST v, v1, v2;
8933
8934   arg1 = coerce_ref (arg1);
8935   arg2 = coerce_ref (arg2);
8936   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
8937   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
8938
8939   if (type1->code () != TYPE_CODE_INT
8940       || type2->code () != TYPE_CODE_INT)
8941     return value_binop (arg1, arg2, op);
8942
8943   switch (op)
8944     {
8945     case BINOP_MOD:
8946     case BINOP_DIV:
8947     case BINOP_REM:
8948       break;
8949     default:
8950       return value_binop (arg1, arg2, op);
8951     }
8952
8953   v2 = value_as_long (arg2);
8954   if (v2 == 0)
8955     {
8956       const char *name;
8957       if (op == BINOP_MOD)
8958         name = "mod";
8959       else if (op == BINOP_DIV)
8960         name = "/";
8961       else
8962         {
8963           gdb_assert (op == BINOP_REM);
8964           name = "rem";
8965         }
8966
8967       error (_("second operand of %s must not be zero."), name);
8968     }
8969
8970   if (type1->is_unsigned () || op == BINOP_MOD)
8971     return value_binop (arg1, arg2, op);
8972
8973   v1 = value_as_long (arg1);
8974   switch (op)
8975     {
8976     case BINOP_DIV:
8977       v = v1 / v2;
8978       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
8979         v += v > 0 ? -1 : 1;
8980       break;
8981     case BINOP_REM:
8982       v = v1 % v2;
8983       if (v * v1 < 0)
8984         v -= v2;
8985       break;
8986     default:
8987       /* Should not reach this point.  */
8988       v = 0;
8989     }
8990
8991   val = allocate_value (type1);
8992   store_unsigned_integer (value_contents_raw (val),
8993                           TYPE_LENGTH (value_type (val)),
8994                           type_byte_order (type1), v);
8995   return val;
8996 }
8997
8998 static int
8999 ada_value_equal (struct value *arg1, struct value *arg2)
9000 {
9001   if (ada_is_direct_array_type (value_type (arg1))
9002       || ada_is_direct_array_type (value_type (arg2)))
9003     {
9004       struct type *arg1_type, *arg2_type;
9005
9006       /* Automatically dereference any array reference before
9007          we attempt to perform the comparison.  */
9008       arg1 = ada_coerce_ref (arg1);
9009       arg2 = ada_coerce_ref (arg2);
9010
9011       arg1 = ada_coerce_to_simple_array (arg1);
9012       arg2 = ada_coerce_to_simple_array (arg2);
9013
9014       arg1_type = ada_check_typedef (value_type (arg1));
9015       arg2_type = ada_check_typedef (value_type (arg2));
9016
9017       if (arg1_type->code () != TYPE_CODE_ARRAY
9018           || arg2_type->code () != TYPE_CODE_ARRAY)
9019         error (_("Attempt to compare array with non-array"));
9020       /* FIXME: The following works only for types whose
9021          representations use all bits (no padding or undefined bits)
9022          and do not have user-defined equality.  */
9023       return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9024               && memcmp (value_contents (arg1), value_contents (arg2),
9025                          TYPE_LENGTH (arg1_type)) == 0);
9026     }
9027   return value_equal (arg1, arg2);
9028 }
9029
9030 namespace expr
9031 {
9032
9033 bool
9034 check_objfile (const std::unique_ptr<ada_component> &comp,
9035                struct objfile *objfile)
9036 {
9037   return comp->uses_objfile (objfile);
9038 }
9039
9040 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9041    component of LHS (a simple array or a record).  Does not modify the
9042    inferior's memory, nor does it modify LHS (unless LHS ==
9043    CONTAINER).  */
9044
9045 static void
9046 assign_component (struct value *container, struct value *lhs, LONGEST index,
9047                   struct expression *exp, operation_up &arg)
9048 {
9049   scoped_value_mark mark;
9050
9051   struct value *elt;
9052   struct type *lhs_type = check_typedef (value_type (lhs));
9053
9054   if (lhs_type->code () == TYPE_CODE_ARRAY)
9055     {
9056       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9057       struct value *index_val = value_from_longest (index_type, index);
9058
9059       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9060     }
9061   else
9062     {
9063       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9064       elt = ada_to_fixed_value (elt);
9065     }
9066
9067   ada_aggregate_operation *ag_op
9068     = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9069   if (ag_op != nullptr)
9070     ag_op->assign_aggregate (container, elt, exp);
9071   else
9072     value_assign_to_component (container, elt,
9073                                arg->evaluate (nullptr, exp,
9074                                               EVAL_NORMAL));
9075 }
9076
9077 bool
9078 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9079 {
9080   for (const auto &item : m_components)
9081     if (item->uses_objfile (objfile))
9082       return true;
9083   return false;
9084 }
9085
9086 void
9087 ada_aggregate_component::dump (ui_file *stream, int depth)
9088 {
9089   fprintf_filtered (stream, _("%*sAggregate\n"), depth, "");
9090   for (const auto &item : m_components)
9091     item->dump (stream, depth + 1);
9092 }
9093
9094 void
9095 ada_aggregate_component::assign (struct value *container,
9096                                  struct value *lhs, struct expression *exp,
9097                                  std::vector<LONGEST> &indices,
9098                                  LONGEST low, LONGEST high)
9099 {
9100   for (auto &item : m_components)
9101     item->assign (container, lhs, exp, indices, low, high);
9102 }
9103
9104 /* Assuming that LHS represents an lvalue having a record or array
9105    type, evaluate an assignment of this aggregate's value to LHS.
9106    CONTAINER is an lvalue containing LHS (possibly LHS itself).  Does
9107    not modify the inferior's memory, nor does it modify the contents
9108    of LHS (unless == CONTAINER).  */
9109
9110 void
9111 ada_aggregate_operation::assign_aggregate (struct value *container,
9112                                            struct value *lhs,
9113                                            struct expression *exp)
9114 {
9115   struct type *lhs_type;
9116   LONGEST low_index, high_index;
9117
9118   container = ada_coerce_ref (container);
9119   if (ada_is_direct_array_type (value_type (container)))
9120     container = ada_coerce_to_simple_array (container);
9121   lhs = ada_coerce_ref (lhs);
9122   if (!deprecated_value_modifiable (lhs))
9123     error (_("Left operand of assignment is not a modifiable lvalue."));
9124
9125   lhs_type = check_typedef (value_type (lhs));
9126   if (ada_is_direct_array_type (lhs_type))
9127     {
9128       lhs = ada_coerce_to_simple_array (lhs);
9129       lhs_type = check_typedef (value_type (lhs));
9130       low_index = lhs_type->bounds ()->low.const_val ();
9131       high_index = lhs_type->bounds ()->high.const_val ();
9132     }
9133   else if (lhs_type->code () == TYPE_CODE_STRUCT)
9134     {
9135       low_index = 0;
9136       high_index = num_visible_fields (lhs_type) - 1;
9137     }
9138   else
9139     error (_("Left-hand side must be array or record."));
9140
9141   std::vector<LONGEST> indices (4);
9142   indices[0] = indices[1] = low_index - 1;
9143   indices[2] = indices[3] = high_index + 1;
9144
9145   std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9146                                    low_index, high_index);
9147 }
9148
9149 bool
9150 ada_positional_component::uses_objfile (struct objfile *objfile)
9151 {
9152   return m_op->uses_objfile (objfile);
9153 }
9154
9155 void
9156 ada_positional_component::dump (ui_file *stream, int depth)
9157 {
9158   fprintf_filtered (stream, _("%*sPositional, index = %d\n"),
9159                     depth, "", m_index);
9160   m_op->dump (stream, depth + 1);
9161 }
9162
9163 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9164    construct, given that the positions are relative to lower bound
9165    LOW, where HIGH is the upper bound.  Record the position in
9166    INDICES.  CONTAINER is as for assign_aggregate.  */
9167 void
9168 ada_positional_component::assign (struct value *container,
9169                                   struct value *lhs, struct expression *exp,
9170                                   std::vector<LONGEST> &indices,
9171                                   LONGEST low, LONGEST high)
9172 {
9173   LONGEST ind = m_index + low;
9174
9175   if (ind - 1 == high)
9176     warning (_("Extra components in aggregate ignored."));
9177   if (ind <= high)
9178     {
9179       add_component_interval (ind, ind, indices);
9180       assign_component (container, lhs, ind, exp, m_op);
9181     }
9182 }
9183
9184 bool
9185 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9186 {
9187   return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9188 }
9189
9190 void
9191 ada_discrete_range_association::dump (ui_file *stream, int depth)
9192 {
9193   fprintf_filtered (stream, _("%*sDiscrete range:\n"), depth, "");
9194   m_low->dump (stream, depth + 1);
9195   m_high->dump (stream, depth + 1);
9196 }
9197
9198 void
9199 ada_discrete_range_association::assign (struct value *container,
9200                                         struct value *lhs,
9201                                         struct expression *exp,
9202                                         std::vector<LONGEST> &indices,
9203                                         LONGEST low, LONGEST high,
9204                                         operation_up &op)
9205 {
9206   LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9207   LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9208
9209   if (lower <= upper && (lower < low || upper > high))
9210     error (_("Index in component association out of bounds."));
9211
9212   add_component_interval (lower, upper, indices);
9213   while (lower <= upper)
9214     {
9215       assign_component (container, lhs, lower, exp, op);
9216       lower += 1;
9217     }
9218 }
9219
9220 bool
9221 ada_name_association::uses_objfile (struct objfile *objfile)
9222 {
9223   return m_val->uses_objfile (objfile);
9224 }
9225
9226 void
9227 ada_name_association::dump (ui_file *stream, int depth)
9228 {
9229   fprintf_filtered (stream, _("%*sName:\n"), depth, "");
9230   m_val->dump (stream, depth + 1);
9231 }
9232
9233 void
9234 ada_name_association::assign (struct value *container,
9235                               struct value *lhs,
9236                               struct expression *exp,
9237                               std::vector<LONGEST> &indices,
9238                               LONGEST low, LONGEST high,
9239                               operation_up &op)
9240 {
9241   int index;
9242
9243   if (ada_is_direct_array_type (value_type (lhs)))
9244     index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9245                                                             EVAL_NORMAL)));
9246   else
9247     {
9248       ada_string_operation *strop
9249         = dynamic_cast<ada_string_operation *> (m_val.get ());
9250
9251       const char *name;
9252       if (strop != nullptr)
9253         name = strop->get_name ();
9254       else
9255         {
9256           ada_var_value_operation *vvo
9257             = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9258           if (vvo != nullptr)
9259             error (_("Invalid record component association."));
9260           name = vvo->get_symbol ()->natural_name ();
9261         }
9262
9263       index = 0;
9264       if (! find_struct_field (name, value_type (lhs), 0,
9265                                NULL, NULL, NULL, NULL, &index))
9266         error (_("Unknown component name: %s."), name);
9267     }
9268
9269   add_component_interval (index, index, indices);
9270   assign_component (container, lhs, index, exp, op);
9271 }
9272
9273 bool
9274 ada_choices_component::uses_objfile (struct objfile *objfile)
9275 {
9276   if (m_op->uses_objfile (objfile))
9277     return true;
9278   for (const auto &item : m_assocs)
9279     if (item->uses_objfile (objfile))
9280       return true;
9281   return false;
9282 }
9283
9284 void
9285 ada_choices_component::dump (ui_file *stream, int depth)
9286 {
9287   fprintf_filtered (stream, _("%*sChoices:\n"), depth, "");
9288   m_op->dump (stream, depth + 1);
9289   for (const auto &item : m_assocs)
9290     item->dump (stream, depth + 1);
9291 }
9292
9293 /* Assign into the components of LHS indexed by the OP_CHOICES
9294    construct at *POS, updating *POS past the construct, given that
9295    the allowable indices are LOW..HIGH.  Record the indices assigned
9296    to in INDICES.  CONTAINER is as for assign_aggregate.  */
9297 void
9298 ada_choices_component::assign (struct value *container,
9299                                struct value *lhs, struct expression *exp,
9300                                std::vector<LONGEST> &indices,
9301                                LONGEST low, LONGEST high)
9302 {
9303   for (auto &item : m_assocs)
9304     item->assign (container, lhs, exp, indices, low, high, m_op);
9305 }
9306
9307 bool
9308 ada_others_component::uses_objfile (struct objfile *objfile)
9309 {
9310   return m_op->uses_objfile (objfile);
9311 }
9312
9313 void
9314 ada_others_component::dump (ui_file *stream, int depth)
9315 {
9316   fprintf_filtered (stream, _("%*sOthers:\n"), depth, "");
9317   m_op->dump (stream, depth + 1);
9318 }
9319
9320 /* Assign the value of the expression in the OP_OTHERS construct in
9321    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9322    have not been previously assigned.  The index intervals already assigned
9323    are in INDICES.  CONTAINER is as for assign_aggregate.  */
9324 void
9325 ada_others_component::assign (struct value *container,
9326                               struct value *lhs, struct expression *exp,
9327                               std::vector<LONGEST> &indices,
9328                               LONGEST low, LONGEST high)
9329 {
9330   int num_indices = indices.size ();
9331   for (int i = 0; i < num_indices - 2; i += 2)
9332     {
9333       for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9334         assign_component (container, lhs, ind, exp, m_op);
9335     }
9336 }
9337
9338 struct value *
9339 ada_assign_operation::evaluate (struct type *expect_type,
9340                                 struct expression *exp,
9341                                 enum noside noside)
9342 {
9343   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9344
9345   ada_aggregate_operation *ag_op
9346     = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9347   if (ag_op != nullptr)
9348     {
9349       if (noside != EVAL_NORMAL)
9350         return arg1;
9351
9352       ag_op->assign_aggregate (arg1, arg1, exp);
9353       return ada_value_assign (arg1, arg1);
9354     }
9355   /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9356      except if the lhs of our assignment is a convenience variable.
9357      In the case of assigning to a convenience variable, the lhs
9358      should be exactly the result of the evaluation of the rhs.  */
9359   struct type *type = value_type (arg1);
9360   if (VALUE_LVAL (arg1) == lval_internalvar)
9361     type = NULL;
9362   value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9363   if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
9364     return arg1;
9365   if (VALUE_LVAL (arg1) == lval_internalvar)
9366     {
9367       /* Nothing.  */
9368     }
9369   else
9370     arg2 = coerce_for_assign (value_type (arg1), arg2);
9371   return ada_value_assign (arg1, arg2);
9372 }
9373
9374 } /* namespace expr */
9375
9376 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9377    [ INDICES[0] .. INDICES[1] ],...  The resulting intervals do not
9378    overlap.  */
9379 static void
9380 add_component_interval (LONGEST low, LONGEST high, 
9381                         std::vector<LONGEST> &indices)
9382 {
9383   int i, j;
9384
9385   int size = indices.size ();
9386   for (i = 0; i < size; i += 2) {
9387     if (high >= indices[i] && low <= indices[i + 1])
9388       {
9389         int kh;
9390
9391         for (kh = i + 2; kh < size; kh += 2)
9392           if (high < indices[kh])
9393             break;
9394         if (low < indices[i])
9395           indices[i] = low;
9396         indices[i + 1] = indices[kh - 1];
9397         if (high > indices[i + 1])
9398           indices[i + 1] = high;
9399         memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9400         indices.resize (kh - i - 2);
9401         return;
9402       }
9403     else if (high < indices[i])
9404       break;
9405   }
9406         
9407   indices.resize (indices.size () + 2);
9408   for (j = indices.size () - 1; j >= i + 2; j -= 1)
9409     indices[j] = indices[j - 2];
9410   indices[i] = low;
9411   indices[i + 1] = high;
9412 }
9413
9414 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9415    is different.  */
9416
9417 static struct value *
9418 ada_value_cast (struct type *type, struct value *arg2)
9419 {
9420   if (type == ada_check_typedef (value_type (arg2)))
9421     return arg2;
9422
9423   return value_cast (type, arg2);
9424 }
9425
9426 /*  Evaluating Ada expressions, and printing their result.
9427     ------------------------------------------------------
9428
9429     1. Introduction:
9430     ----------------
9431
9432     We usually evaluate an Ada expression in order to print its value.
9433     We also evaluate an expression in order to print its type, which
9434     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9435     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
9436     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9437     the evaluation compared to the EVAL_NORMAL, but is otherwise very
9438     similar.
9439
9440     Evaluating expressions is a little more complicated for Ada entities
9441     than it is for entities in languages such as C.  The main reason for
9442     this is that Ada provides types whose definition might be dynamic.
9443     One example of such types is variant records.  Or another example
9444     would be an array whose bounds can only be known at run time.
9445
9446     The following description is a general guide as to what should be
9447     done (and what should NOT be done) in order to evaluate an expression
9448     involving such types, and when.  This does not cover how the semantic
9449     information is encoded by GNAT as this is covered separatly.  For the
9450     document used as the reference for the GNAT encoding, see exp_dbug.ads
9451     in the GNAT sources.
9452
9453     Ideally, we should embed each part of this description next to its
9454     associated code.  Unfortunately, the amount of code is so vast right
9455     now that it's hard to see whether the code handling a particular
9456     situation might be duplicated or not.  One day, when the code is
9457     cleaned up, this guide might become redundant with the comments
9458     inserted in the code, and we might want to remove it.
9459
9460     2. ``Fixing'' an Entity, the Simple Case:
9461     -----------------------------------------
9462
9463     When evaluating Ada expressions, the tricky issue is that they may
9464     reference entities whose type contents and size are not statically
9465     known.  Consider for instance a variant record:
9466
9467        type Rec (Empty : Boolean := True) is record
9468           case Empty is
9469              when True => null;
9470              when False => Value : Integer;
9471           end case;
9472        end record;
9473        Yes : Rec := (Empty => False, Value => 1);
9474        No  : Rec := (empty => True);
9475
9476     The size and contents of that record depends on the value of the
9477     descriminant (Rec.Empty).  At this point, neither the debugging
9478     information nor the associated type structure in GDB are able to
9479     express such dynamic types.  So what the debugger does is to create
9480     "fixed" versions of the type that applies to the specific object.
9481     We also informally refer to this operation as "fixing" an object,
9482     which means creating its associated fixed type.
9483
9484     Example: when printing the value of variable "Yes" above, its fixed
9485     type would look like this:
9486
9487        type Rec is record
9488           Empty : Boolean;
9489           Value : Integer;
9490        end record;
9491
9492     On the other hand, if we printed the value of "No", its fixed type
9493     would become:
9494
9495        type Rec is record
9496           Empty : Boolean;
9497        end record;
9498
9499     Things become a little more complicated when trying to fix an entity
9500     with a dynamic type that directly contains another dynamic type,
9501     such as an array of variant records, for instance.  There are
9502     two possible cases: Arrays, and records.
9503
9504     3. ``Fixing'' Arrays:
9505     ---------------------
9506
9507     The type structure in GDB describes an array in terms of its bounds,
9508     and the type of its elements.  By design, all elements in the array
9509     have the same type and we cannot represent an array of variant elements
9510     using the current type structure in GDB.  When fixing an array,
9511     we cannot fix the array element, as we would potentially need one
9512     fixed type per element of the array.  As a result, the best we can do
9513     when fixing an array is to produce an array whose bounds and size
9514     are correct (allowing us to read it from memory), but without having
9515     touched its element type.  Fixing each element will be done later,
9516     when (if) necessary.
9517
9518     Arrays are a little simpler to handle than records, because the same
9519     amount of memory is allocated for each element of the array, even if
9520     the amount of space actually used by each element differs from element
9521     to element.  Consider for instance the following array of type Rec:
9522
9523        type Rec_Array is array (1 .. 2) of Rec;
9524
9525     The actual amount of memory occupied by each element might be different
9526     from element to element, depending on the value of their discriminant.
9527     But the amount of space reserved for each element in the array remains
9528     fixed regardless.  So we simply need to compute that size using
9529     the debugging information available, from which we can then determine
9530     the array size (we multiply the number of elements of the array by
9531     the size of each element).
9532
9533     The simplest case is when we have an array of a constrained element
9534     type. For instance, consider the following type declarations:
9535
9536         type Bounded_String (Max_Size : Integer) is
9537            Length : Integer;
9538            Buffer : String (1 .. Max_Size);
9539         end record;
9540         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9541
9542     In this case, the compiler describes the array as an array of
9543     variable-size elements (identified by its XVS suffix) for which
9544     the size can be read in the parallel XVZ variable.
9545
9546     In the case of an array of an unconstrained element type, the compiler
9547     wraps the array element inside a private PAD type.  This type should not
9548     be shown to the user, and must be "unwrap"'ed before printing.  Note
9549     that we also use the adjective "aligner" in our code to designate
9550     these wrapper types.
9551
9552     In some cases, the size allocated for each element is statically
9553     known.  In that case, the PAD type already has the correct size,
9554     and the array element should remain unfixed.
9555
9556     But there are cases when this size is not statically known.
9557     For instance, assuming that "Five" is an integer variable:
9558
9559         type Dynamic is array (1 .. Five) of Integer;
9560         type Wrapper (Has_Length : Boolean := False) is record
9561            Data : Dynamic;
9562            case Has_Length is
9563               when True => Length : Integer;
9564               when False => null;
9565            end case;
9566         end record;
9567         type Wrapper_Array is array (1 .. 2) of Wrapper;
9568
9569         Hello : Wrapper_Array := (others => (Has_Length => True,
9570                                              Data => (others => 17),
9571                                              Length => 1));
9572
9573
9574     The debugging info would describe variable Hello as being an
9575     array of a PAD type.  The size of that PAD type is not statically
9576     known, but can be determined using a parallel XVZ variable.
9577     In that case, a copy of the PAD type with the correct size should
9578     be used for the fixed array.
9579
9580     3. ``Fixing'' record type objects:
9581     ----------------------------------
9582
9583     Things are slightly different from arrays in the case of dynamic
9584     record types.  In this case, in order to compute the associated
9585     fixed type, we need to determine the size and offset of each of
9586     its components.  This, in turn, requires us to compute the fixed
9587     type of each of these components.
9588
9589     Consider for instance the example:
9590
9591         type Bounded_String (Max_Size : Natural) is record
9592            Str : String (1 .. Max_Size);
9593            Length : Natural;
9594         end record;
9595         My_String : Bounded_String (Max_Size => 10);
9596
9597     In that case, the position of field "Length" depends on the size
9598     of field Str, which itself depends on the value of the Max_Size
9599     discriminant.  In order to fix the type of variable My_String,
9600     we need to fix the type of field Str.  Therefore, fixing a variant
9601     record requires us to fix each of its components.
9602
9603     However, if a component does not have a dynamic size, the component
9604     should not be fixed.  In particular, fields that use a PAD type
9605     should not fixed.  Here is an example where this might happen
9606     (assuming type Rec above):
9607
9608        type Container (Big : Boolean) is record
9609           First : Rec;
9610           After : Integer;
9611           case Big is
9612              when True => Another : Integer;
9613              when False => null;
9614           end case;
9615        end record;
9616        My_Container : Container := (Big => False,
9617                                     First => (Empty => True),
9618                                     After => 42);
9619
9620     In that example, the compiler creates a PAD type for component First,
9621     whose size is constant, and then positions the component After just
9622     right after it.  The offset of component After is therefore constant
9623     in this case.
9624
9625     The debugger computes the position of each field based on an algorithm
9626     that uses, among other things, the actual position and size of the field
9627     preceding it.  Let's now imagine that the user is trying to print
9628     the value of My_Container.  If the type fixing was recursive, we would
9629     end up computing the offset of field After based on the size of the
9630     fixed version of field First.  And since in our example First has
9631     only one actual field, the size of the fixed type is actually smaller
9632     than the amount of space allocated to that field, and thus we would
9633     compute the wrong offset of field After.
9634
9635     To make things more complicated, we need to watch out for dynamic
9636     components of variant records (identified by the ___XVL suffix in
9637     the component name).  Even if the target type is a PAD type, the size
9638     of that type might not be statically known.  So the PAD type needs
9639     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
9640     we might end up with the wrong size for our component.  This can be
9641     observed with the following type declarations:
9642
9643         type Octal is new Integer range 0 .. 7;
9644         type Octal_Array is array (Positive range <>) of Octal;
9645         pragma Pack (Octal_Array);
9646
9647         type Octal_Buffer (Size : Positive) is record
9648            Buffer : Octal_Array (1 .. Size);
9649            Length : Integer;
9650         end record;
9651
9652     In that case, Buffer is a PAD type whose size is unset and needs
9653     to be computed by fixing the unwrapped type.
9654
9655     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9656     ----------------------------------------------------------
9657
9658     Lastly, when should the sub-elements of an entity that remained unfixed
9659     thus far, be actually fixed?
9660
9661     The answer is: Only when referencing that element.  For instance
9662     when selecting one component of a record, this specific component
9663     should be fixed at that point in time.  Or when printing the value
9664     of a record, each component should be fixed before its value gets
9665     printed.  Similarly for arrays, the element of the array should be
9666     fixed when printing each element of the array, or when extracting
9667     one element out of that array.  On the other hand, fixing should
9668     not be performed on the elements when taking a slice of an array!
9669
9670     Note that one of the side effects of miscomputing the offset and
9671     size of each field is that we end up also miscomputing the size
9672     of the containing type.  This can have adverse results when computing
9673     the value of an entity.  GDB fetches the value of an entity based
9674     on the size of its type, and thus a wrong size causes GDB to fetch
9675     the wrong amount of memory.  In the case where the computed size is
9676     too small, GDB fetches too little data to print the value of our
9677     entity.  Results in this case are unpredictable, as we usually read
9678     past the buffer containing the data =:-o.  */
9679
9680 /* A helper function for TERNOP_IN_RANGE.  */
9681
9682 static value *
9683 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
9684                       enum noside noside,
9685                       value *arg1, value *arg2, value *arg3)
9686 {
9687   if (noside == EVAL_SKIP)
9688     return eval_skip_value (exp);
9689
9690   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9691   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9692   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
9693   return
9694     value_from_longest (type,
9695                         (value_less (arg1, arg3)
9696                          || value_equal (arg1, arg3))
9697                         && (value_less (arg2, arg1)
9698                             || value_equal (arg2, arg1)));
9699 }
9700
9701 /* A helper function for UNOP_NEG.  */
9702
9703 value *
9704 ada_unop_neg (struct type *expect_type,
9705               struct expression *exp,
9706               enum noside noside, enum exp_opcode op,
9707               struct value *arg1)
9708 {
9709   if (noside == EVAL_SKIP)
9710     return eval_skip_value (exp);
9711   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9712   return value_neg (arg1);
9713 }
9714
9715 /* A helper function for UNOP_IN_RANGE.  */
9716
9717 value *
9718 ada_unop_in_range (struct type *expect_type,
9719                    struct expression *exp,
9720                    enum noside noside, enum exp_opcode op,
9721                    struct value *arg1, struct type *type)
9722 {
9723   if (noside == EVAL_SKIP)
9724     return eval_skip_value (exp);
9725
9726   struct value *arg2, *arg3;
9727   switch (type->code ())
9728     {
9729     default:
9730       lim_warning (_("Membership test incompletely implemented; "
9731                      "always returns true"));
9732       type = language_bool_type (exp->language_defn, exp->gdbarch);
9733       return value_from_longest (type, (LONGEST) 1);
9734
9735     case TYPE_CODE_RANGE:
9736       arg2 = value_from_longest (type,
9737                                  type->bounds ()->low.const_val ());
9738       arg3 = value_from_longest (type,
9739                                  type->bounds ()->high.const_val ());
9740       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9741       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9742       type = language_bool_type (exp->language_defn, exp->gdbarch);
9743       return
9744         value_from_longest (type,
9745                             (value_less (arg1, arg3)
9746                              || value_equal (arg1, arg3))
9747                             && (value_less (arg2, arg1)
9748                                 || value_equal (arg2, arg1)));
9749     }
9750 }
9751
9752 /* A helper function for OP_ATR_TAG.  */
9753
9754 value *
9755 ada_atr_tag (struct type *expect_type,
9756              struct expression *exp,
9757              enum noside noside, enum exp_opcode op,
9758              struct value *arg1)
9759 {
9760   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9761     return value_zero (ada_tag_type (arg1), not_lval);
9762
9763   return ada_value_tag (arg1);
9764 }
9765
9766 /* A helper function for OP_ATR_SIZE.  */
9767
9768 value *
9769 ada_atr_size (struct type *expect_type,
9770               struct expression *exp,
9771               enum noside noside, enum exp_opcode op,
9772               struct value *arg1)
9773 {
9774   struct type *type = value_type (arg1);
9775
9776   /* If the argument is a reference, then dereference its type, since
9777      the user is really asking for the size of the actual object,
9778      not the size of the pointer.  */
9779   if (type->code () == TYPE_CODE_REF)
9780     type = TYPE_TARGET_TYPE (type);
9781
9782   if (noside == EVAL_SKIP)
9783     return eval_skip_value (exp);
9784   else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9785     return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
9786   else
9787     return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
9788                                TARGET_CHAR_BIT * TYPE_LENGTH (type));
9789 }
9790
9791 /* A helper function for UNOP_ABS.  */
9792
9793 value *
9794 ada_abs (struct type *expect_type,
9795          struct expression *exp,
9796          enum noside noside, enum exp_opcode op,
9797          struct value *arg1)
9798 {
9799   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9800   if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
9801     return value_neg (arg1);
9802   else
9803     return arg1;
9804 }
9805
9806 /* A helper function for BINOP_MUL.  */
9807
9808 value *
9809 ada_mult_binop (struct type *expect_type,
9810                 struct expression *exp,
9811                 enum noside noside, enum exp_opcode op,
9812                 struct value *arg1, struct value *arg2)
9813 {
9814   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9815     {
9816       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9817       return value_zero (value_type (arg1), not_lval);
9818     }
9819   else
9820     {
9821       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9822       return ada_value_binop (arg1, arg2, op);
9823     }
9824 }
9825
9826 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL.  */
9827
9828 value *
9829 ada_equal_binop (struct type *expect_type,
9830                  struct expression *exp,
9831                  enum noside noside, enum exp_opcode op,
9832                  struct value *arg1, struct value *arg2)
9833 {
9834   int tem;
9835   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9836     tem = 0;
9837   else
9838     {
9839       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9840       tem = ada_value_equal (arg1, arg2);
9841     }
9842   if (op == BINOP_NOTEQUAL)
9843     tem = !tem;
9844   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
9845   return value_from_longest (type, (LONGEST) tem);
9846 }
9847
9848 /* A helper function for TERNOP_SLICE.  */
9849
9850 value *
9851 ada_ternop_slice (struct expression *exp,
9852                   enum noside noside,
9853                   struct value *array, struct value *low_bound_val,
9854                   struct value *high_bound_val)
9855 {
9856   LONGEST low_bound;
9857   LONGEST high_bound;
9858
9859   low_bound_val = coerce_ref (low_bound_val);
9860   high_bound_val = coerce_ref (high_bound_val);
9861   low_bound = value_as_long (low_bound_val);
9862   high_bound = value_as_long (high_bound_val);
9863
9864   /* If this is a reference to an aligner type, then remove all
9865      the aligners.  */
9866   if (value_type (array)->code () == TYPE_CODE_REF
9867       && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
9868     TYPE_TARGET_TYPE (value_type (array)) =
9869       ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
9870
9871   if (ada_is_any_packed_array_type (value_type (array)))
9872     error (_("cannot slice a packed array"));
9873
9874   /* If this is a reference to an array or an array lvalue,
9875      convert to a pointer.  */
9876   if (value_type (array)->code () == TYPE_CODE_REF
9877       || (value_type (array)->code () == TYPE_CODE_ARRAY
9878           && VALUE_LVAL (array) == lval_memory))
9879     array = value_addr (array);
9880
9881   if (noside == EVAL_AVOID_SIDE_EFFECTS
9882       && ada_is_array_descriptor_type (ada_check_typedef
9883                                        (value_type (array))))
9884     return empty_array (ada_type_of_array (array, 0), low_bound,
9885                         high_bound);
9886
9887   array = ada_coerce_to_simple_array_ptr (array);
9888
9889   /* If we have more than one level of pointer indirection,
9890      dereference the value until we get only one level.  */
9891   while (value_type (array)->code () == TYPE_CODE_PTR
9892          && (TYPE_TARGET_TYPE (value_type (array))->code ()
9893              == TYPE_CODE_PTR))
9894     array = value_ind (array);
9895
9896   /* Make sure we really do have an array type before going further,
9897      to avoid a SEGV when trying to get the index type or the target
9898      type later down the road if the debug info generated by
9899      the compiler is incorrect or incomplete.  */
9900   if (!ada_is_simple_array_type (value_type (array)))
9901     error (_("cannot take slice of non-array"));
9902
9903   if (ada_check_typedef (value_type (array))->code ()
9904       == TYPE_CODE_PTR)
9905     {
9906       struct type *type0 = ada_check_typedef (value_type (array));
9907
9908       if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
9909         return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
9910       else
9911         {
9912           struct type *arr_type0 =
9913             to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
9914
9915           return ada_value_slice_from_ptr (array, arr_type0,
9916                                            longest_to_int (low_bound),
9917                                            longest_to_int (high_bound));
9918         }
9919     }
9920   else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9921     return array;
9922   else if (high_bound < low_bound)
9923     return empty_array (value_type (array), low_bound, high_bound);
9924   else
9925     return ada_value_slice (array, longest_to_int (low_bound),
9926                             longest_to_int (high_bound));
9927 }
9928
9929 /* A helper function for BINOP_IN_BOUNDS.  */
9930
9931 value *
9932 ada_binop_in_bounds (struct expression *exp, enum noside noside,
9933                      struct value *arg1, struct value *arg2, int n)
9934 {
9935   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9936     {
9937       struct type *type = language_bool_type (exp->language_defn,
9938                                               exp->gdbarch);
9939       return value_zero (type, not_lval);
9940     }
9941
9942   struct type *type = ada_index_type (value_type (arg2), n, "range");
9943   if (!type)
9944     type = value_type (arg1);
9945
9946   value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
9947   arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
9948
9949   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9950   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9951   type = language_bool_type (exp->language_defn, exp->gdbarch);
9952   return value_from_longest (type,
9953                              (value_less (arg1, arg3)
9954                               || value_equal (arg1, arg3))
9955                              && (value_less (arg2, arg1)
9956                                  || value_equal (arg2, arg1)));
9957 }
9958
9959 /* A helper function for some attribute operations.  */
9960
9961 static value *
9962 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
9963               struct value *arg1, struct type *type_arg, int tem)
9964 {
9965   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9966     {
9967       if (type_arg == NULL)
9968         type_arg = value_type (arg1);
9969
9970       if (ada_is_constrained_packed_array_type (type_arg))
9971         type_arg = decode_constrained_packed_array_type (type_arg);
9972
9973       if (!discrete_type_p (type_arg))
9974         {
9975           switch (op)
9976             {
9977             default:          /* Should never happen.  */
9978               error (_("unexpected attribute encountered"));
9979             case OP_ATR_FIRST:
9980             case OP_ATR_LAST:
9981               type_arg = ada_index_type (type_arg, tem,
9982                                          ada_attribute_name (op));
9983               break;
9984             case OP_ATR_LENGTH:
9985               type_arg = builtin_type (exp->gdbarch)->builtin_int;
9986               break;
9987             }
9988         }
9989
9990       return value_zero (type_arg, not_lval);
9991     }
9992   else if (type_arg == NULL)
9993     {
9994       arg1 = ada_coerce_ref (arg1);
9995
9996       if (ada_is_constrained_packed_array_type (value_type (arg1)))
9997         arg1 = ada_coerce_to_simple_array (arg1);
9998
9999       struct type *type;
10000       if (op == OP_ATR_LENGTH)
10001         type = builtin_type (exp->gdbarch)->builtin_int;
10002       else
10003         {
10004           type = ada_index_type (value_type (arg1), tem,
10005                                  ada_attribute_name (op));
10006           if (type == NULL)
10007             type = builtin_type (exp->gdbarch)->builtin_int;
10008         }
10009
10010       switch (op)
10011         {
10012         default:          /* Should never happen.  */
10013           error (_("unexpected attribute encountered"));
10014         case OP_ATR_FIRST:
10015           return value_from_longest
10016             (type, ada_array_bound (arg1, tem, 0));
10017         case OP_ATR_LAST:
10018           return value_from_longest
10019             (type, ada_array_bound (arg1, tem, 1));
10020         case OP_ATR_LENGTH:
10021           return value_from_longest
10022             (type, ada_array_length (arg1, tem));
10023         }
10024     }
10025   else if (discrete_type_p (type_arg))
10026     {
10027       struct type *range_type;
10028       const char *name = ada_type_name (type_arg);
10029
10030       range_type = NULL;
10031       if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10032         range_type = to_fixed_range_type (type_arg, NULL);
10033       if (range_type == NULL)
10034         range_type = type_arg;
10035       switch (op)
10036         {
10037         default:
10038           error (_("unexpected attribute encountered"));
10039         case OP_ATR_FIRST:
10040           return value_from_longest 
10041             (range_type, ada_discrete_type_low_bound (range_type));
10042         case OP_ATR_LAST:
10043           return value_from_longest
10044             (range_type, ada_discrete_type_high_bound (range_type));
10045         case OP_ATR_LENGTH:
10046           error (_("the 'length attribute applies only to array types"));
10047         }
10048     }
10049   else if (type_arg->code () == TYPE_CODE_FLT)
10050     error (_("unimplemented type attribute"));
10051   else
10052     {
10053       LONGEST low, high;
10054
10055       if (ada_is_constrained_packed_array_type (type_arg))
10056         type_arg = decode_constrained_packed_array_type (type_arg);
10057
10058       struct type *type;
10059       if (op == OP_ATR_LENGTH)
10060         type = builtin_type (exp->gdbarch)->builtin_int;
10061       else
10062         {
10063           type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10064           if (type == NULL)
10065             type = builtin_type (exp->gdbarch)->builtin_int;
10066         }
10067
10068       switch (op)
10069         {
10070         default:
10071           error (_("unexpected attribute encountered"));
10072         case OP_ATR_FIRST:
10073           low = ada_array_bound_from_type (type_arg, tem, 0);
10074           return value_from_longest (type, low);
10075         case OP_ATR_LAST:
10076           high = ada_array_bound_from_type (type_arg, tem, 1);
10077           return value_from_longest (type, high);
10078         case OP_ATR_LENGTH:
10079           low = ada_array_bound_from_type (type_arg, tem, 0);
10080           high = ada_array_bound_from_type (type_arg, tem, 1);
10081           return value_from_longest (type, high - low + 1);
10082         }
10083     }
10084 }
10085
10086 /* A helper function for OP_ATR_MIN and OP_ATR_MAX.  */
10087
10088 struct value *
10089 ada_binop_minmax (struct type *expect_type,
10090                   struct expression *exp,
10091                   enum noside noside, enum exp_opcode op,
10092                   struct value *arg1, struct value *arg2)
10093 {
10094   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10095     return value_zero (value_type (arg1), not_lval);
10096   else
10097     {
10098       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10099       return value_binop (arg1, arg2,
10100                           op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
10101     }
10102 }
10103
10104 /* A helper function for BINOP_EXP.  */
10105
10106 struct value *
10107 ada_binop_exp (struct type *expect_type,
10108                struct expression *exp,
10109                enum noside noside, enum exp_opcode op,
10110                struct value *arg1, struct value *arg2)
10111 {
10112   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10113     return value_zero (value_type (arg1), not_lval);
10114   else
10115     {
10116       /* For integer exponentiation operations,
10117          only promote the first argument.  */
10118       if (is_integral_type (value_type (arg2)))
10119         unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10120       else
10121         binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10122
10123       return value_binop (arg1, arg2, op);
10124     }
10125 }
10126
10127 namespace expr
10128 {
10129
10130 value *
10131 ada_wrapped_operation::evaluate (struct type *expect_type,
10132                                  struct expression *exp,
10133                                  enum noside noside)
10134 {
10135   value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10136   if (noside == EVAL_NORMAL)
10137     result = unwrap_value (result);
10138
10139   /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10140      then we need to perform the conversion manually, because
10141      evaluate_subexp_standard doesn't do it.  This conversion is
10142      necessary in Ada because the different kinds of float/fixed
10143      types in Ada have different representations.
10144
10145      Similarly, we need to perform the conversion from OP_LONG
10146      ourselves.  */
10147   if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10148     result = ada_value_cast (expect_type, result);
10149
10150   return result;
10151 }
10152
10153 value *
10154 ada_string_operation::evaluate (struct type *expect_type,
10155                                 struct expression *exp,
10156                                 enum noside noside)
10157 {
10158   value *result = string_operation::evaluate (expect_type, exp, noside);
10159   /* The result type will have code OP_STRING, bashed there from 
10160      OP_ARRAY.  Bash it back.  */
10161   if (value_type (result)->code () == TYPE_CODE_STRING)
10162     value_type (result)->set_code (TYPE_CODE_ARRAY);
10163   return result;
10164 }
10165
10166 value *
10167 ada_qual_operation::evaluate (struct type *expect_type,
10168                               struct expression *exp,
10169                               enum noside noside)
10170 {
10171   struct type *type = std::get<1> (m_storage);
10172   return std::get<0> (m_storage)->evaluate (type, exp, noside);
10173 }
10174
10175 value *
10176 ada_ternop_range_operation::evaluate (struct type *expect_type,
10177                                       struct expression *exp,
10178                                       enum noside noside)
10179 {
10180   value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10181   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10182   value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10183   return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10184 }
10185
10186 value *
10187 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10188                                       struct expression *exp,
10189                                       enum noside noside)
10190 {
10191   value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10192   value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10193
10194   auto do_op = [=] (LONGEST x, LONGEST y)
10195     {
10196       if (std::get<0> (m_storage) == BINOP_ADD)
10197         return x + y;
10198       return x - y;
10199     };
10200
10201   if (value_type (arg1)->code () == TYPE_CODE_PTR)
10202     return (value_from_longest
10203             (value_type (arg1),
10204              do_op (value_as_long (arg1), value_as_long (arg2))));
10205   if (value_type (arg2)->code () == TYPE_CODE_PTR)
10206     return (value_from_longest
10207             (value_type (arg2),
10208              do_op (value_as_long (arg1), value_as_long (arg2))));
10209   /* Preserve the original type for use by the range case below.
10210      We cannot cast the result to a reference type, so if ARG1 is
10211      a reference type, find its underlying type.  */
10212   struct type *type = value_type (arg1);
10213   while (type->code () == TYPE_CODE_REF)
10214     type = TYPE_TARGET_TYPE (type);
10215   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10216   arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10217   /* We need to special-case the result with a range.
10218      This is done for the benefit of "ptype".  gdb's Ada support
10219      historically used the LHS to set the result type here, so
10220      preserve this behavior.  */
10221   if (type->code () == TYPE_CODE_RANGE)
10222     arg1 = value_cast (type, arg1);
10223   return arg1;
10224 }
10225
10226 value *
10227 ada_unop_atr_operation::evaluate (struct type *expect_type,
10228                                   struct expression *exp,
10229                                   enum noside noside)
10230 {
10231   struct type *type_arg = nullptr;
10232   value *val = nullptr;
10233
10234   if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10235     {
10236       value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10237                                                       EVAL_AVOID_SIDE_EFFECTS);
10238       type_arg = value_type (tem);
10239     }
10240   else
10241     val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10242
10243   return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10244                        val, type_arg, std::get<2> (m_storage));
10245 }
10246
10247 value *
10248 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10249                                                  struct expression *exp,
10250                                                  enum noside noside)
10251 {
10252   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10253     return value_zero (expect_type, not_lval);
10254
10255   value *val = evaluate_var_msym_value (noside,
10256                                         std::get<1> (m_storage),
10257                                         std::get<0> (m_storage));
10258
10259   val = ada_value_cast (expect_type, val);
10260
10261   /* Follow the Ada language semantics that do not allow taking
10262      an address of the result of a cast (view conversion in Ada).  */
10263   if (VALUE_LVAL (val) == lval_memory)
10264     {
10265       if (value_lazy (val))
10266         value_fetch_lazy (val);
10267       VALUE_LVAL (val) = not_lval;
10268     }
10269   return val;
10270 }
10271
10272 value *
10273 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10274                                             struct expression *exp,
10275                                             enum noside noside)
10276 {
10277   value *val = evaluate_var_value (noside,
10278                                    std::get<1> (m_storage),
10279                                    std::get<0> (m_storage));
10280
10281   val = ada_value_cast (expect_type, val);
10282
10283   /* Follow the Ada language semantics that do not allow taking
10284      an address of the result of a cast (view conversion in Ada).  */
10285   if (VALUE_LVAL (val) == lval_memory)
10286     {
10287       if (value_lazy (val))
10288         value_fetch_lazy (val);
10289       VALUE_LVAL (val) = not_lval;
10290     }
10291   return val;
10292 }
10293
10294 value *
10295 ada_var_value_operation::evaluate (struct type *expect_type,
10296                                    struct expression *exp,
10297                                    enum noside noside)
10298 {
10299   symbol *sym = std::get<0> (m_storage);
10300
10301   if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
10302     /* Only encountered when an unresolved symbol occurs in a
10303        context other than a function call, in which case, it is
10304        invalid.  */
10305     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10306            sym->print_name ());
10307
10308   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10309     {
10310       struct type *type = static_unwrap_type (SYMBOL_TYPE (sym));
10311       /* Check to see if this is a tagged type.  We also need to handle
10312          the case where the type is a reference to a tagged type, but
10313          we have to be careful to exclude pointers to tagged types.
10314          The latter should be shown as usual (as a pointer), whereas
10315          a reference should mostly be transparent to the user.  */
10316       if (ada_is_tagged_type (type, 0)
10317           || (type->code () == TYPE_CODE_REF
10318               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10319         {
10320           /* Tagged types are a little special in the fact that the real
10321              type is dynamic and can only be determined by inspecting the
10322              object's tag.  This means that we need to get the object's
10323              value first (EVAL_NORMAL) and then extract the actual object
10324              type from its tag.
10325
10326              Note that we cannot skip the final step where we extract
10327              the object type from its tag, because the EVAL_NORMAL phase
10328              results in dynamic components being resolved into fixed ones.
10329              This can cause problems when trying to print the type
10330              description of tagged types whose parent has a dynamic size:
10331              We use the type name of the "_parent" component in order
10332              to print the name of the ancestor type in the type description.
10333              If that component had a dynamic size, the resolution into
10334              a fixed type would result in the loss of that type name,
10335              thus preventing us from printing the name of the ancestor
10336              type in the type description.  */
10337           value *arg1 = var_value_operation::evaluate (nullptr, exp,
10338                                                        EVAL_NORMAL);
10339
10340           if (type->code () != TYPE_CODE_REF)
10341             {
10342               struct type *actual_type;
10343
10344               actual_type = type_from_tag (ada_value_tag (arg1));
10345               if (actual_type == NULL)
10346                 /* If, for some reason, we were unable to determine
10347                    the actual type from the tag, then use the static
10348                    approximation that we just computed as a fallback.
10349                    This can happen if the debugging information is
10350                    incomplete, for instance.  */
10351                 actual_type = type;
10352               return value_zero (actual_type, not_lval);
10353             }
10354           else
10355             {
10356               /* In the case of a ref, ada_coerce_ref takes care
10357                  of determining the actual type.  But the evaluation
10358                  should return a ref as it should be valid to ask
10359                  for its address; so rebuild a ref after coerce.  */
10360               arg1 = ada_coerce_ref (arg1);
10361               return value_ref (arg1, TYPE_CODE_REF);
10362             }
10363         }
10364
10365       /* Records and unions for which GNAT encodings have been
10366          generated need to be statically fixed as well.
10367          Otherwise, non-static fixing produces a type where
10368          all dynamic properties are removed, which prevents "ptype"
10369          from being able to completely describe the type.
10370          For instance, a case statement in a variant record would be
10371          replaced by the relevant components based on the actual
10372          value of the discriminants.  */
10373       if ((type->code () == TYPE_CODE_STRUCT
10374            && dynamic_template_type (type) != NULL)
10375           || (type->code () == TYPE_CODE_UNION
10376               && ada_find_parallel_type (type, "___XVU") != NULL))
10377         return value_zero (to_static_fixed_type (type), not_lval);
10378     }
10379
10380   value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10381   return ada_to_fixed_value (arg1);
10382 }
10383
10384 bool
10385 ada_var_value_operation::resolve (struct expression *exp,
10386                                   bool deprocedure_p,
10387                                   bool parse_completion,
10388                                   innermost_block_tracker *tracker,
10389                                   struct type *context_type)
10390 {
10391   symbol *sym = std::get<0> (m_storage);
10392   if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
10393     {
10394       block_symbol resolved
10395         = ada_resolve_variable (sym, std::get<1> (m_storage),
10396                                 context_type, parse_completion,
10397                                 deprocedure_p, tracker);
10398       std::get<0> (m_storage) = resolved.symbol;
10399       std::get<1> (m_storage) = resolved.block;
10400     }
10401
10402   if (deprocedure_p
10403       && SYMBOL_TYPE (std::get<0> (m_storage))->code () == TYPE_CODE_FUNC)
10404     return true;
10405
10406   return false;
10407 }
10408
10409 value *
10410 ada_atr_val_operation::evaluate (struct type *expect_type,
10411                                  struct expression *exp,
10412                                  enum noside noside)
10413 {
10414   value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10415   return ada_val_atr (noside, std::get<0> (m_storage), arg);
10416 }
10417
10418 value *
10419 ada_unop_ind_operation::evaluate (struct type *expect_type,
10420                                   struct expression *exp,
10421                                   enum noside noside)
10422 {
10423   value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10424
10425   struct type *type = ada_check_typedef (value_type (arg1));
10426   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10427     {
10428       if (ada_is_array_descriptor_type (type))
10429         /* GDB allows dereferencing GNAT array descriptors.  */
10430         {
10431           struct type *arrType = ada_type_of_array (arg1, 0);
10432
10433           if (arrType == NULL)
10434             error (_("Attempt to dereference null array pointer."));
10435           return value_at_lazy (arrType, 0);
10436         }
10437       else if (type->code () == TYPE_CODE_PTR
10438                || type->code () == TYPE_CODE_REF
10439                /* In C you can dereference an array to get the 1st elt.  */
10440                || type->code () == TYPE_CODE_ARRAY)
10441         {
10442           /* As mentioned in the OP_VAR_VALUE case, tagged types can
10443              only be determined by inspecting the object's tag.
10444              This means that we need to evaluate completely the
10445              expression in order to get its type.  */
10446
10447           if ((type->code () == TYPE_CODE_REF
10448                || type->code () == TYPE_CODE_PTR)
10449               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
10450             {
10451               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
10452                                                         EVAL_NORMAL);
10453               type = value_type (ada_value_ind (arg1));
10454             }
10455           else
10456             {
10457               type = to_static_fixed_type
10458                 (ada_aligned_type
10459                  (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10460             }
10461           ada_ensure_varsize_limit (type);
10462           return value_zero (type, lval_memory);
10463         }
10464       else if (type->code () == TYPE_CODE_INT)
10465         {
10466           /* GDB allows dereferencing an int.  */
10467           if (expect_type == NULL)
10468             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10469                                lval_memory);
10470           else
10471             {
10472               expect_type =
10473                 to_static_fixed_type (ada_aligned_type (expect_type));
10474               return value_zero (expect_type, lval_memory);
10475             }
10476         }
10477       else
10478         error (_("Attempt to take contents of a non-pointer value."));
10479     }
10480   arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
10481   type = ada_check_typedef (value_type (arg1));
10482
10483   if (type->code () == TYPE_CODE_INT)
10484     /* GDB allows dereferencing an int.  If we were given
10485        the expect_type, then use that as the target type.
10486        Otherwise, assume that the target type is an int.  */
10487     {
10488       if (expect_type != NULL)
10489         return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10490                                           arg1));
10491       else
10492         return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10493                               (CORE_ADDR) value_as_address (arg1));
10494     }
10495
10496   if (ada_is_array_descriptor_type (type))
10497     /* GDB allows dereferencing GNAT array descriptors.  */
10498     return ada_coerce_to_simple_array (arg1);
10499   else
10500     return ada_value_ind (arg1);
10501 }
10502
10503 value *
10504 ada_structop_operation::evaluate (struct type *expect_type,
10505                                   struct expression *exp,
10506                                   enum noside noside)
10507 {
10508   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10509   const char *str = std::get<1> (m_storage).c_str ();
10510   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10511     {
10512       struct type *type;
10513       struct type *type1 = value_type (arg1);
10514
10515       if (ada_is_tagged_type (type1, 1))
10516         {
10517           type = ada_lookup_struct_elt_type (type1, str, 1, 1);
10518
10519           /* If the field is not found, check if it exists in the
10520              extension of this object's type. This means that we
10521              need to evaluate completely the expression.  */
10522
10523           if (type == NULL)
10524             {
10525               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
10526                                                         EVAL_NORMAL);
10527               arg1 = ada_value_struct_elt (arg1, str, 0);
10528               arg1 = unwrap_value (arg1);
10529               type = value_type (ada_to_fixed_value (arg1));
10530             }
10531         }
10532       else
10533         type = ada_lookup_struct_elt_type (type1, str, 1, 0);
10534
10535       return value_zero (ada_aligned_type (type), lval_memory);
10536     }
10537   else
10538     {
10539       arg1 = ada_value_struct_elt (arg1, str, 0);
10540       arg1 = unwrap_value (arg1);
10541       return ada_to_fixed_value (arg1);
10542     }
10543 }
10544
10545 value *
10546 ada_funcall_operation::evaluate (struct type *expect_type,
10547                                  struct expression *exp,
10548                                  enum noside noside)
10549 {
10550   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
10551   int nargs = args_up.size ();
10552   std::vector<value *> argvec (nargs);
10553   operation_up &callee_op = std::get<0> (m_storage);
10554
10555   ada_var_value_operation *avv
10556     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
10557   if (avv != nullptr
10558       && SYMBOL_DOMAIN (avv->get_symbol ()) == UNDEF_DOMAIN)
10559     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10560            avv->get_symbol ()->print_name ());
10561
10562   value *callee = callee_op->evaluate (nullptr, exp, noside);
10563   for (int i = 0; i < args_up.size (); ++i)
10564     argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
10565
10566   if (ada_is_constrained_packed_array_type
10567       (desc_base_type (value_type (callee))))
10568     callee = ada_coerce_to_simple_array (callee);
10569   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
10570            && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
10571     /* This is a packed array that has already been fixed, and
10572        therefore already coerced to a simple array.  Nothing further
10573        to do.  */
10574     ;
10575   else if (value_type (callee)->code () == TYPE_CODE_REF)
10576     {
10577       /* Make sure we dereference references so that all the code below
10578          feels like it's really handling the referenced value.  Wrapping
10579          types (for alignment) may be there, so make sure we strip them as
10580          well.  */
10581       callee = ada_to_fixed_value (coerce_ref (callee));
10582     }
10583   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
10584            && VALUE_LVAL (callee) == lval_memory)
10585     callee = value_addr (callee);
10586
10587   struct type *type = ada_check_typedef (value_type (callee));
10588
10589   /* Ada allows us to implicitly dereference arrays when subscripting
10590      them.  So, if this is an array typedef (encoding use for array
10591      access types encoded as fat pointers), strip it now.  */
10592   if (type->code () == TYPE_CODE_TYPEDEF)
10593     type = ada_typedef_target_type (type);
10594
10595   if (type->code () == TYPE_CODE_PTR)
10596     {
10597       switch (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ())
10598         {
10599         case TYPE_CODE_FUNC:
10600           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10601           break;
10602         case TYPE_CODE_ARRAY:
10603           break;
10604         case TYPE_CODE_STRUCT:
10605           if (noside != EVAL_AVOID_SIDE_EFFECTS)
10606             callee = ada_value_ind (callee);
10607           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10608           break;
10609         default:
10610           error (_("cannot subscript or call something of type `%s'"),
10611                  ada_type_name (value_type (callee)));
10612           break;
10613         }
10614     }
10615
10616   switch (type->code ())
10617     {
10618     case TYPE_CODE_FUNC:
10619       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10620         {
10621           if (TYPE_TARGET_TYPE (type) == NULL)
10622             error_call_unknown_return_type (NULL);
10623           return allocate_value (TYPE_TARGET_TYPE (type));
10624         }
10625       return call_function_by_hand (callee, NULL, argvec);
10626     case TYPE_CODE_INTERNAL_FUNCTION:
10627       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10628         /* We don't know anything about what the internal
10629            function might return, but we have to return
10630            something.  */
10631         return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10632                            not_lval);
10633       else
10634         return call_internal_function (exp->gdbarch, exp->language_defn,
10635                                        callee, nargs,
10636                                        argvec.data ());
10637
10638     case TYPE_CODE_STRUCT:
10639       {
10640         int arity;
10641
10642         arity = ada_array_arity (type);
10643         type = ada_array_element_type (type, nargs);
10644         if (type == NULL)
10645           error (_("cannot subscript or call a record"));
10646         if (arity != nargs)
10647           error (_("wrong number of subscripts; expecting %d"), arity);
10648         if (noside == EVAL_AVOID_SIDE_EFFECTS)
10649           return value_zero (ada_aligned_type (type), lval_memory);
10650         return
10651           unwrap_value (ada_value_subscript
10652                         (callee, nargs, argvec.data ()));
10653       }
10654     case TYPE_CODE_ARRAY:
10655       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10656         {
10657           type = ada_array_element_type (type, nargs);
10658           if (type == NULL)
10659             error (_("element type of array unknown"));
10660           else
10661             return value_zero (ada_aligned_type (type), lval_memory);
10662         }
10663       return
10664         unwrap_value (ada_value_subscript
10665                       (ada_coerce_to_simple_array (callee),
10666                        nargs, argvec.data ()));
10667     case TYPE_CODE_PTR:     /* Pointer to array */
10668       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10669         {
10670           type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10671           type = ada_array_element_type (type, nargs);
10672           if (type == NULL)
10673             error (_("element type of array unknown"));
10674           else
10675             return value_zero (ada_aligned_type (type), lval_memory);
10676         }
10677       return
10678         unwrap_value (ada_value_ptr_subscript (callee, nargs,
10679                                                argvec.data ()));
10680
10681     default:
10682       error (_("Attempt to index or call something other than an "
10683                "array or function"));
10684     }
10685 }
10686
10687 bool
10688 ada_funcall_operation::resolve (struct expression *exp,
10689                                 bool deprocedure_p,
10690                                 bool parse_completion,
10691                                 innermost_block_tracker *tracker,
10692                                 struct type *context_type)
10693 {
10694   operation_up &callee_op = std::get<0> (m_storage);
10695
10696   ada_var_value_operation *avv
10697     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
10698   if (avv == nullptr)
10699     return false;
10700
10701   symbol *sym = avv->get_symbol ();
10702   if (SYMBOL_DOMAIN (sym) != UNDEF_DOMAIN)
10703     return false;
10704
10705   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
10706   int nargs = args_up.size ();
10707   std::vector<value *> argvec (nargs);
10708
10709   for (int i = 0; i < args_up.size (); ++i)
10710     argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
10711
10712   const block *block = avv->get_block ();
10713   block_symbol resolved
10714     = ada_resolve_funcall (sym, block,
10715                            context_type, parse_completion,
10716                            nargs, argvec.data (),
10717                            tracker);
10718
10719   std::get<0> (m_storage)
10720     = make_operation<ada_var_value_operation> (resolved.symbol,
10721                                                resolved.block);
10722   return false;
10723 }
10724
10725 bool
10726 ada_ternop_slice_operation::resolve (struct expression *exp,
10727                                      bool deprocedure_p,
10728                                      bool parse_completion,
10729                                      innermost_block_tracker *tracker,
10730                                      struct type *context_type)
10731 {
10732   /* Historically this check was done during resolution, so we
10733      continue that here.  */
10734   value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
10735                                                 EVAL_AVOID_SIDE_EFFECTS);
10736   if (ada_is_any_packed_array_type (value_type (v)))
10737     error (_("cannot slice a packed array"));
10738   return false;
10739 }
10740
10741 }
10742
10743 \f
10744
10745 /* Return non-zero iff TYPE represents a System.Address type.  */
10746
10747 int
10748 ada_is_system_address_type (struct type *type)
10749 {
10750   return (type->name () && strcmp (type->name (), "system__address") == 0);
10751 }
10752
10753 \f
10754
10755                                 /* Range types */
10756
10757 /* Scan STR beginning at position K for a discriminant name, and
10758    return the value of that discriminant field of DVAL in *PX.  If
10759    PNEW_K is not null, put the position of the character beyond the
10760    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
10761    not alter *PX and *PNEW_K if unsuccessful.  */
10762
10763 static int
10764 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
10765                     int *pnew_k)
10766 {
10767   static std::string storage;
10768   const char *pstart, *pend, *bound;
10769   struct value *bound_val;
10770
10771   if (dval == NULL || str == NULL || str[k] == '\0')
10772     return 0;
10773
10774   pstart = str + k;
10775   pend = strstr (pstart, "__");
10776   if (pend == NULL)
10777     {
10778       bound = pstart;
10779       k += strlen (bound);
10780     }
10781   else
10782     {
10783       int len = pend - pstart;
10784
10785       /* Strip __ and beyond.  */
10786       storage = std::string (pstart, len);
10787       bound = storage.c_str ();
10788       k = pend - str;
10789     }
10790
10791   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
10792   if (bound_val == NULL)
10793     return 0;
10794
10795   *px = value_as_long (bound_val);
10796   if (pnew_k != NULL)
10797     *pnew_k = k;
10798   return 1;
10799 }
10800
10801 /* Value of variable named NAME.  Only exact matches are considered.
10802    If no such variable found, then if ERR_MSG is null, returns 0, and
10803    otherwise causes an error with message ERR_MSG.  */
10804
10805 static struct value *
10806 get_var_value (const char *name, const char *err_msg)
10807 {
10808   std::string quoted_name = add_angle_brackets (name);
10809
10810   lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
10811
10812   std::vector<struct block_symbol> syms
10813     = ada_lookup_symbol_list_worker (lookup_name,
10814                                      get_selected_block (0),
10815                                      VAR_DOMAIN, 1);
10816
10817   if (syms.size () != 1)
10818     {
10819       if (err_msg == NULL)
10820         return 0;
10821       else
10822         error (("%s"), err_msg);
10823     }
10824
10825   return value_of_variable (syms[0].symbol, syms[0].block);
10826 }
10827
10828 /* Value of integer variable named NAME in the current environment.
10829    If no such variable is found, returns false.  Otherwise, sets VALUE
10830    to the variable's value and returns true.  */
10831
10832 bool
10833 get_int_var_value (const char *name, LONGEST &value)
10834 {
10835   struct value *var_val = get_var_value (name, 0);
10836
10837   if (var_val == 0)
10838     return false;
10839
10840   value = value_as_long (var_val);
10841   return true;
10842 }
10843
10844
10845 /* Return a range type whose base type is that of the range type named
10846    NAME in the current environment, and whose bounds are calculated
10847    from NAME according to the GNAT range encoding conventions.
10848    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
10849    corresponding range type from debug information; fall back to using it
10850    if symbol lookup fails.  If a new type must be created, allocate it
10851    like ORIG_TYPE was.  The bounds information, in general, is encoded
10852    in NAME, the base type given in the named range type.  */
10853
10854 static struct type *
10855 to_fixed_range_type (struct type *raw_type, struct value *dval)
10856 {
10857   const char *name;
10858   struct type *base_type;
10859   const char *subtype_info;
10860
10861   gdb_assert (raw_type != NULL);
10862   gdb_assert (raw_type->name () != NULL);
10863
10864   if (raw_type->code () == TYPE_CODE_RANGE)
10865     base_type = TYPE_TARGET_TYPE (raw_type);
10866   else
10867     base_type = raw_type;
10868
10869   name = raw_type->name ();
10870   subtype_info = strstr (name, "___XD");
10871   if (subtype_info == NULL)
10872     {
10873       LONGEST L = ada_discrete_type_low_bound (raw_type);
10874       LONGEST U = ada_discrete_type_high_bound (raw_type);
10875
10876       if (L < INT_MIN || U > INT_MAX)
10877         return raw_type;
10878       else
10879         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
10880                                          L, U);
10881     }
10882   else
10883     {
10884       int prefix_len = subtype_info - name;
10885       LONGEST L, U;
10886       struct type *type;
10887       const char *bounds_str;
10888       int n;
10889
10890       subtype_info += 5;
10891       bounds_str = strchr (subtype_info, '_');
10892       n = 1;
10893
10894       if (*subtype_info == 'L')
10895         {
10896           if (!ada_scan_number (bounds_str, n, &L, &n)
10897               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
10898             return raw_type;
10899           if (bounds_str[n] == '_')
10900             n += 2;
10901           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
10902             n += 1;
10903           subtype_info += 1;
10904         }
10905       else
10906         {
10907           std::string name_buf = std::string (name, prefix_len) + "___L";
10908           if (!get_int_var_value (name_buf.c_str (), L))
10909             {
10910               lim_warning (_("Unknown lower bound, using 1."));
10911               L = 1;
10912             }
10913         }
10914
10915       if (*subtype_info == 'U')
10916         {
10917           if (!ada_scan_number (bounds_str, n, &U, &n)
10918               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
10919             return raw_type;
10920         }
10921       else
10922         {
10923           std::string name_buf = std::string (name, prefix_len) + "___U";
10924           if (!get_int_var_value (name_buf.c_str (), U))
10925             {
10926               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
10927               U = L;
10928             }
10929         }
10930
10931       type = create_static_range_type (alloc_type_copy (raw_type),
10932                                        base_type, L, U);
10933       /* create_static_range_type alters the resulting type's length
10934          to match the size of the base_type, which is not what we want.
10935          Set it back to the original range type's length.  */
10936       TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
10937       type->set_name (name);
10938       return type;
10939     }
10940 }
10941
10942 /* True iff NAME is the name of a range type.  */
10943
10944 int
10945 ada_is_range_type_name (const char *name)
10946 {
10947   return (name != NULL && strstr (name, "___XD"));
10948 }
10949 \f
10950
10951                                 /* Modular types */
10952
10953 /* True iff TYPE is an Ada modular type.  */
10954
10955 int
10956 ada_is_modular_type (struct type *type)
10957 {
10958   struct type *subranged_type = get_base_type (type);
10959
10960   return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
10961           && subranged_type->code () == TYPE_CODE_INT
10962           && subranged_type->is_unsigned ());
10963 }
10964
10965 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
10966
10967 ULONGEST
10968 ada_modulus (struct type *type)
10969 {
10970   const dynamic_prop &high = type->bounds ()->high;
10971
10972   if (high.kind () == PROP_CONST)
10973     return (ULONGEST) high.const_val () + 1;
10974
10975   /* If TYPE is unresolved, the high bound might be a location list.  Return
10976      0, for lack of a better value to return.  */
10977   return 0;
10978 }
10979 \f
10980
10981 /* Ada exception catchpoint support:
10982    ---------------------------------
10983
10984    We support 3 kinds of exception catchpoints:
10985      . catchpoints on Ada exceptions
10986      . catchpoints on unhandled Ada exceptions
10987      . catchpoints on failed assertions
10988
10989    Exceptions raised during failed assertions, or unhandled exceptions
10990    could perfectly be caught with the general catchpoint on Ada exceptions.
10991    However, we can easily differentiate these two special cases, and having
10992    the option to distinguish these two cases from the rest can be useful
10993    to zero-in on certain situations.
10994
10995    Exception catchpoints are a specialized form of breakpoint,
10996    since they rely on inserting breakpoints inside known routines
10997    of the GNAT runtime.  The implementation therefore uses a standard
10998    breakpoint structure of the BP_BREAKPOINT type, but with its own set
10999    of breakpoint_ops.
11000
11001    Support in the runtime for exception catchpoints have been changed
11002    a few times already, and these changes affect the implementation
11003    of these catchpoints.  In order to be able to support several
11004    variants of the runtime, we use a sniffer that will determine
11005    the runtime variant used by the program being debugged.  */
11006
11007 /* Ada's standard exceptions.
11008
11009    The Ada 83 standard also defined Numeric_Error.  But there so many
11010    situations where it was unclear from the Ada 83 Reference Manual
11011    (RM) whether Constraint_Error or Numeric_Error should be raised,
11012    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11013    Interpretation saying that anytime the RM says that Numeric_Error
11014    should be raised, the implementation may raise Constraint_Error.
11015    Ada 95 went one step further and pretty much removed Numeric_Error
11016    from the list of standard exceptions (it made it a renaming of
11017    Constraint_Error, to help preserve compatibility when compiling
11018    an Ada83 compiler). As such, we do not include Numeric_Error from
11019    this list of standard exceptions.  */
11020
11021 static const char * const standard_exc[] = {
11022   "constraint_error",
11023   "program_error",
11024   "storage_error",
11025   "tasking_error"
11026 };
11027
11028 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11029
11030 /* A structure that describes how to support exception catchpoints
11031    for a given executable.  */
11032
11033 struct exception_support_info
11034 {
11035    /* The name of the symbol to break on in order to insert
11036       a catchpoint on exceptions.  */
11037    const char *catch_exception_sym;
11038
11039    /* The name of the symbol to break on in order to insert
11040       a catchpoint on unhandled exceptions.  */
11041    const char *catch_exception_unhandled_sym;
11042
11043    /* The name of the symbol to break on in order to insert
11044       a catchpoint on failed assertions.  */
11045    const char *catch_assert_sym;
11046
11047    /* The name of the symbol to break on in order to insert
11048       a catchpoint on exception handling.  */
11049    const char *catch_handlers_sym;
11050
11051    /* Assuming that the inferior just triggered an unhandled exception
11052       catchpoint, this function is responsible for returning the address
11053       in inferior memory where the name of that exception is stored.
11054       Return zero if the address could not be computed.  */
11055    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11056 };
11057
11058 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11059 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11060
11061 /* The following exception support info structure describes how to
11062    implement exception catchpoints with the latest version of the
11063    Ada runtime (as of 2019-08-??).  */
11064
11065 static const struct exception_support_info default_exception_support_info =
11066 {
11067   "__gnat_debug_raise_exception", /* catch_exception_sym */
11068   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11069   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11070   "__gnat_begin_handler_v1", /* catch_handlers_sym */
11071   ada_unhandled_exception_name_addr
11072 };
11073
11074 /* The following exception support info structure describes how to
11075    implement exception catchpoints with an earlier version of the
11076    Ada runtime (as of 2007-03-06) using v0 of the EH ABI.  */
11077
11078 static const struct exception_support_info exception_support_info_v0 =
11079 {
11080   "__gnat_debug_raise_exception", /* catch_exception_sym */
11081   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11082   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11083   "__gnat_begin_handler", /* catch_handlers_sym */
11084   ada_unhandled_exception_name_addr
11085 };
11086
11087 /* The following exception support info structure describes how to
11088    implement exception catchpoints with a slightly older version
11089    of the Ada runtime.  */
11090
11091 static const struct exception_support_info exception_support_info_fallback =
11092 {
11093   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11094   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11095   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
11096   "__gnat_begin_handler", /* catch_handlers_sym */
11097   ada_unhandled_exception_name_addr_from_raise
11098 };
11099
11100 /* Return nonzero if we can detect the exception support routines
11101    described in EINFO.
11102
11103    This function errors out if an abnormal situation is detected
11104    (for instance, if we find the exception support routines, but
11105    that support is found to be incomplete).  */
11106
11107 static int
11108 ada_has_this_exception_support (const struct exception_support_info *einfo)
11109 {
11110   struct symbol *sym;
11111
11112   /* The symbol we're looking up is provided by a unit in the GNAT runtime
11113      that should be compiled with debugging information.  As a result, we
11114      expect to find that symbol in the symtabs.  */
11115
11116   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11117   if (sym == NULL)
11118     {
11119       /* Perhaps we did not find our symbol because the Ada runtime was
11120          compiled without debugging info, or simply stripped of it.
11121          It happens on some GNU/Linux distributions for instance, where
11122          users have to install a separate debug package in order to get
11123          the runtime's debugging info.  In that situation, let the user
11124          know why we cannot insert an Ada exception catchpoint.
11125
11126          Note: Just for the purpose of inserting our Ada exception
11127          catchpoint, we could rely purely on the associated minimal symbol.
11128          But we would be operating in degraded mode anyway, since we are
11129          still lacking the debugging info needed later on to extract
11130          the name of the exception being raised (this name is printed in
11131          the catchpoint message, and is also used when trying to catch
11132          a specific exception).  We do not handle this case for now.  */
11133       struct bound_minimal_symbol msym
11134         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11135
11136       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11137         error (_("Your Ada runtime appears to be missing some debugging "
11138                  "information.\nCannot insert Ada exception catchpoint "
11139                  "in this configuration."));
11140
11141       return 0;
11142     }
11143
11144   /* Make sure that the symbol we found corresponds to a function.  */
11145
11146   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11147     {
11148       error (_("Symbol \"%s\" is not a function (class = %d)"),
11149              sym->linkage_name (), SYMBOL_CLASS (sym));
11150       return 0;
11151     }
11152
11153   sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11154   if (sym == NULL)
11155     {
11156       struct bound_minimal_symbol msym
11157         = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11158
11159       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11160         error (_("Your Ada runtime appears to be missing some debugging "
11161                  "information.\nCannot insert Ada exception catchpoint "
11162                  "in this configuration."));
11163
11164       return 0;
11165     }
11166
11167   /* Make sure that the symbol we found corresponds to a function.  */
11168
11169   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11170     {
11171       error (_("Symbol \"%s\" is not a function (class = %d)"),
11172              sym->linkage_name (), SYMBOL_CLASS (sym));
11173       return 0;
11174     }
11175
11176   return 1;
11177 }
11178
11179 /* Inspect the Ada runtime and determine which exception info structure
11180    should be used to provide support for exception catchpoints.
11181
11182    This function will always set the per-inferior exception_info,
11183    or raise an error.  */
11184
11185 static void
11186 ada_exception_support_info_sniffer (void)
11187 {
11188   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11189
11190   /* If the exception info is already known, then no need to recompute it.  */
11191   if (data->exception_info != NULL)
11192     return;
11193
11194   /* Check the latest (default) exception support info.  */
11195   if (ada_has_this_exception_support (&default_exception_support_info))
11196     {
11197       data->exception_info = &default_exception_support_info;
11198       return;
11199     }
11200
11201   /* Try the v0 exception suport info.  */
11202   if (ada_has_this_exception_support (&exception_support_info_v0))
11203     {
11204       data->exception_info = &exception_support_info_v0;
11205       return;
11206     }
11207
11208   /* Try our fallback exception suport info.  */
11209   if (ada_has_this_exception_support (&exception_support_info_fallback))
11210     {
11211       data->exception_info = &exception_support_info_fallback;
11212       return;
11213     }
11214
11215   /* Sometimes, it is normal for us to not be able to find the routine
11216      we are looking for.  This happens when the program is linked with
11217      the shared version of the GNAT runtime, and the program has not been
11218      started yet.  Inform the user of these two possible causes if
11219      applicable.  */
11220
11221   if (ada_update_initial_language (language_unknown) != language_ada)
11222     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
11223
11224   /* If the symbol does not exist, then check that the program is
11225      already started, to make sure that shared libraries have been
11226      loaded.  If it is not started, this may mean that the symbol is
11227      in a shared library.  */
11228
11229   if (inferior_ptid.pid () == 0)
11230     error (_("Unable to insert catchpoint. Try to start the program first."));
11231
11232   /* At this point, we know that we are debugging an Ada program and
11233      that the inferior has been started, but we still are not able to
11234      find the run-time symbols.  That can mean that we are in
11235      configurable run time mode, or that a-except as been optimized
11236      out by the linker...  In any case, at this point it is not worth
11237      supporting this feature.  */
11238
11239   error (_("Cannot insert Ada exception catchpoints in this configuration."));
11240 }
11241
11242 /* True iff FRAME is very likely to be that of a function that is
11243    part of the runtime system.  This is all very heuristic, but is
11244    intended to be used as advice as to what frames are uninteresting
11245    to most users.  */
11246
11247 static int
11248 is_known_support_routine (struct frame_info *frame)
11249 {
11250   enum language func_lang;
11251   int i;
11252   const char *fullname;
11253
11254   /* If this code does not have any debugging information (no symtab),
11255      This cannot be any user code.  */
11256
11257   symtab_and_line sal = find_frame_sal (frame);
11258   if (sal.symtab == NULL)
11259     return 1;
11260
11261   /* If there is a symtab, but the associated source file cannot be
11262      located, then assume this is not user code:  Selecting a frame
11263      for which we cannot display the code would not be very helpful
11264      for the user.  This should also take care of case such as VxWorks
11265      where the kernel has some debugging info provided for a few units.  */
11266
11267   fullname = symtab_to_fullname (sal.symtab);
11268   if (access (fullname, R_OK) != 0)
11269     return 1;
11270
11271   /* Check the unit filename against the Ada runtime file naming.
11272      We also check the name of the objfile against the name of some
11273      known system libraries that sometimes come with debugging info
11274      too.  */
11275
11276   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11277     {
11278       re_comp (known_runtime_file_name_patterns[i]);
11279       if (re_exec (lbasename (sal.symtab->filename)))
11280         return 1;
11281       if (SYMTAB_OBJFILE (sal.symtab) != NULL
11282           && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
11283         return 1;
11284     }
11285
11286   /* Check whether the function is a GNAT-generated entity.  */
11287
11288   gdb::unique_xmalloc_ptr<char> func_name
11289     = find_frame_funname (frame, &func_lang, NULL);
11290   if (func_name == NULL)
11291     return 1;
11292
11293   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11294     {
11295       re_comp (known_auxiliary_function_name_patterns[i]);
11296       if (re_exec (func_name.get ()))
11297         return 1;
11298     }
11299
11300   return 0;
11301 }
11302
11303 /* Find the first frame that contains debugging information and that is not
11304    part of the Ada run-time, starting from FI and moving upward.  */
11305
11306 void
11307 ada_find_printable_frame (struct frame_info *fi)
11308 {
11309   for (; fi != NULL; fi = get_prev_frame (fi))
11310     {
11311       if (!is_known_support_routine (fi))
11312         {
11313           select_frame (fi);
11314           break;
11315         }
11316     }
11317
11318 }
11319
11320 /* Assuming that the inferior just triggered an unhandled exception
11321    catchpoint, return the address in inferior memory where the name
11322    of the exception is stored.
11323    
11324    Return zero if the address could not be computed.  */
11325
11326 static CORE_ADDR
11327 ada_unhandled_exception_name_addr (void)
11328 {
11329   return parse_and_eval_address ("e.full_name");
11330 }
11331
11332 /* Same as ada_unhandled_exception_name_addr, except that this function
11333    should be used when the inferior uses an older version of the runtime,
11334    where the exception name needs to be extracted from a specific frame
11335    several frames up in the callstack.  */
11336
11337 static CORE_ADDR
11338 ada_unhandled_exception_name_addr_from_raise (void)
11339 {
11340   int frame_level;
11341   struct frame_info *fi;
11342   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11343
11344   /* To determine the name of this exception, we need to select
11345      the frame corresponding to RAISE_SYM_NAME.  This frame is
11346      at least 3 levels up, so we simply skip the first 3 frames
11347      without checking the name of their associated function.  */
11348   fi = get_current_frame ();
11349   for (frame_level = 0; frame_level < 3; frame_level += 1)
11350     if (fi != NULL)
11351       fi = get_prev_frame (fi); 
11352
11353   while (fi != NULL)
11354     {
11355       enum language func_lang;
11356
11357       gdb::unique_xmalloc_ptr<char> func_name
11358         = find_frame_funname (fi, &func_lang, NULL);
11359       if (func_name != NULL)
11360         {
11361           if (strcmp (func_name.get (),
11362                       data->exception_info->catch_exception_sym) == 0)
11363             break; /* We found the frame we were looking for...  */
11364         }
11365       fi = get_prev_frame (fi);
11366     }
11367
11368   if (fi == NULL)
11369     return 0;
11370
11371   select_frame (fi);
11372   return parse_and_eval_address ("id.full_name");
11373 }
11374
11375 /* Assuming the inferior just triggered an Ada exception catchpoint
11376    (of any type), return the address in inferior memory where the name
11377    of the exception is stored, if applicable.
11378
11379    Assumes the selected frame is the current frame.
11380
11381    Return zero if the address could not be computed, or if not relevant.  */
11382
11383 static CORE_ADDR
11384 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
11385                            struct breakpoint *b)
11386 {
11387   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11388
11389   switch (ex)
11390     {
11391       case ada_catch_exception:
11392         return (parse_and_eval_address ("e.full_name"));
11393         break;
11394
11395       case ada_catch_exception_unhandled:
11396         return data->exception_info->unhandled_exception_name_addr ();
11397         break;
11398
11399       case ada_catch_handlers:
11400         return 0;  /* The runtimes does not provide access to the exception
11401                       name.  */
11402         break;
11403
11404       case ada_catch_assert:
11405         return 0;  /* Exception name is not relevant in this case.  */
11406         break;
11407
11408       default:
11409         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11410         break;
11411     }
11412
11413   return 0; /* Should never be reached.  */
11414 }
11415
11416 /* Assuming the inferior is stopped at an exception catchpoint,
11417    return the message which was associated to the exception, if
11418    available.  Return NULL if the message could not be retrieved.
11419
11420    Note: The exception message can be associated to an exception
11421    either through the use of the Raise_Exception function, or
11422    more simply (Ada 2005 and later), via:
11423
11424        raise Exception_Name with "exception message";
11425
11426    */
11427
11428 static gdb::unique_xmalloc_ptr<char>
11429 ada_exception_message_1 (void)
11430 {
11431   struct value *e_msg_val;
11432   int e_msg_len;
11433
11434   /* For runtimes that support this feature, the exception message
11435      is passed as an unbounded string argument called "message".  */
11436   e_msg_val = parse_and_eval ("message");
11437   if (e_msg_val == NULL)
11438     return NULL; /* Exception message not supported.  */
11439
11440   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
11441   gdb_assert (e_msg_val != NULL);
11442   e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
11443
11444   /* If the message string is empty, then treat it as if there was
11445      no exception message.  */
11446   if (e_msg_len <= 0)
11447     return NULL;
11448
11449   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
11450   read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
11451                e_msg_len);
11452   e_msg.get ()[e_msg_len] = '\0';
11453
11454   return e_msg;
11455 }
11456
11457 /* Same as ada_exception_message_1, except that all exceptions are
11458    contained here (returning NULL instead).  */
11459
11460 static gdb::unique_xmalloc_ptr<char>
11461 ada_exception_message (void)
11462 {
11463   gdb::unique_xmalloc_ptr<char> e_msg;
11464
11465   try
11466     {
11467       e_msg = ada_exception_message_1 ();
11468     }
11469   catch (const gdb_exception_error &e)
11470     {
11471       e_msg.reset (nullptr);
11472     }
11473
11474   return e_msg;
11475 }
11476
11477 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11478    any error that ada_exception_name_addr_1 might cause to be thrown.
11479    When an error is intercepted, a warning with the error message is printed,
11480    and zero is returned.  */
11481
11482 static CORE_ADDR
11483 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
11484                          struct breakpoint *b)
11485 {
11486   CORE_ADDR result = 0;
11487
11488   try
11489     {
11490       result = ada_exception_name_addr_1 (ex, b);
11491     }
11492
11493   catch (const gdb_exception_error &e)
11494     {
11495       warning (_("failed to get exception name: %s"), e.what ());
11496       return 0;
11497     }
11498
11499   return result;
11500 }
11501
11502 static std::string ada_exception_catchpoint_cond_string
11503   (const char *excep_string,
11504    enum ada_exception_catchpoint_kind ex);
11505
11506 /* Ada catchpoints.
11507
11508    In the case of catchpoints on Ada exceptions, the catchpoint will
11509    stop the target on every exception the program throws.  When a user
11510    specifies the name of a specific exception, we translate this
11511    request into a condition expression (in text form), and then parse
11512    it into an expression stored in each of the catchpoint's locations.
11513    We then use this condition to check whether the exception that was
11514    raised is the one the user is interested in.  If not, then the
11515    target is resumed again.  We store the name of the requested
11516    exception, in order to be able to re-set the condition expression
11517    when symbols change.  */
11518
11519 /* An instance of this type is used to represent an Ada catchpoint
11520    breakpoint location.  */
11521
11522 class ada_catchpoint_location : public bp_location
11523 {
11524 public:
11525   ada_catchpoint_location (breakpoint *owner)
11526     : bp_location (owner, bp_loc_software_breakpoint)
11527   {}
11528
11529   /* The condition that checks whether the exception that was raised
11530      is the specific exception the user specified on catchpoint
11531      creation.  */
11532   expression_up excep_cond_expr;
11533 };
11534
11535 /* An instance of this type is used to represent an Ada catchpoint.  */
11536
11537 struct ada_catchpoint : public breakpoint
11538 {
11539   explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind)
11540     : m_kind (kind)
11541   {
11542   }
11543
11544   /* The name of the specific exception the user specified.  */
11545   std::string excep_string;
11546
11547   /* What kind of catchpoint this is.  */
11548   enum ada_exception_catchpoint_kind m_kind;
11549 };
11550
11551 /* Parse the exception condition string in the context of each of the
11552    catchpoint's locations, and store them for later evaluation.  */
11553
11554 static void
11555 create_excep_cond_exprs (struct ada_catchpoint *c,
11556                          enum ada_exception_catchpoint_kind ex)
11557 {
11558   struct bp_location *bl;
11559
11560   /* Nothing to do if there's no specific exception to catch.  */
11561   if (c->excep_string.empty ())
11562     return;
11563
11564   /* Same if there are no locations... */
11565   if (c->loc == NULL)
11566     return;
11567
11568   /* Compute the condition expression in text form, from the specific
11569      expection we want to catch.  */
11570   std::string cond_string
11571     = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
11572
11573   /* Iterate over all the catchpoint's locations, and parse an
11574      expression for each.  */
11575   for (bl = c->loc; bl != NULL; bl = bl->next)
11576     {
11577       struct ada_catchpoint_location *ada_loc
11578         = (struct ada_catchpoint_location *) bl;
11579       expression_up exp;
11580
11581       if (!bl->shlib_disabled)
11582         {
11583           const char *s;
11584
11585           s = cond_string.c_str ();
11586           try
11587             {
11588               exp = parse_exp_1 (&s, bl->address,
11589                                  block_for_pc (bl->address),
11590                                  0);
11591             }
11592           catch (const gdb_exception_error &e)
11593             {
11594               warning (_("failed to reevaluate internal exception condition "
11595                          "for catchpoint %d: %s"),
11596                        c->number, e.what ());
11597             }
11598         }
11599
11600       ada_loc->excep_cond_expr = std::move (exp);
11601     }
11602 }
11603
11604 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11605    structure for all exception catchpoint kinds.  */
11606
11607 static struct bp_location *
11608 allocate_location_exception (struct breakpoint *self)
11609 {
11610   return new ada_catchpoint_location (self);
11611 }
11612
11613 /* Implement the RE_SET method in the breakpoint_ops structure for all
11614    exception catchpoint kinds.  */
11615
11616 static void
11617 re_set_exception (struct breakpoint *b)
11618 {
11619   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11620
11621   /* Call the base class's method.  This updates the catchpoint's
11622      locations.  */
11623   bkpt_breakpoint_ops.re_set (b);
11624
11625   /* Reparse the exception conditional expressions.  One for each
11626      location.  */
11627   create_excep_cond_exprs (c, c->m_kind);
11628 }
11629
11630 /* Returns true if we should stop for this breakpoint hit.  If the
11631    user specified a specific exception, we only want to cause a stop
11632    if the program thrown that exception.  */
11633
11634 static int
11635 should_stop_exception (const struct bp_location *bl)
11636 {
11637   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11638   const struct ada_catchpoint_location *ada_loc
11639     = (const struct ada_catchpoint_location *) bl;
11640   int stop;
11641
11642   struct internalvar *var = lookup_internalvar ("_ada_exception");
11643   if (c->m_kind == ada_catch_assert)
11644     clear_internalvar (var);
11645   else
11646     {
11647       try
11648         {
11649           const char *expr;
11650
11651           if (c->m_kind == ada_catch_handlers)
11652             expr = ("GNAT_GCC_exception_Access(gcc_exception)"
11653                     ".all.occurrence.id");
11654           else
11655             expr = "e";
11656
11657           struct value *exc = parse_and_eval (expr);
11658           set_internalvar (var, exc);
11659         }
11660       catch (const gdb_exception_error &ex)
11661         {
11662           clear_internalvar (var);
11663         }
11664     }
11665
11666   /* With no specific exception, should always stop.  */
11667   if (c->excep_string.empty ())
11668     return 1;
11669
11670   if (ada_loc->excep_cond_expr == NULL)
11671     {
11672       /* We will have a NULL expression if back when we were creating
11673          the expressions, this location's had failed to parse.  */
11674       return 1;
11675     }
11676
11677   stop = 1;
11678   try
11679     {
11680       struct value *mark;
11681
11682       mark = value_mark ();
11683       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
11684       value_free_to_mark (mark);
11685     }
11686   catch (const gdb_exception &ex)
11687     {
11688       exception_fprintf (gdb_stderr, ex,
11689                          _("Error in testing exception condition:\n"));
11690     }
11691
11692   return stop;
11693 }
11694
11695 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
11696    for all exception catchpoint kinds.  */
11697
11698 static void
11699 check_status_exception (bpstat bs)
11700 {
11701   bs->stop = should_stop_exception (bs->bp_location_at.get ());
11702 }
11703
11704 /* Implement the PRINT_IT method in the breakpoint_ops structure
11705    for all exception catchpoint kinds.  */
11706
11707 static enum print_stop_action
11708 print_it_exception (bpstat bs)
11709 {
11710   struct ui_out *uiout = current_uiout;
11711   struct breakpoint *b = bs->breakpoint_at;
11712
11713   annotate_catchpoint (b->number);
11714
11715   if (uiout->is_mi_like_p ())
11716     {
11717       uiout->field_string ("reason",
11718                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11719       uiout->field_string ("disp", bpdisp_text (b->disposition));
11720     }
11721
11722   uiout->text (b->disposition == disp_del
11723                ? "\nTemporary catchpoint " : "\nCatchpoint ");
11724   uiout->field_signed ("bkptno", b->number);
11725   uiout->text (", ");
11726
11727   /* ada_exception_name_addr relies on the selected frame being the
11728      current frame.  Need to do this here because this function may be
11729      called more than once when printing a stop, and below, we'll
11730      select the first frame past the Ada run-time (see
11731      ada_find_printable_frame).  */
11732   select_frame (get_current_frame ());
11733
11734   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11735   switch (c->m_kind)
11736     {
11737       case ada_catch_exception:
11738       case ada_catch_exception_unhandled:
11739       case ada_catch_handlers:
11740         {
11741           const CORE_ADDR addr = ada_exception_name_addr (c->m_kind, b);
11742           char exception_name[256];
11743
11744           if (addr != 0)
11745             {
11746               read_memory (addr, (gdb_byte *) exception_name,
11747                            sizeof (exception_name) - 1);
11748               exception_name [sizeof (exception_name) - 1] = '\0';
11749             }
11750           else
11751             {
11752               /* For some reason, we were unable to read the exception
11753                  name.  This could happen if the Runtime was compiled
11754                  without debugging info, for instance.  In that case,
11755                  just replace the exception name by the generic string
11756                  "exception" - it will read as "an exception" in the
11757                  notification we are about to print.  */
11758               memcpy (exception_name, "exception", sizeof ("exception"));
11759             }
11760           /* In the case of unhandled exception breakpoints, we print
11761              the exception name as "unhandled EXCEPTION_NAME", to make
11762              it clearer to the user which kind of catchpoint just got
11763              hit.  We used ui_out_text to make sure that this extra
11764              info does not pollute the exception name in the MI case.  */
11765           if (c->m_kind == ada_catch_exception_unhandled)
11766             uiout->text ("unhandled ");
11767           uiout->field_string ("exception-name", exception_name);
11768         }
11769         break;
11770       case ada_catch_assert:
11771         /* In this case, the name of the exception is not really
11772            important.  Just print "failed assertion" to make it clearer
11773            that his program just hit an assertion-failure catchpoint.
11774            We used ui_out_text because this info does not belong in
11775            the MI output.  */
11776         uiout->text ("failed assertion");
11777         break;
11778     }
11779
11780   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
11781   if (exception_message != NULL)
11782     {
11783       uiout->text (" (");
11784       uiout->field_string ("exception-message", exception_message.get ());
11785       uiout->text (")");
11786     }
11787
11788   uiout->text (" at ");
11789   ada_find_printable_frame (get_current_frame ());
11790
11791   return PRINT_SRC_AND_LOC;
11792 }
11793
11794 /* Implement the PRINT_ONE method in the breakpoint_ops structure
11795    for all exception catchpoint kinds.  */
11796
11797 static void
11798 print_one_exception (struct breakpoint *b, struct bp_location **last_loc)
11799
11800   struct ui_out *uiout = current_uiout;
11801   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11802   struct value_print_options opts;
11803
11804   get_user_print_options (&opts);
11805
11806   if (opts.addressprint)
11807     uiout->field_skip ("addr");
11808
11809   annotate_field (5);
11810   switch (c->m_kind)
11811     {
11812       case ada_catch_exception:
11813         if (!c->excep_string.empty ())
11814           {
11815             std::string msg = string_printf (_("`%s' Ada exception"),
11816                                              c->excep_string.c_str ());
11817
11818             uiout->field_string ("what", msg);
11819           }
11820         else
11821           uiout->field_string ("what", "all Ada exceptions");
11822         
11823         break;
11824
11825       case ada_catch_exception_unhandled:
11826         uiout->field_string ("what", "unhandled Ada exceptions");
11827         break;
11828       
11829       case ada_catch_handlers:
11830         if (!c->excep_string.empty ())
11831           {
11832             uiout->field_fmt ("what",
11833                               _("`%s' Ada exception handlers"),
11834                               c->excep_string.c_str ());
11835           }
11836         else
11837           uiout->field_string ("what", "all Ada exceptions handlers");
11838         break;
11839
11840       case ada_catch_assert:
11841         uiout->field_string ("what", "failed Ada assertions");
11842         break;
11843
11844       default:
11845         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11846         break;
11847     }
11848 }
11849
11850 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
11851    for all exception catchpoint kinds.  */
11852
11853 static void
11854 print_mention_exception (struct breakpoint *b)
11855 {
11856   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11857   struct ui_out *uiout = current_uiout;
11858
11859   uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
11860                                                  : _("Catchpoint "));
11861   uiout->field_signed ("bkptno", b->number);
11862   uiout->text (": ");
11863
11864   switch (c->m_kind)
11865     {
11866       case ada_catch_exception:
11867         if (!c->excep_string.empty ())
11868           {
11869             std::string info = string_printf (_("`%s' Ada exception"),
11870                                               c->excep_string.c_str ());
11871             uiout->text (info.c_str ());
11872           }
11873         else
11874           uiout->text (_("all Ada exceptions"));
11875         break;
11876
11877       case ada_catch_exception_unhandled:
11878         uiout->text (_("unhandled Ada exceptions"));
11879         break;
11880
11881       case ada_catch_handlers:
11882         if (!c->excep_string.empty ())
11883           {
11884             std::string info
11885               = string_printf (_("`%s' Ada exception handlers"),
11886                                c->excep_string.c_str ());
11887             uiout->text (info.c_str ());
11888           }
11889         else
11890           uiout->text (_("all Ada exceptions handlers"));
11891         break;
11892
11893       case ada_catch_assert:
11894         uiout->text (_("failed Ada assertions"));
11895         break;
11896
11897       default:
11898         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11899         break;
11900     }
11901 }
11902
11903 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
11904    for all exception catchpoint kinds.  */
11905
11906 static void
11907 print_recreate_exception (struct breakpoint *b, struct ui_file *fp)
11908 {
11909   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11910
11911   switch (c->m_kind)
11912     {
11913       case ada_catch_exception:
11914         fprintf_filtered (fp, "catch exception");
11915         if (!c->excep_string.empty ())
11916           fprintf_filtered (fp, " %s", c->excep_string.c_str ());
11917         break;
11918
11919       case ada_catch_exception_unhandled:
11920         fprintf_filtered (fp, "catch exception unhandled");
11921         break;
11922
11923       case ada_catch_handlers:
11924         fprintf_filtered (fp, "catch handlers");
11925         break;
11926
11927       case ada_catch_assert:
11928         fprintf_filtered (fp, "catch assert");
11929         break;
11930
11931       default:
11932         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11933     }
11934   print_recreate_thread (b, fp);
11935 }
11936
11937 /* Virtual tables for various breakpoint types.  */
11938 static struct breakpoint_ops catch_exception_breakpoint_ops;
11939 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
11940 static struct breakpoint_ops catch_assert_breakpoint_ops;
11941 static struct breakpoint_ops catch_handlers_breakpoint_ops;
11942
11943 /* See ada-lang.h.  */
11944
11945 bool
11946 is_ada_exception_catchpoint (breakpoint *bp)
11947 {
11948   return (bp->ops == &catch_exception_breakpoint_ops
11949           || bp->ops == &catch_exception_unhandled_breakpoint_ops
11950           || bp->ops == &catch_assert_breakpoint_ops
11951           || bp->ops == &catch_handlers_breakpoint_ops);
11952 }
11953
11954 /* Split the arguments specified in a "catch exception" command.  
11955    Set EX to the appropriate catchpoint type.
11956    Set EXCEP_STRING to the name of the specific exception if
11957    specified by the user.
11958    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
11959    "catch handlers" command.  False otherwise.
11960    If a condition is found at the end of the arguments, the condition
11961    expression is stored in COND_STRING (memory must be deallocated
11962    after use).  Otherwise COND_STRING is set to NULL.  */
11963
11964 static void
11965 catch_ada_exception_command_split (const char *args,
11966                                    bool is_catch_handlers_cmd,
11967                                    enum ada_exception_catchpoint_kind *ex,
11968                                    std::string *excep_string,
11969                                    std::string *cond_string)
11970 {
11971   std::string exception_name;
11972
11973   exception_name = extract_arg (&args);
11974   if (exception_name == "if")
11975     {
11976       /* This is not an exception name; this is the start of a condition
11977          expression for a catchpoint on all exceptions.  So, "un-get"
11978          this token, and set exception_name to NULL.  */
11979       exception_name.clear ();
11980       args -= 2;
11981     }
11982
11983   /* Check to see if we have a condition.  */
11984
11985   args = skip_spaces (args);
11986   if (startswith (args, "if")
11987       && (isspace (args[2]) || args[2] == '\0'))
11988     {
11989       args += 2;
11990       args = skip_spaces (args);
11991
11992       if (args[0] == '\0')
11993         error (_("Condition missing after `if' keyword"));
11994       *cond_string = args;
11995
11996       args += strlen (args);
11997     }
11998
11999   /* Check that we do not have any more arguments.  Anything else
12000      is unexpected.  */
12001
12002   if (args[0] != '\0')
12003     error (_("Junk at end of expression"));
12004
12005   if (is_catch_handlers_cmd)
12006     {
12007       /* Catch handling of exceptions.  */
12008       *ex = ada_catch_handlers;
12009       *excep_string = exception_name;
12010     }
12011   else if (exception_name.empty ())
12012     {
12013       /* Catch all exceptions.  */
12014       *ex = ada_catch_exception;
12015       excep_string->clear ();
12016     }
12017   else if (exception_name == "unhandled")
12018     {
12019       /* Catch unhandled exceptions.  */
12020       *ex = ada_catch_exception_unhandled;
12021       excep_string->clear ();
12022     }
12023   else
12024     {
12025       /* Catch a specific exception.  */
12026       *ex = ada_catch_exception;
12027       *excep_string = exception_name;
12028     }
12029 }
12030
12031 /* Return the name of the symbol on which we should break in order to
12032    implement a catchpoint of the EX kind.  */
12033
12034 static const char *
12035 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12036 {
12037   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12038
12039   gdb_assert (data->exception_info != NULL);
12040
12041   switch (ex)
12042     {
12043       case ada_catch_exception:
12044         return (data->exception_info->catch_exception_sym);
12045         break;
12046       case ada_catch_exception_unhandled:
12047         return (data->exception_info->catch_exception_unhandled_sym);
12048         break;
12049       case ada_catch_assert:
12050         return (data->exception_info->catch_assert_sym);
12051         break;
12052       case ada_catch_handlers:
12053         return (data->exception_info->catch_handlers_sym);
12054         break;
12055       default:
12056         internal_error (__FILE__, __LINE__,
12057                         _("unexpected catchpoint kind (%d)"), ex);
12058     }
12059 }
12060
12061 /* Return the breakpoint ops "virtual table" used for catchpoints
12062    of the EX kind.  */
12063
12064 static const struct breakpoint_ops *
12065 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
12066 {
12067   switch (ex)
12068     {
12069       case ada_catch_exception:
12070         return (&catch_exception_breakpoint_ops);
12071         break;
12072       case ada_catch_exception_unhandled:
12073         return (&catch_exception_unhandled_breakpoint_ops);
12074         break;
12075       case ada_catch_assert:
12076         return (&catch_assert_breakpoint_ops);
12077         break;
12078       case ada_catch_handlers:
12079         return (&catch_handlers_breakpoint_ops);
12080         break;
12081       default:
12082         internal_error (__FILE__, __LINE__,
12083                         _("unexpected catchpoint kind (%d)"), ex);
12084     }
12085 }
12086
12087 /* Return the condition that will be used to match the current exception
12088    being raised with the exception that the user wants to catch.  This
12089    assumes that this condition is used when the inferior just triggered
12090    an exception catchpoint.
12091    EX: the type of catchpoints used for catching Ada exceptions.  */
12092
12093 static std::string
12094 ada_exception_catchpoint_cond_string (const char *excep_string,
12095                                       enum ada_exception_catchpoint_kind ex)
12096 {
12097   int i;
12098   bool is_standard_exc = false;
12099   std::string result;
12100
12101   if (ex == ada_catch_handlers)
12102     {
12103       /* For exception handlers catchpoints, the condition string does
12104          not use the same parameter as for the other exceptions.  */
12105       result = ("long_integer (GNAT_GCC_exception_Access"
12106                 "(gcc_exception).all.occurrence.id)");
12107     }
12108   else
12109     result = "long_integer (e)";
12110
12111   /* The standard exceptions are a special case.  They are defined in
12112      runtime units that have been compiled without debugging info; if
12113      EXCEP_STRING is the not-fully-qualified name of a standard
12114      exception (e.g. "constraint_error") then, during the evaluation
12115      of the condition expression, the symbol lookup on this name would
12116      *not* return this standard exception.  The catchpoint condition
12117      may then be set only on user-defined exceptions which have the
12118      same not-fully-qualified name (e.g. my_package.constraint_error).
12119
12120      To avoid this unexcepted behavior, these standard exceptions are
12121      systematically prefixed by "standard".  This means that "catch
12122      exception constraint_error" is rewritten into "catch exception
12123      standard.constraint_error".
12124
12125      If an exception named constraint_error is defined in another package of
12126      the inferior program, then the only way to specify this exception as a
12127      breakpoint condition is to use its fully-qualified named:
12128      e.g. my_package.constraint_error.  */
12129
12130   for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12131     {
12132       if (strcmp (standard_exc [i], excep_string) == 0)
12133         {
12134           is_standard_exc = true;
12135           break;
12136         }
12137     }
12138
12139   result += " = ";
12140
12141   if (is_standard_exc)
12142     string_appendf (result, "long_integer (&standard.%s)", excep_string);
12143   else
12144     string_appendf (result, "long_integer (&%s)", excep_string);
12145
12146   return result;
12147 }
12148
12149 /* Return the symtab_and_line that should be used to insert an exception
12150    catchpoint of the TYPE kind.
12151
12152    ADDR_STRING returns the name of the function where the real
12153    breakpoint that implements the catchpoints is set, depending on the
12154    type of catchpoint we need to create.  */
12155
12156 static struct symtab_and_line
12157 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12158                    std::string *addr_string, const struct breakpoint_ops **ops)
12159 {
12160   const char *sym_name;
12161   struct symbol *sym;
12162
12163   /* First, find out which exception support info to use.  */
12164   ada_exception_support_info_sniffer ();
12165
12166   /* Then lookup the function on which we will break in order to catch
12167      the Ada exceptions requested by the user.  */
12168   sym_name = ada_exception_sym_name (ex);
12169   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12170
12171   if (sym == NULL)
12172     error (_("Catchpoint symbol not found: %s"), sym_name);
12173
12174   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12175     error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12176
12177   /* Set ADDR_STRING.  */
12178   *addr_string = sym_name;
12179
12180   /* Set OPS.  */
12181   *ops = ada_exception_breakpoint_ops (ex);
12182
12183   return find_function_start_sal (sym, 1);
12184 }
12185
12186 /* Create an Ada exception catchpoint.
12187
12188    EX_KIND is the kind of exception catchpoint to be created.
12189
12190    If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12191    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
12192    of the exception to which this catchpoint applies.
12193
12194    COND_STRING, if not empty, is the catchpoint condition.
12195
12196    TEMPFLAG, if nonzero, means that the underlying breakpoint
12197    should be temporary.
12198
12199    FROM_TTY is the usual argument passed to all commands implementations.  */
12200
12201 void
12202 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12203                                  enum ada_exception_catchpoint_kind ex_kind,
12204                                  const std::string &excep_string,
12205                                  const std::string &cond_string,
12206                                  int tempflag,
12207                                  int disabled,
12208                                  int from_tty)
12209 {
12210   std::string addr_string;
12211   const struct breakpoint_ops *ops = NULL;
12212   struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
12213
12214   std::unique_ptr<ada_catchpoint> c (new ada_catchpoint (ex_kind));
12215   init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
12216                                  ops, tempflag, disabled, from_tty);
12217   c->excep_string = excep_string;
12218   create_excep_cond_exprs (c.get (), ex_kind);
12219   if (!cond_string.empty ())
12220     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12221   install_breakpoint (0, std::move (c), 1);
12222 }
12223
12224 /* Implement the "catch exception" command.  */
12225
12226 static void
12227 catch_ada_exception_command (const char *arg_entry, int from_tty,
12228                              struct cmd_list_element *command)
12229 {
12230   const char *arg = arg_entry;
12231   struct gdbarch *gdbarch = get_current_arch ();
12232   int tempflag;
12233   enum ada_exception_catchpoint_kind ex_kind;
12234   std::string excep_string;
12235   std::string cond_string;
12236
12237   tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12238
12239   if (!arg)
12240     arg = "";
12241   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12242                                      &cond_string);
12243   create_ada_exception_catchpoint (gdbarch, ex_kind,
12244                                    excep_string, cond_string,
12245                                    tempflag, 1 /* enabled */,
12246                                    from_tty);
12247 }
12248
12249 /* Implement the "catch handlers" command.  */
12250
12251 static void
12252 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12253                             struct cmd_list_element *command)
12254 {
12255   const char *arg = arg_entry;
12256   struct gdbarch *gdbarch = get_current_arch ();
12257   int tempflag;
12258   enum ada_exception_catchpoint_kind ex_kind;
12259   std::string excep_string;
12260   std::string cond_string;
12261
12262   tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12263
12264   if (!arg)
12265     arg = "";
12266   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12267                                      &cond_string);
12268   create_ada_exception_catchpoint (gdbarch, ex_kind,
12269                                    excep_string, cond_string,
12270                                    tempflag, 1 /* enabled */,
12271                                    from_tty);
12272 }
12273
12274 /* Completion function for the Ada "catch" commands.  */
12275
12276 static void
12277 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12278                      const char *text, const char *word)
12279 {
12280   std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12281
12282   for (const ada_exc_info &info : exceptions)
12283     {
12284       if (startswith (info.name, word))
12285         tracker.add_completion (make_unique_xstrdup (info.name));
12286     }
12287 }
12288
12289 /* Split the arguments specified in a "catch assert" command.
12290
12291    ARGS contains the command's arguments (or the empty string if
12292    no arguments were passed).
12293
12294    If ARGS contains a condition, set COND_STRING to that condition
12295    (the memory needs to be deallocated after use).  */
12296
12297 static void
12298 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12299 {
12300   args = skip_spaces (args);
12301
12302   /* Check whether a condition was provided.  */
12303   if (startswith (args, "if")
12304       && (isspace (args[2]) || args[2] == '\0'))
12305     {
12306       args += 2;
12307       args = skip_spaces (args);
12308       if (args[0] == '\0')
12309         error (_("condition missing after `if' keyword"));
12310       cond_string.assign (args);
12311     }
12312
12313   /* Otherwise, there should be no other argument at the end of
12314      the command.  */
12315   else if (args[0] != '\0')
12316     error (_("Junk at end of arguments."));
12317 }
12318
12319 /* Implement the "catch assert" command.  */
12320
12321 static void
12322 catch_assert_command (const char *arg_entry, int from_tty,
12323                       struct cmd_list_element *command)
12324 {
12325   const char *arg = arg_entry;
12326   struct gdbarch *gdbarch = get_current_arch ();
12327   int tempflag;
12328   std::string cond_string;
12329
12330   tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12331
12332   if (!arg)
12333     arg = "";
12334   catch_ada_assert_command_split (arg, cond_string);
12335   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12336                                    "", cond_string,
12337                                    tempflag, 1 /* enabled */,
12338                                    from_tty);
12339 }
12340
12341 /* Return non-zero if the symbol SYM is an Ada exception object.  */
12342
12343 static int
12344 ada_is_exception_sym (struct symbol *sym)
12345 {
12346   const char *type_name = SYMBOL_TYPE (sym)->name ();
12347
12348   return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12349           && SYMBOL_CLASS (sym) != LOC_BLOCK
12350           && SYMBOL_CLASS (sym) != LOC_CONST
12351           && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12352           && type_name != NULL && strcmp (type_name, "exception") == 0);
12353 }
12354
12355 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12356    Ada exception object.  This matches all exceptions except the ones
12357    defined by the Ada language.  */
12358
12359 static int
12360 ada_is_non_standard_exception_sym (struct symbol *sym)
12361 {
12362   int i;
12363
12364   if (!ada_is_exception_sym (sym))
12365     return 0;
12366
12367   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12368     if (strcmp (sym->linkage_name (), standard_exc[i]) == 0)
12369       return 0;  /* A standard exception.  */
12370
12371   /* Numeric_Error is also a standard exception, so exclude it.
12372      See the STANDARD_EXC description for more details as to why
12373      this exception is not listed in that array.  */
12374   if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12375     return 0;
12376
12377   return 1;
12378 }
12379
12380 /* A helper function for std::sort, comparing two struct ada_exc_info
12381    objects.
12382
12383    The comparison is determined first by exception name, and then
12384    by exception address.  */
12385
12386 bool
12387 ada_exc_info::operator< (const ada_exc_info &other) const
12388 {
12389   int result;
12390
12391   result = strcmp (name, other.name);
12392   if (result < 0)
12393     return true;
12394   if (result == 0 && addr < other.addr)
12395     return true;
12396   return false;
12397 }
12398
12399 bool
12400 ada_exc_info::operator== (const ada_exc_info &other) const
12401 {
12402   return addr == other.addr && strcmp (name, other.name) == 0;
12403 }
12404
12405 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12406    routine, but keeping the first SKIP elements untouched.
12407
12408    All duplicates are also removed.  */
12409
12410 static void
12411 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
12412                                       int skip)
12413 {
12414   std::sort (exceptions->begin () + skip, exceptions->end ());
12415   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
12416                      exceptions->end ());
12417 }
12418
12419 /* Add all exceptions defined by the Ada standard whose name match
12420    a regular expression.
12421
12422    If PREG is not NULL, then this regexp_t object is used to
12423    perform the symbol name matching.  Otherwise, no name-based
12424    filtering is performed.
12425
12426    EXCEPTIONS is a vector of exceptions to which matching exceptions
12427    gets pushed.  */
12428
12429 static void
12430 ada_add_standard_exceptions (compiled_regex *preg,
12431                              std::vector<ada_exc_info> *exceptions)
12432 {
12433   int i;
12434
12435   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12436     {
12437       if (preg == NULL
12438           || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
12439         {
12440           struct bound_minimal_symbol msymbol
12441             = ada_lookup_simple_minsym (standard_exc[i]);
12442
12443           if (msymbol.minsym != NULL)
12444             {
12445               struct ada_exc_info info
12446                 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
12447
12448               exceptions->push_back (info);
12449             }
12450         }
12451     }
12452 }
12453
12454 /* Add all Ada exceptions defined locally and accessible from the given
12455    FRAME.
12456
12457    If PREG is not NULL, then this regexp_t object is used to
12458    perform the symbol name matching.  Otherwise, no name-based
12459    filtering is performed.
12460
12461    EXCEPTIONS is a vector of exceptions to which matching exceptions
12462    gets pushed.  */
12463
12464 static void
12465 ada_add_exceptions_from_frame (compiled_regex *preg,
12466                                struct frame_info *frame,
12467                                std::vector<ada_exc_info> *exceptions)
12468 {
12469   const struct block *block = get_frame_block (frame, 0);
12470
12471   while (block != 0)
12472     {
12473       struct block_iterator iter;
12474       struct symbol *sym;
12475
12476       ALL_BLOCK_SYMBOLS (block, iter, sym)
12477         {
12478           switch (SYMBOL_CLASS (sym))
12479             {
12480             case LOC_TYPEDEF:
12481             case LOC_BLOCK:
12482             case LOC_CONST:
12483               break;
12484             default:
12485               if (ada_is_exception_sym (sym))
12486                 {
12487                   struct ada_exc_info info = {sym->print_name (),
12488                                               SYMBOL_VALUE_ADDRESS (sym)};
12489
12490                   exceptions->push_back (info);
12491                 }
12492             }
12493         }
12494       if (BLOCK_FUNCTION (block) != NULL)
12495         break;
12496       block = BLOCK_SUPERBLOCK (block);
12497     }
12498 }
12499
12500 /* Return true if NAME matches PREG or if PREG is NULL.  */
12501
12502 static bool
12503 name_matches_regex (const char *name, compiled_regex *preg)
12504 {
12505   return (preg == NULL
12506           || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
12507 }
12508
12509 /* Add all exceptions defined globally whose name name match
12510    a regular expression, excluding standard exceptions.
12511
12512    The reason we exclude standard exceptions is that they need
12513    to be handled separately: Standard exceptions are defined inside
12514    a runtime unit which is normally not compiled with debugging info,
12515    and thus usually do not show up in our symbol search.  However,
12516    if the unit was in fact built with debugging info, we need to
12517    exclude them because they would duplicate the entry we found
12518    during the special loop that specifically searches for those
12519    standard exceptions.
12520
12521    If PREG is not NULL, then this regexp_t object is used to
12522    perform the symbol name matching.  Otherwise, no name-based
12523    filtering is performed.
12524
12525    EXCEPTIONS is a vector of exceptions to which matching exceptions
12526    gets pushed.  */
12527
12528 static void
12529 ada_add_global_exceptions (compiled_regex *preg,
12530                            std::vector<ada_exc_info> *exceptions)
12531 {
12532   /* In Ada, the symbol "search name" is a linkage name, whereas the
12533      regular expression used to do the matching refers to the natural
12534      name.  So match against the decoded name.  */
12535   expand_symtabs_matching (NULL,
12536                            lookup_name_info::match_any (),
12537                            [&] (const char *search_name)
12538                            {
12539                              std::string decoded = ada_decode (search_name);
12540                              return name_matches_regex (decoded.c_str (), preg);
12541                            },
12542                            NULL,
12543                            VARIABLES_DOMAIN);
12544
12545   for (objfile *objfile : current_program_space->objfiles ())
12546     {
12547       for (compunit_symtab *s : objfile->compunits ())
12548         {
12549           const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
12550           int i;
12551
12552           for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
12553             {
12554               const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
12555               struct block_iterator iter;
12556               struct symbol *sym;
12557
12558               ALL_BLOCK_SYMBOLS (b, iter, sym)
12559                 if (ada_is_non_standard_exception_sym (sym)
12560                     && name_matches_regex (sym->natural_name (), preg))
12561                   {
12562                     struct ada_exc_info info
12563                       = {sym->print_name (), SYMBOL_VALUE_ADDRESS (sym)};
12564
12565                     exceptions->push_back (info);
12566                   }
12567             }
12568         }
12569     }
12570 }
12571
12572 /* Implements ada_exceptions_list with the regular expression passed
12573    as a regex_t, rather than a string.
12574
12575    If not NULL, PREG is used to filter out exceptions whose names
12576    do not match.  Otherwise, all exceptions are listed.  */
12577
12578 static std::vector<ada_exc_info>
12579 ada_exceptions_list_1 (compiled_regex *preg)
12580 {
12581   std::vector<ada_exc_info> result;
12582   int prev_len;
12583
12584   /* First, list the known standard exceptions.  These exceptions
12585      need to be handled separately, as they are usually defined in
12586      runtime units that have been compiled without debugging info.  */
12587
12588   ada_add_standard_exceptions (preg, &result);
12589
12590   /* Next, find all exceptions whose scope is local and accessible
12591      from the currently selected frame.  */
12592
12593   if (has_stack_frames ())
12594     {
12595       prev_len = result.size ();
12596       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
12597                                      &result);
12598       if (result.size () > prev_len)
12599         sort_remove_dups_ada_exceptions_list (&result, prev_len);
12600     }
12601
12602   /* Add all exceptions whose scope is global.  */
12603
12604   prev_len = result.size ();
12605   ada_add_global_exceptions (preg, &result);
12606   if (result.size () > prev_len)
12607     sort_remove_dups_ada_exceptions_list (&result, prev_len);
12608
12609   return result;
12610 }
12611
12612 /* Return a vector of ada_exc_info.
12613
12614    If REGEXP is NULL, all exceptions are included in the result.
12615    Otherwise, it should contain a valid regular expression,
12616    and only the exceptions whose names match that regular expression
12617    are included in the result.
12618
12619    The exceptions are sorted in the following order:
12620      - Standard exceptions (defined by the Ada language), in
12621        alphabetical order;
12622      - Exceptions only visible from the current frame, in
12623        alphabetical order;
12624      - Exceptions whose scope is global, in alphabetical order.  */
12625
12626 std::vector<ada_exc_info>
12627 ada_exceptions_list (const char *regexp)
12628 {
12629   if (regexp == NULL)
12630     return ada_exceptions_list_1 (NULL);
12631
12632   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
12633   return ada_exceptions_list_1 (&reg);
12634 }
12635
12636 /* Implement the "info exceptions" command.  */
12637
12638 static void
12639 info_exceptions_command (const char *regexp, int from_tty)
12640 {
12641   struct gdbarch *gdbarch = get_current_arch ();
12642
12643   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
12644
12645   if (regexp != NULL)
12646     printf_filtered
12647       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
12648   else
12649     printf_filtered (_("All defined Ada exceptions:\n"));
12650
12651   for (const ada_exc_info &info : exceptions)
12652     printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
12653 }
12654
12655 \f
12656                                 /* Language vector */
12657
12658 /* symbol_name_matcher_ftype adapter for wild_match.  */
12659
12660 static bool
12661 do_wild_match (const char *symbol_search_name,
12662                const lookup_name_info &lookup_name,
12663                completion_match_result *comp_match_res)
12664 {
12665   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
12666 }
12667
12668 /* symbol_name_matcher_ftype adapter for full_match.  */
12669
12670 static bool
12671 do_full_match (const char *symbol_search_name,
12672                const lookup_name_info &lookup_name,
12673                completion_match_result *comp_match_res)
12674 {
12675   const char *lname = lookup_name.ada ().lookup_name ().c_str ();
12676
12677   /* If both symbols start with "_ada_", just let the loop below
12678      handle the comparison.  However, if only the symbol name starts
12679      with "_ada_", skip the prefix and let the match proceed as
12680      usual.  */
12681   if (startswith (symbol_search_name, "_ada_")
12682       && !startswith (lname, "_ada"))
12683     symbol_search_name += 5;
12684
12685   int uscore_count = 0;
12686   while (*lname != '\0')
12687     {
12688       if (*symbol_search_name != *lname)
12689         {
12690           if (*symbol_search_name == 'B' && uscore_count == 2
12691               && symbol_search_name[1] == '_')
12692             {
12693               symbol_search_name += 2;
12694               while (isdigit (*symbol_search_name))
12695                 ++symbol_search_name;
12696               if (symbol_search_name[0] == '_'
12697                   && symbol_search_name[1] == '_')
12698                 {
12699                   symbol_search_name += 2;
12700                   continue;
12701                 }
12702             }
12703           return false;
12704         }
12705
12706       if (*symbol_search_name == '_')
12707         ++uscore_count;
12708       else
12709         uscore_count = 0;
12710
12711       ++symbol_search_name;
12712       ++lname;
12713     }
12714
12715   return is_name_suffix (symbol_search_name);
12716 }
12717
12718 /* symbol_name_matcher_ftype for exact (verbatim) matches.  */
12719
12720 static bool
12721 do_exact_match (const char *symbol_search_name,
12722                 const lookup_name_info &lookup_name,
12723                 completion_match_result *comp_match_res)
12724 {
12725   return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
12726 }
12727
12728 /* Build the Ada lookup name for LOOKUP_NAME.  */
12729
12730 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
12731 {
12732   gdb::string_view user_name = lookup_name.name ();
12733
12734   if (!user_name.empty () && user_name[0] == '<')
12735     {
12736       if (user_name.back () == '>')
12737         m_encoded_name
12738           = gdb::to_string (user_name.substr (1, user_name.size () - 2));
12739       else
12740         m_encoded_name
12741           = gdb::to_string (user_name.substr (1, user_name.size () - 1));
12742       m_encoded_p = true;
12743       m_verbatim_p = true;
12744       m_wild_match_p = false;
12745       m_standard_p = false;
12746     }
12747   else
12748     {
12749       m_verbatim_p = false;
12750
12751       m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
12752
12753       if (!m_encoded_p)
12754         {
12755           const char *folded = ada_fold_name (user_name);
12756           m_encoded_name = ada_encode_1 (folded, false);
12757           if (m_encoded_name.empty ())
12758             m_encoded_name = gdb::to_string (user_name);
12759         }
12760       else
12761         m_encoded_name = gdb::to_string (user_name);
12762
12763       /* Handle the 'package Standard' special case.  See description
12764          of m_standard_p.  */
12765       if (startswith (m_encoded_name.c_str (), "standard__"))
12766         {
12767           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
12768           m_standard_p = true;
12769         }
12770       else
12771         m_standard_p = false;
12772
12773       /* If the name contains a ".", then the user is entering a fully
12774          qualified entity name, and the match must not be done in wild
12775          mode.  Similarly, if the user wants to complete what looks
12776          like an encoded name, the match must not be done in wild
12777          mode.  Also, in the standard__ special case always do
12778          non-wild matching.  */
12779       m_wild_match_p
12780         = (lookup_name.match_type () != symbol_name_match_type::FULL
12781            && !m_encoded_p
12782            && !m_standard_p
12783            && user_name.find ('.') == std::string::npos);
12784     }
12785 }
12786
12787 /* symbol_name_matcher_ftype method for Ada.  This only handles
12788    completion mode.  */
12789
12790 static bool
12791 ada_symbol_name_matches (const char *symbol_search_name,
12792                          const lookup_name_info &lookup_name,
12793                          completion_match_result *comp_match_res)
12794 {
12795   return lookup_name.ada ().matches (symbol_search_name,
12796                                      lookup_name.match_type (),
12797                                      comp_match_res);
12798 }
12799
12800 /* A name matcher that matches the symbol name exactly, with
12801    strcmp.  */
12802
12803 static bool
12804 literal_symbol_name_matcher (const char *symbol_search_name,
12805                              const lookup_name_info &lookup_name,
12806                              completion_match_result *comp_match_res)
12807 {
12808   gdb::string_view name_view = lookup_name.name ();
12809
12810   if (lookup_name.completion_mode ()
12811       ? (strncmp (symbol_search_name, name_view.data (),
12812                   name_view.size ()) == 0)
12813       : symbol_search_name == name_view)
12814     {
12815       if (comp_match_res != NULL)
12816         comp_match_res->set_match (symbol_search_name);
12817       return true;
12818     }
12819   else
12820     return false;
12821 }
12822
12823 /* Implement the "get_symbol_name_matcher" language_defn method for
12824    Ada.  */
12825
12826 static symbol_name_matcher_ftype *
12827 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
12828 {
12829   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
12830     return literal_symbol_name_matcher;
12831
12832   if (lookup_name.completion_mode ())
12833     return ada_symbol_name_matches;
12834   else
12835     {
12836       if (lookup_name.ada ().wild_match_p ())
12837         return do_wild_match;
12838       else if (lookup_name.ada ().verbatim_p ())
12839         return do_exact_match;
12840       else
12841         return do_full_match;
12842     }
12843 }
12844
12845 /* Class representing the Ada language.  */
12846
12847 class ada_language : public language_defn
12848 {
12849 public:
12850   ada_language ()
12851     : language_defn (language_ada)
12852   { /* Nothing.  */ }
12853
12854   /* See language.h.  */
12855
12856   const char *name () const override
12857   { return "ada"; }
12858
12859   /* See language.h.  */
12860
12861   const char *natural_name () const override
12862   { return "Ada"; }
12863
12864   /* See language.h.  */
12865
12866   const std::vector<const char *> &filename_extensions () const override
12867   {
12868     static const std::vector<const char *> extensions
12869       = { ".adb", ".ads", ".a", ".ada", ".dg" };
12870     return extensions;
12871   }
12872
12873   /* Print an array element index using the Ada syntax.  */
12874
12875   void print_array_index (struct type *index_type,
12876                           LONGEST index,
12877                           struct ui_file *stream,
12878                           const value_print_options *options) const override
12879   {
12880     struct value *index_value = val_atr (index_type, index);
12881
12882     value_print (index_value, stream, options);
12883     fprintf_filtered (stream, " => ");
12884   }
12885
12886   /* Implement the "read_var_value" language_defn method for Ada.  */
12887
12888   struct value *read_var_value (struct symbol *var,
12889                                 const struct block *var_block,
12890                                 struct frame_info *frame) const override
12891   {
12892     /* The only case where default_read_var_value is not sufficient
12893        is when VAR is a renaming...  */
12894     if (frame != nullptr)
12895       {
12896         const struct block *frame_block = get_frame_block (frame, NULL);
12897         if (frame_block != nullptr && ada_is_renaming_symbol (var))
12898           return ada_read_renaming_var_value (var, frame_block);
12899       }
12900
12901     /* This is a typical case where we expect the default_read_var_value
12902        function to work.  */
12903     return language_defn::read_var_value (var, var_block, frame);
12904   }
12905
12906   /* See language.h.  */
12907   void language_arch_info (struct gdbarch *gdbarch,
12908                            struct language_arch_info *lai) const override
12909   {
12910     const struct builtin_type *builtin = builtin_type (gdbarch);
12911
12912     /* Helper function to allow shorter lines below.  */
12913     auto add = [&] (struct type *t)
12914     {
12915       lai->add_primitive_type (t);
12916     };
12917
12918     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12919                             0, "integer"));
12920     add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
12921                             0, "long_integer"));
12922     add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
12923                             0, "short_integer"));
12924     struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
12925                                                   0, "character");
12926     lai->set_string_char_type (char_type);
12927     add (char_type);
12928     add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
12929                           "float", gdbarch_float_format (gdbarch)));
12930     add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
12931                           "long_float", gdbarch_double_format (gdbarch)));
12932     add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
12933                             0, "long_long_integer"));
12934     add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
12935                           "long_long_float",
12936                           gdbarch_long_double_format (gdbarch)));
12937     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12938                             0, "natural"));
12939     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12940                             0, "positive"));
12941     add (builtin->builtin_void);
12942
12943     struct type *system_addr_ptr
12944       = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
12945                                         "void"));
12946     system_addr_ptr->set_name ("system__address");
12947     add (system_addr_ptr);
12948
12949     /* Create the equivalent of the System.Storage_Elements.Storage_Offset
12950        type.  This is a signed integral type whose size is the same as
12951        the size of addresses.  */
12952     unsigned int addr_length = TYPE_LENGTH (system_addr_ptr);
12953     add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
12954                             "storage_offset"));
12955
12956     lai->set_bool_type (builtin->builtin_bool);
12957   }
12958
12959   /* See language.h.  */
12960
12961   bool iterate_over_symbols
12962         (const struct block *block, const lookup_name_info &name,
12963          domain_enum domain,
12964          gdb::function_view<symbol_found_callback_ftype> callback) const override
12965   {
12966     std::vector<struct block_symbol> results
12967       = ada_lookup_symbol_list_worker (name, block, domain, 0);
12968     for (block_symbol &sym : results)
12969       {
12970         if (!callback (&sym))
12971           return false;
12972       }
12973
12974     return true;
12975   }
12976
12977   /* See language.h.  */
12978   bool sniff_from_mangled_name (const char *mangled,
12979                                 char **out) const override
12980   {
12981     std::string demangled = ada_decode (mangled);
12982
12983     *out = NULL;
12984
12985     if (demangled != mangled && demangled[0] != '<')
12986       {
12987         /* Set the gsymbol language to Ada, but still return 0.
12988            Two reasons for that:
12989
12990            1. For Ada, we prefer computing the symbol's decoded name
12991            on the fly rather than pre-compute it, in order to save
12992            memory (Ada projects are typically very large).
12993
12994            2. There are some areas in the definition of the GNAT
12995            encoding where, with a bit of bad luck, we might be able
12996            to decode a non-Ada symbol, generating an incorrect
12997            demangled name (Eg: names ending with "TB" for instance
12998            are identified as task bodies and so stripped from
12999            the decoded name returned).
13000
13001            Returning true, here, but not setting *DEMANGLED, helps us get
13002            a little bit of the best of both worlds.  Because we're last,
13003            we should not affect any of the other languages that were
13004            able to demangle the symbol before us; we get to correctly
13005            tag Ada symbols as such; and even if we incorrectly tagged a
13006            non-Ada symbol, which should be rare, any routing through the
13007            Ada language should be transparent (Ada tries to behave much
13008            like C/C++ with non-Ada symbols).  */
13009         return true;
13010       }
13011
13012     return false;
13013   }
13014
13015   /* See language.h.  */
13016
13017   char *demangle_symbol (const char *mangled, int options) const override
13018   {
13019     return ada_la_decode (mangled, options);
13020   }
13021
13022   /* See language.h.  */
13023
13024   void print_type (struct type *type, const char *varstring,
13025                    struct ui_file *stream, int show, int level,
13026                    const struct type_print_options *flags) const override
13027   {
13028     ada_print_type (type, varstring, stream, show, level, flags);
13029   }
13030
13031   /* See language.h.  */
13032
13033   const char *word_break_characters (void) const override
13034   {
13035     return ada_completer_word_break_characters;
13036   }
13037
13038   /* See language.h.  */
13039
13040   void collect_symbol_completion_matches (completion_tracker &tracker,
13041                                           complete_symbol_mode mode,
13042                                           symbol_name_match_type name_match_type,
13043                                           const char *text, const char *word,
13044                                           enum type_code code) const override
13045   {
13046     struct symbol *sym;
13047     const struct block *b, *surrounding_static_block = 0;
13048     struct block_iterator iter;
13049
13050     gdb_assert (code == TYPE_CODE_UNDEF);
13051
13052     lookup_name_info lookup_name (text, name_match_type, true);
13053
13054     /* First, look at the partial symtab symbols.  */
13055     expand_symtabs_matching (NULL,
13056                              lookup_name,
13057                              NULL,
13058                              NULL,
13059                              ALL_DOMAIN);
13060
13061     /* At this point scan through the misc symbol vectors and add each
13062        symbol you find to the list.  Eventually we want to ignore
13063        anything that isn't a text symbol (everything else will be
13064        handled by the psymtab code above).  */
13065
13066     for (objfile *objfile : current_program_space->objfiles ())
13067       {
13068         for (minimal_symbol *msymbol : objfile->msymbols ())
13069           {
13070             QUIT;
13071
13072             if (completion_skip_symbol (mode, msymbol))
13073               continue;
13074
13075             language symbol_language = msymbol->language ();
13076
13077             /* Ada minimal symbols won't have their language set to Ada.  If
13078                we let completion_list_add_name compare using the
13079                default/C-like matcher, then when completing e.g., symbols in a
13080                package named "pck", we'd match internal Ada symbols like
13081                "pckS", which are invalid in an Ada expression, unless you wrap
13082                them in '<' '>' to request a verbatim match.
13083
13084                Unfortunately, some Ada encoded names successfully demangle as
13085                C++ symbols (using an old mangling scheme), such as "name__2Xn"
13086                -> "Xn::name(void)" and thus some Ada minimal symbols end up
13087                with the wrong language set.  Paper over that issue here.  */
13088             if (symbol_language == language_auto
13089                 || symbol_language == language_cplus)
13090               symbol_language = language_ada;
13091
13092             completion_list_add_name (tracker,
13093                                       symbol_language,
13094                                       msymbol->linkage_name (),
13095                                       lookup_name, text, word);
13096           }
13097       }
13098
13099     /* Search upwards from currently selected frame (so that we can
13100        complete on local vars.  */
13101
13102     for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
13103       {
13104         if (!BLOCK_SUPERBLOCK (b))
13105           surrounding_static_block = b;   /* For elmin of dups */
13106
13107         ALL_BLOCK_SYMBOLS (b, iter, sym)
13108           {
13109             if (completion_skip_symbol (mode, sym))
13110               continue;
13111
13112             completion_list_add_name (tracker,
13113                                       sym->language (),
13114                                       sym->linkage_name (),
13115                                       lookup_name, text, word);
13116           }
13117       }
13118
13119     /* Go through the symtabs and check the externs and statics for
13120        symbols which match.  */
13121
13122     for (objfile *objfile : current_program_space->objfiles ())
13123       {
13124         for (compunit_symtab *s : objfile->compunits ())
13125           {
13126             QUIT;
13127             b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
13128             ALL_BLOCK_SYMBOLS (b, iter, sym)
13129               {
13130                 if (completion_skip_symbol (mode, sym))
13131                   continue;
13132
13133                 completion_list_add_name (tracker,
13134                                           sym->language (),
13135                                           sym->linkage_name (),
13136                                           lookup_name, text, word);
13137               }
13138           }
13139       }
13140
13141     for (objfile *objfile : current_program_space->objfiles ())
13142       {
13143         for (compunit_symtab *s : objfile->compunits ())
13144           {
13145             QUIT;
13146             b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
13147             /* Don't do this block twice.  */
13148             if (b == surrounding_static_block)
13149               continue;
13150             ALL_BLOCK_SYMBOLS (b, iter, sym)
13151               {
13152                 if (completion_skip_symbol (mode, sym))
13153                   continue;
13154
13155                 completion_list_add_name (tracker,
13156                                           sym->language (),
13157                                           sym->linkage_name (),
13158                                           lookup_name, text, word);
13159               }
13160           }
13161       }
13162   }
13163
13164   /* See language.h.  */
13165
13166   gdb::unique_xmalloc_ptr<char> watch_location_expression
13167         (struct type *type, CORE_ADDR addr) const override
13168   {
13169     type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
13170     std::string name = type_to_string (type);
13171     return gdb::unique_xmalloc_ptr<char>
13172       (xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr)));
13173   }
13174
13175   /* See language.h.  */
13176
13177   void value_print (struct value *val, struct ui_file *stream,
13178                     const struct value_print_options *options) const override
13179   {
13180     return ada_value_print (val, stream, options);
13181   }
13182
13183   /* See language.h.  */
13184
13185   void value_print_inner
13186         (struct value *val, struct ui_file *stream, int recurse,
13187          const struct value_print_options *options) const override
13188   {
13189     return ada_value_print_inner (val, stream, recurse, options);
13190   }
13191
13192   /* See language.h.  */
13193
13194   struct block_symbol lookup_symbol_nonlocal
13195         (const char *name, const struct block *block,
13196          const domain_enum domain) const override
13197   {
13198     struct block_symbol sym;
13199
13200     sym = ada_lookup_symbol (name, block_static_block (block), domain);
13201     if (sym.symbol != NULL)
13202       return sym;
13203
13204     /* If we haven't found a match at this point, try the primitive
13205        types.  In other languages, this search is performed before
13206        searching for global symbols in order to short-circuit that
13207        global-symbol search if it happens that the name corresponds
13208        to a primitive type.  But we cannot do the same in Ada, because
13209        it is perfectly legitimate for a program to declare a type which
13210        has the same name as a standard type.  If looking up a type in
13211        that situation, we have traditionally ignored the primitive type
13212        in favor of user-defined types.  This is why, unlike most other
13213        languages, we search the primitive types this late and only after
13214        having searched the global symbols without success.  */
13215
13216     if (domain == VAR_DOMAIN)
13217       {
13218         struct gdbarch *gdbarch;
13219
13220         if (block == NULL)
13221           gdbarch = target_gdbarch ();
13222         else
13223           gdbarch = block_gdbarch (block);
13224         sym.symbol
13225           = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13226         if (sym.symbol != NULL)
13227           return sym;
13228       }
13229
13230     return {};
13231   }
13232
13233   /* See language.h.  */
13234
13235   int parser (struct parser_state *ps) const override
13236   {
13237     warnings_issued = 0;
13238     return ada_parse (ps);
13239   }
13240
13241   /* See language.h.  */
13242
13243   void emitchar (int ch, struct type *chtype,
13244                  struct ui_file *stream, int quoter) const override
13245   {
13246     ada_emit_char (ch, chtype, stream, quoter, 1);
13247   }
13248
13249   /* See language.h.  */
13250
13251   void printchar (int ch, struct type *chtype,
13252                   struct ui_file *stream) const override
13253   {
13254     ada_printchar (ch, chtype, stream);
13255   }
13256
13257   /* See language.h.  */
13258
13259   void printstr (struct ui_file *stream, struct type *elttype,
13260                  const gdb_byte *string, unsigned int length,
13261                  const char *encoding, int force_ellipses,
13262                  const struct value_print_options *options) const override
13263   {
13264     ada_printstr (stream, elttype, string, length, encoding,
13265                   force_ellipses, options);
13266   }
13267
13268   /* See language.h.  */
13269
13270   void print_typedef (struct type *type, struct symbol *new_symbol,
13271                       struct ui_file *stream) const override
13272   {
13273     ada_print_typedef (type, new_symbol, stream);
13274   }
13275
13276   /* See language.h.  */
13277
13278   bool is_string_type_p (struct type *type) const override
13279   {
13280     return ada_is_string_type (type);
13281   }
13282
13283   /* See language.h.  */
13284
13285   const char *struct_too_deep_ellipsis () const override
13286   { return "(...)"; }
13287
13288   /* See language.h.  */
13289
13290   bool c_style_arrays_p () const override
13291   { return false; }
13292
13293   /* See language.h.  */
13294
13295   bool store_sym_names_in_linkage_form_p () const override
13296   { return true; }
13297
13298   /* See language.h.  */
13299
13300   const struct lang_varobj_ops *varobj_ops () const override
13301   { return &ada_varobj_ops; }
13302
13303 protected:
13304   /* See language.h.  */
13305
13306   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13307         (const lookup_name_info &lookup_name) const override
13308   {
13309     return ada_get_symbol_name_matcher (lookup_name);
13310   }
13311 };
13312
13313 /* Single instance of the Ada language class.  */
13314
13315 static ada_language ada_language_defn;
13316
13317 /* Command-list for the "set/show ada" prefix command.  */
13318 static struct cmd_list_element *set_ada_list;
13319 static struct cmd_list_element *show_ada_list;
13320
13321 static void
13322 initialize_ada_catchpoint_ops (void)
13323 {
13324   struct breakpoint_ops *ops;
13325
13326   initialize_breakpoint_ops ();
13327
13328   ops = &catch_exception_breakpoint_ops;
13329   *ops = bkpt_breakpoint_ops;
13330   ops->allocate_location = allocate_location_exception;
13331   ops->re_set = re_set_exception;
13332   ops->check_status = check_status_exception;
13333   ops->print_it = print_it_exception;
13334   ops->print_one = print_one_exception;
13335   ops->print_mention = print_mention_exception;
13336   ops->print_recreate = print_recreate_exception;
13337
13338   ops = &catch_exception_unhandled_breakpoint_ops;
13339   *ops = bkpt_breakpoint_ops;
13340   ops->allocate_location = allocate_location_exception;
13341   ops->re_set = re_set_exception;
13342   ops->check_status = check_status_exception;
13343   ops->print_it = print_it_exception;
13344   ops->print_one = print_one_exception;
13345   ops->print_mention = print_mention_exception;
13346   ops->print_recreate = print_recreate_exception;
13347
13348   ops = &catch_assert_breakpoint_ops;
13349   *ops = bkpt_breakpoint_ops;
13350   ops->allocate_location = allocate_location_exception;
13351   ops->re_set = re_set_exception;
13352   ops->check_status = check_status_exception;
13353   ops->print_it = print_it_exception;
13354   ops->print_one = print_one_exception;
13355   ops->print_mention = print_mention_exception;
13356   ops->print_recreate = print_recreate_exception;
13357
13358   ops = &catch_handlers_breakpoint_ops;
13359   *ops = bkpt_breakpoint_ops;
13360   ops->allocate_location = allocate_location_exception;
13361   ops->re_set = re_set_exception;
13362   ops->check_status = check_status_exception;
13363   ops->print_it = print_it_exception;
13364   ops->print_one = print_one_exception;
13365   ops->print_mention = print_mention_exception;
13366   ops->print_recreate = print_recreate_exception;
13367 }
13368
13369 /* This module's 'new_objfile' observer.  */
13370
13371 static void
13372 ada_new_objfile_observer (struct objfile *objfile)
13373 {
13374   ada_clear_symbol_cache ();
13375 }
13376
13377 /* This module's 'free_objfile' observer.  */
13378
13379 static void
13380 ada_free_objfile_observer (struct objfile *objfile)
13381 {
13382   ada_clear_symbol_cache ();
13383 }
13384
13385 void _initialize_ada_language ();
13386 void
13387 _initialize_ada_language ()
13388 {
13389   initialize_ada_catchpoint_ops ();
13390
13391   add_basic_prefix_cmd ("ada", no_class,
13392                         _("Prefix command for changing Ada-specific settings."),
13393                         &set_ada_list, "set ada ", 0, &setlist);
13394
13395   add_show_prefix_cmd ("ada", no_class,
13396                        _("Generic command for showing Ada-specific settings."),
13397                        &show_ada_list, "show ada ", 0, &showlist);
13398
13399   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13400                            &trust_pad_over_xvs, _("\
13401 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13402 Show whether an optimization trusting PAD types over XVS types is activated."),
13403                            _("\
13404 This is related to the encoding used by the GNAT compiler.  The debugger\n\
13405 should normally trust the contents of PAD types, but certain older versions\n\
13406 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13407 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
13408 work around this bug.  It is always safe to turn this option \"off\", but\n\
13409 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13410 this option to \"off\" unless necessary."),
13411                             NULL, NULL, &set_ada_list, &show_ada_list);
13412
13413   add_setshow_boolean_cmd ("print-signatures", class_vars,
13414                            &print_signatures, _("\
13415 Enable or disable the output of formal and return types for functions in the \
13416 overloads selection menu."), _("\
13417 Show whether the output of formal and return types for functions in the \
13418 overloads selection menu is activated."),
13419                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
13420
13421   add_catch_command ("exception", _("\
13422 Catch Ada exceptions, when raised.\n\
13423 Usage: catch exception [ARG] [if CONDITION]\n\
13424 Without any argument, stop when any Ada exception is raised.\n\
13425 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
13426 being raised does not have a handler (and will therefore lead to the task's\n\
13427 termination).\n\
13428 Otherwise, the catchpoint only stops when the name of the exception being\n\
13429 raised is the same as ARG.\n\
13430 CONDITION is a boolean expression that is evaluated to see whether the\n\
13431 exception should cause a stop."),
13432                      catch_ada_exception_command,
13433                      catch_ada_completer,
13434                      CATCH_PERMANENT,
13435                      CATCH_TEMPORARY);
13436
13437   add_catch_command ("handlers", _("\
13438 Catch Ada exceptions, when handled.\n\
13439 Usage: catch handlers [ARG] [if CONDITION]\n\
13440 Without any argument, stop when any Ada exception is handled.\n\
13441 With an argument, catch only exceptions with the given name.\n\
13442 CONDITION is a boolean expression that is evaluated to see whether the\n\
13443 exception should cause a stop."),
13444                      catch_ada_handlers_command,
13445                      catch_ada_completer,
13446                      CATCH_PERMANENT,
13447                      CATCH_TEMPORARY);
13448   add_catch_command ("assert", _("\
13449 Catch failed Ada assertions, when raised.\n\
13450 Usage: catch assert [if CONDITION]\n\
13451 CONDITION is a boolean expression that is evaluated to see whether the\n\
13452 exception should cause a stop."),
13453                      catch_assert_command,
13454                      NULL,
13455                      CATCH_PERMANENT,
13456                      CATCH_TEMPORARY);
13457
13458   varsize_limit = 65536;
13459   add_setshow_uinteger_cmd ("varsize-limit", class_support,
13460                             &varsize_limit, _("\
13461 Set the maximum number of bytes allowed in a variable-size object."), _("\
13462 Show the maximum number of bytes allowed in a variable-size object."), _("\
13463 Attempts to access an object whose size is not a compile-time constant\n\
13464 and exceeds this limit will cause an error."),
13465                             NULL, NULL, &setlist, &showlist);
13466
13467   add_info ("exceptions", info_exceptions_command,
13468             _("\
13469 List all Ada exception names.\n\
13470 Usage: info exceptions [REGEXP]\n\
13471 If a regular expression is passed as an argument, only those matching\n\
13472 the regular expression are listed."));
13473
13474   add_basic_prefix_cmd ("ada", class_maintenance,
13475                         _("Set Ada maintenance-related variables."),
13476                         &maint_set_ada_cmdlist, "maintenance set ada ",
13477                         0/*allow-unknown*/, &maintenance_set_cmdlist);
13478
13479   add_show_prefix_cmd ("ada", class_maintenance,
13480                        _("Show Ada maintenance-related variables."),
13481                        &maint_show_ada_cmdlist, "maintenance show ada ",
13482                        0/*allow-unknown*/, &maintenance_show_cmdlist);
13483
13484   add_setshow_boolean_cmd
13485     ("ignore-descriptive-types", class_maintenance,
13486      &ada_ignore_descriptive_types_p,
13487      _("Set whether descriptive types generated by GNAT should be ignored."),
13488      _("Show whether descriptive types generated by GNAT should be ignored."),
13489      _("\
13490 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13491 DWARF attribute."),
13492      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
13493
13494   decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
13495                                            NULL, xcalloc, xfree);
13496
13497   /* The ada-lang observers.  */
13498   gdb::observers::new_objfile.attach (ada_new_objfile_observer);
13499   gdb::observers::free_objfile.attach (ada_free_objfile_observer);
13500   gdb::observers::inferior_exit.attach (ada_inferior_exit);
13501 }
This page took 0.791745 seconds and 4 git commands to generate.