]> Git Repo - binutils.git/blob - gdb/ada-lang.c
Fix Ada overloading with 'null'
[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_args_match (struct symbol *, struct value **, int);
99
100 static struct value *make_array_descriptor (struct type *, struct value *);
101
102 static void ada_add_block_symbols (std::vector<struct block_symbol> &,
103                                    const struct block *,
104                                    const lookup_name_info &lookup_name,
105                                    domain_enum, struct objfile *);
106
107 static void ada_add_all_symbols (std::vector<struct block_symbol> &,
108                                  const struct block *,
109                                  const lookup_name_info &lookup_name,
110                                  domain_enum, int, int *);
111
112 static int is_nonfunction (const std::vector<struct block_symbol> &);
113
114 static void add_defn_to_vec (std::vector<struct block_symbol> &,
115                              struct symbol *,
116                              const struct block *);
117
118 static int possible_user_operator_p (enum exp_opcode, struct value **);
119
120 static const char *ada_decoded_op_name (enum exp_opcode);
121
122 static int numeric_type_p (struct type *);
123
124 static int integer_type_p (struct type *);
125
126 static int scalar_type_p (struct type *);
127
128 static int discrete_type_p (struct type *);
129
130 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
131                                                 int, int);
132
133 static struct type *ada_find_parallel_type_with_name (struct type *,
134                                                       const char *);
135
136 static int is_dynamic_field (struct type *, int);
137
138 static struct type *to_fixed_variant_branch_type (struct type *,
139                                                   const gdb_byte *,
140                                                   CORE_ADDR, struct value *);
141
142 static struct type *to_fixed_array_type (struct type *, struct value *, int);
143
144 static struct type *to_fixed_range_type (struct type *, struct value *);
145
146 static struct type *to_static_fixed_type (struct type *);
147 static struct type *static_unwrap_type (struct type *type);
148
149 static struct value *unwrap_value (struct value *);
150
151 static struct type *constrained_packed_array_type (struct type *, long *);
152
153 static struct type *decode_constrained_packed_array_type (struct type *);
154
155 static long decode_packed_array_bitsize (struct type *);
156
157 static struct value *decode_constrained_packed_array (struct value *);
158
159 static int ada_is_unconstrained_packed_array_type (struct type *);
160
161 static struct value *value_subscript_packed (struct value *, int,
162                                              struct value **);
163
164 static struct value *coerce_unspec_val_to_type (struct value *,
165                                                 struct type *);
166
167 static int lesseq_defined_than (struct symbol *, struct symbol *);
168
169 static int equiv_types (struct type *, struct type *);
170
171 static int is_name_suffix (const char *);
172
173 static int advance_wild_match (const char **, const char *, char);
174
175 static bool wild_match (const char *name, const char *patn);
176
177 static struct value *ada_coerce_ref (struct value *);
178
179 static LONGEST pos_atr (struct value *);
180
181 static struct value *val_atr (struct type *, LONGEST);
182
183 static struct symbol *standard_lookup (const char *, const struct block *,
184                                        domain_enum);
185
186 static struct value *ada_search_struct_field (const char *, struct value *, int,
187                                               struct type *);
188
189 static int find_struct_field (const char *, struct type *, int,
190                               struct type **, int *, int *, int *, int *);
191
192 static int ada_resolve_function (std::vector<struct block_symbol> &,
193                                  struct value **, int, const char *,
194                                  struct type *, bool);
195
196 static int ada_is_direct_array_type (struct type *);
197
198 static struct value *ada_index_struct_field (int, struct value *, int,
199                                              struct type *);
200
201 static void add_component_interval (LONGEST, LONGEST, std::vector<LONGEST> &);
202
203
204 static struct type *ada_find_any_type (const char *name);
205
206 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
207   (const lookup_name_info &lookup_name);
208
209 \f
210
211 /* The result of a symbol lookup to be stored in our symbol cache.  */
212
213 struct cache_entry
214 {
215   /* The name used to perform the lookup.  */
216   const char *name;
217   /* The namespace used during the lookup.  */
218   domain_enum domain;
219   /* The symbol returned by the lookup, or NULL if no matching symbol
220      was found.  */
221   struct symbol *sym;
222   /* The block where the symbol was found, or NULL if no matching
223      symbol was found.  */
224   const struct block *block;
225   /* A pointer to the next entry with the same hash.  */
226   struct cache_entry *next;
227 };
228
229 /* The Ada symbol cache, used to store the result of Ada-mode symbol
230    lookups in the course of executing the user's commands.
231
232    The cache is implemented using a simple, fixed-sized hash.
233    The size is fixed on the grounds that there are not likely to be
234    all that many symbols looked up during any given session, regardless
235    of the size of the symbol table.  If we decide to go to a resizable
236    table, let's just use the stuff from libiberty instead.  */
237
238 #define HASH_SIZE 1009
239
240 struct ada_symbol_cache
241 {
242   /* An obstack used to store the entries in our cache.  */
243   struct auto_obstack cache_space;
244
245   /* The root of the hash table used to implement our symbol cache.  */
246   struct cache_entry *root[HASH_SIZE] {};
247 };
248
249 /* Maximum-sized dynamic type.  */
250 static unsigned int varsize_limit;
251
252 static const char ada_completer_word_break_characters[] =
253 #ifdef VMS
254   " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
255 #else
256   " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
257 #endif
258
259 /* The name of the symbol to use to get the name of the main subprogram.  */
260 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
261   = "__gnat_ada_main_program_name";
262
263 /* Limit on the number of warnings to raise per expression evaluation.  */
264 static int warning_limit = 2;
265
266 /* Number of warning messages issued; reset to 0 by cleanups after
267    expression evaluation.  */
268 static int warnings_issued = 0;
269
270 static const char * const known_runtime_file_name_patterns[] = {
271   ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
272 };
273
274 static const char * const known_auxiliary_function_name_patterns[] = {
275   ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
276 };
277
278 /* Maintenance-related settings for this module.  */
279
280 static struct cmd_list_element *maint_set_ada_cmdlist;
281 static struct cmd_list_element *maint_show_ada_cmdlist;
282
283 /* The "maintenance ada set/show ignore-descriptive-type" value.  */
284
285 static bool ada_ignore_descriptive_types_p = false;
286
287                         /* Inferior-specific data.  */
288
289 /* Per-inferior data for this module.  */
290
291 struct ada_inferior_data
292 {
293   /* The ada__tags__type_specific_data type, which is used when decoding
294      tagged types.  With older versions of GNAT, this type was directly
295      accessible through a component ("tsd") in the object tag.  But this
296      is no longer the case, so we cache it for each inferior.  */
297   struct type *tsd_type = nullptr;
298
299   /* The exception_support_info data.  This data is used to determine
300      how to implement support for Ada exception catchpoints in a given
301      inferior.  */
302   const struct exception_support_info *exception_info = nullptr;
303 };
304
305 /* Our key to this module's inferior data.  */
306 static const struct inferior_key<ada_inferior_data> ada_inferior_data;
307
308 /* Return our inferior data for the given inferior (INF).
309
310    This function always returns a valid pointer to an allocated
311    ada_inferior_data structure.  If INF's inferior data has not
312    been previously set, this functions creates a new one with all
313    fields set to zero, sets INF's inferior to it, and then returns
314    a pointer to that newly allocated ada_inferior_data.  */
315
316 static struct ada_inferior_data *
317 get_ada_inferior_data (struct inferior *inf)
318 {
319   struct ada_inferior_data *data;
320
321   data = ada_inferior_data.get (inf);
322   if (data == NULL)
323     data = ada_inferior_data.emplace (inf);
324
325   return data;
326 }
327
328 /* Perform all necessary cleanups regarding our module's inferior data
329    that is required after the inferior INF just exited.  */
330
331 static void
332 ada_inferior_exit (struct inferior *inf)
333 {
334   ada_inferior_data.clear (inf);
335 }
336
337
338                         /* program-space-specific data.  */
339
340 /* This module's per-program-space data.  */
341 struct ada_pspace_data
342 {
343   /* The Ada symbol cache.  */
344   std::unique_ptr<ada_symbol_cache> sym_cache;
345 };
346
347 /* Key to our per-program-space data.  */
348 static const struct program_space_key<ada_pspace_data> ada_pspace_data_handle;
349
350 /* Return this module's data for the given program space (PSPACE).
351    If not is found, add a zero'ed one now.
352
353    This function always returns a valid object.  */
354
355 static struct ada_pspace_data *
356 get_ada_pspace_data (struct program_space *pspace)
357 {
358   struct ada_pspace_data *data;
359
360   data = ada_pspace_data_handle.get (pspace);
361   if (data == NULL)
362     data = ada_pspace_data_handle.emplace (pspace);
363
364   return data;
365 }
366
367                         /* Utilities */
368
369 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
370    all typedef layers have been peeled.  Otherwise, return TYPE.
371
372    Normally, we really expect a typedef type to only have 1 typedef layer.
373    In other words, we really expect the target type of a typedef type to be
374    a non-typedef type.  This is particularly true for Ada units, because
375    the language does not have a typedef vs not-typedef distinction.
376    In that respect, the Ada compiler has been trying to eliminate as many
377    typedef definitions in the debugging information, since they generally
378    do not bring any extra information (we still use typedef under certain
379    circumstances related mostly to the GNAT encoding).
380
381    Unfortunately, we have seen situations where the debugging information
382    generated by the compiler leads to such multiple typedef layers.  For
383    instance, consider the following example with stabs:
384
385      .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
386      .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
387
388    This is an error in the debugging information which causes type
389    pck__float_array___XUP to be defined twice, and the second time,
390    it is defined as a typedef of a typedef.
391
392    This is on the fringe of legality as far as debugging information is
393    concerned, and certainly unexpected.  But it is easy to handle these
394    situations correctly, so we can afford to be lenient in this case.  */
395
396 static struct type *
397 ada_typedef_target_type (struct type *type)
398 {
399   while (type->code () == TYPE_CODE_TYPEDEF)
400     type = TYPE_TARGET_TYPE (type);
401   return type;
402 }
403
404 /* Given DECODED_NAME a string holding a symbol name in its
405    decoded form (ie using the Ada dotted notation), returns
406    its unqualified name.  */
407
408 static const char *
409 ada_unqualified_name (const char *decoded_name)
410 {
411   const char *result;
412   
413   /* If the decoded name starts with '<', it means that the encoded
414      name does not follow standard naming conventions, and thus that
415      it is not your typical Ada symbol name.  Trying to unqualify it
416      is therefore pointless and possibly erroneous.  */
417   if (decoded_name[0] == '<')
418     return decoded_name;
419
420   result = strrchr (decoded_name, '.');
421   if (result != NULL)
422     result++;                   /* Skip the dot...  */
423   else
424     result = decoded_name;
425
426   return result;
427 }
428
429 /* Return a string starting with '<', followed by STR, and '>'.  */
430
431 static std::string
432 add_angle_brackets (const char *str)
433 {
434   return string_printf ("<%s>", str);
435 }
436
437 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
438    suffix of FIELD_NAME beginning "___".  */
439
440 static int
441 field_name_match (const char *field_name, const char *target)
442 {
443   int len = strlen (target);
444
445   return
446     (strncmp (field_name, target, len) == 0
447      && (field_name[len] == '\0'
448          || (startswith (field_name + len, "___")
449              && strcmp (field_name + strlen (field_name) - 6,
450                         "___XVN") != 0)));
451 }
452
453
454 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
455    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
456    and return its index.  This function also handles fields whose name
457    have ___ suffixes because the compiler sometimes alters their name
458    by adding such a suffix to represent fields with certain constraints.
459    If the field could not be found, return a negative number if
460    MAYBE_MISSING is set.  Otherwise raise an error.  */
461
462 int
463 ada_get_field_index (const struct type *type, const char *field_name,
464                      int maybe_missing)
465 {
466   int fieldno;
467   struct type *struct_type = check_typedef ((struct type *) type);
468
469   for (fieldno = 0; fieldno < struct_type->num_fields (); fieldno++)
470     if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
471       return fieldno;
472
473   if (!maybe_missing)
474     error (_("Unable to find field %s in struct %s.  Aborting"),
475            field_name, struct_type->name ());
476
477   return -1;
478 }
479
480 /* The length of the prefix of NAME prior to any "___" suffix.  */
481
482 int
483 ada_name_prefix_len (const char *name)
484 {
485   if (name == NULL)
486     return 0;
487   else
488     {
489       const char *p = strstr (name, "___");
490
491       if (p == NULL)
492         return strlen (name);
493       else
494         return p - name;
495     }
496 }
497
498 /* Return non-zero if SUFFIX is a suffix of STR.
499    Return zero if STR is null.  */
500
501 static int
502 is_suffix (const char *str, const char *suffix)
503 {
504   int len1, len2;
505
506   if (str == NULL)
507     return 0;
508   len1 = strlen (str);
509   len2 = strlen (suffix);
510   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
511 }
512
513 /* The contents of value VAL, treated as a value of type TYPE.  The
514    result is an lval in memory if VAL is.  */
515
516 static struct value *
517 coerce_unspec_val_to_type (struct value *val, struct type *type)
518 {
519   type = ada_check_typedef (type);
520   if (value_type (val) == type)
521     return val;
522   else
523     {
524       struct value *result;
525
526       /* Make sure that the object size is not unreasonable before
527          trying to allocate some memory for it.  */
528       ada_ensure_varsize_limit (type);
529
530       if (value_optimized_out (val))
531         result = allocate_optimized_out_value (type);
532       else if (value_lazy (val)
533                /* Be careful not to make a lazy not_lval value.  */
534                || (VALUE_LVAL (val) != not_lval
535                    && TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val))))
536         result = allocate_value_lazy (type);
537       else
538         {
539           result = allocate_value (type);
540           value_contents_copy (result, 0, val, 0, TYPE_LENGTH (type));
541         }
542       set_value_component_location (result, val);
543       set_value_bitsize (result, value_bitsize (val));
544       set_value_bitpos (result, value_bitpos (val));
545       if (VALUE_LVAL (result) == lval_memory)
546         set_value_address (result, value_address (val));
547       return result;
548     }
549 }
550
551 static const gdb_byte *
552 cond_offset_host (const gdb_byte *valaddr, long offset)
553 {
554   if (valaddr == NULL)
555     return NULL;
556   else
557     return valaddr + offset;
558 }
559
560 static CORE_ADDR
561 cond_offset_target (CORE_ADDR address, long offset)
562 {
563   if (address == 0)
564     return 0;
565   else
566     return address + offset;
567 }
568
569 /* Issue a warning (as for the definition of warning in utils.c, but
570    with exactly one argument rather than ...), unless the limit on the
571    number of warnings has passed during the evaluation of the current
572    expression.  */
573
574 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
575    provided by "complaint".  */
576 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
577
578 static void
579 lim_warning (const char *format, ...)
580 {
581   va_list args;
582
583   va_start (args, format);
584   warnings_issued += 1;
585   if (warnings_issued <= warning_limit)
586     vwarning (format, args);
587
588   va_end (args);
589 }
590
591 /* Issue an error if the size of an object of type T is unreasonable,
592    i.e. if it would be a bad idea to allocate a value of this type in
593    GDB.  */
594
595 void
596 ada_ensure_varsize_limit (const struct type *type)
597 {
598   if (TYPE_LENGTH (type) > varsize_limit)
599     error (_("object size is larger than varsize-limit"));
600 }
601
602 /* Maximum value of a SIZE-byte signed integer type.  */
603 static LONGEST
604 max_of_size (int size)
605 {
606   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
607
608   return top_bit | (top_bit - 1);
609 }
610
611 /* Minimum value of a SIZE-byte signed integer type.  */
612 static LONGEST
613 min_of_size (int size)
614 {
615   return -max_of_size (size) - 1;
616 }
617
618 /* Maximum value of a SIZE-byte unsigned integer type.  */
619 static ULONGEST
620 umax_of_size (int size)
621 {
622   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
623
624   return top_bit | (top_bit - 1);
625 }
626
627 /* Maximum value of integral type T, as a signed quantity.  */
628 static LONGEST
629 max_of_type (struct type *t)
630 {
631   if (t->is_unsigned ())
632     return (LONGEST) umax_of_size (TYPE_LENGTH (t));
633   else
634     return max_of_size (TYPE_LENGTH (t));
635 }
636
637 /* Minimum value of integral type T, as a signed quantity.  */
638 static LONGEST
639 min_of_type (struct type *t)
640 {
641   if (t->is_unsigned ())
642     return 0;
643   else
644     return min_of_size (TYPE_LENGTH (t));
645 }
646
647 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
648 LONGEST
649 ada_discrete_type_high_bound (struct type *type)
650 {
651   type = resolve_dynamic_type (type, {}, 0);
652   switch (type->code ())
653     {
654     case TYPE_CODE_RANGE:
655       {
656         const dynamic_prop &high = type->bounds ()->high;
657
658         if (high.kind () == PROP_CONST)
659           return high.const_val ();
660         else
661           {
662             gdb_assert (high.kind () == PROP_UNDEFINED);
663
664             /* This happens when trying to evaluate a type's dynamic bound
665                without a live target.  There is nothing relevant for us to
666                return here, so return 0.  */
667             return 0;
668           }
669       }
670     case TYPE_CODE_ENUM:
671       return TYPE_FIELD_ENUMVAL (type, type->num_fields () - 1);
672     case TYPE_CODE_BOOL:
673       return 1;
674     case TYPE_CODE_CHAR:
675     case TYPE_CODE_INT:
676       return max_of_type (type);
677     default:
678       error (_("Unexpected type in ada_discrete_type_high_bound."));
679     }
680 }
681
682 /* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
683 LONGEST
684 ada_discrete_type_low_bound (struct type *type)
685 {
686   type = resolve_dynamic_type (type, {}, 0);
687   switch (type->code ())
688     {
689     case TYPE_CODE_RANGE:
690       {
691         const dynamic_prop &low = type->bounds ()->low;
692
693         if (low.kind () == PROP_CONST)
694           return low.const_val ();
695         else
696           {
697             gdb_assert (low.kind () == PROP_UNDEFINED);
698
699             /* This happens when trying to evaluate a type's dynamic bound
700                without a live target.  There is nothing relevant for us to
701                return here, so return 0.  */
702             return 0;
703           }
704       }
705     case TYPE_CODE_ENUM:
706       return TYPE_FIELD_ENUMVAL (type, 0);
707     case TYPE_CODE_BOOL:
708       return 0;
709     case TYPE_CODE_CHAR:
710     case TYPE_CODE_INT:
711       return min_of_type (type);
712     default:
713       error (_("Unexpected type in ada_discrete_type_low_bound."));
714     }
715 }
716
717 /* The identity on non-range types.  For range types, the underlying
718    non-range scalar type.  */
719
720 static struct type *
721 get_base_type (struct type *type)
722 {
723   while (type != NULL && type->code () == TYPE_CODE_RANGE)
724     {
725       if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
726         return type;
727       type = TYPE_TARGET_TYPE (type);
728     }
729   return type;
730 }
731
732 /* Return a decoded version of the given VALUE.  This means returning
733    a value whose type is obtained by applying all the GNAT-specific
734    encodings, making the resulting type a static but standard description
735    of the initial type.  */
736
737 struct value *
738 ada_get_decoded_value (struct value *value)
739 {
740   struct type *type = ada_check_typedef (value_type (value));
741
742   if (ada_is_array_descriptor_type (type)
743       || (ada_is_constrained_packed_array_type (type)
744           && type->code () != TYPE_CODE_PTR))
745     {
746       if (type->code () == TYPE_CODE_TYPEDEF)  /* array access type.  */
747         value = ada_coerce_to_simple_array_ptr (value);
748       else
749         value = ada_coerce_to_simple_array (value);
750     }
751   else
752     value = ada_to_fixed_value (value);
753
754   return value;
755 }
756
757 /* Same as ada_get_decoded_value, but with the given TYPE.
758    Because there is no associated actual value for this type,
759    the resulting type might be a best-effort approximation in
760    the case of dynamic types.  */
761
762 struct type *
763 ada_get_decoded_type (struct type *type)
764 {
765   type = to_static_fixed_type (type);
766   if (ada_is_constrained_packed_array_type (type))
767     type = ada_coerce_to_simple_array_type (type);
768   return type;
769 }
770
771 \f
772
773                                 /* Language Selection */
774
775 /* If the main program is in Ada, return language_ada, otherwise return LANG
776    (the main program is in Ada iif the adainit symbol is found).  */
777
778 static enum language
779 ada_update_initial_language (enum language lang)
780 {
781   if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
782     return language_ada;
783
784   return lang;
785 }
786
787 /* If the main procedure is written in Ada, then return its name.
788    The result is good until the next call.  Return NULL if the main
789    procedure doesn't appear to be in Ada.  */
790
791 char *
792 ada_main_name (void)
793 {
794   struct bound_minimal_symbol msym;
795   static gdb::unique_xmalloc_ptr<char> main_program_name;
796
797   /* For Ada, the name of the main procedure is stored in a specific
798      string constant, generated by the binder.  Look for that symbol,
799      extract its address, and then read that string.  If we didn't find
800      that string, then most probably the main procedure is not written
801      in Ada.  */
802   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
803
804   if (msym.minsym != NULL)
805     {
806       CORE_ADDR main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
807       if (main_program_name_addr == 0)
808         error (_("Invalid address for Ada main program name."));
809
810       main_program_name = target_read_string (main_program_name_addr, 1024);
811       return main_program_name.get ();
812     }
813
814   /* The main procedure doesn't seem to be in Ada.  */
815   return NULL;
816 }
817 \f
818                                 /* Symbols */
819
820 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
821    of NULLs.  */
822
823 const struct ada_opname_map ada_opname_table[] = {
824   {"Oadd", "\"+\"", BINOP_ADD},
825   {"Osubtract", "\"-\"", BINOP_SUB},
826   {"Omultiply", "\"*\"", BINOP_MUL},
827   {"Odivide", "\"/\"", BINOP_DIV},
828   {"Omod", "\"mod\"", BINOP_MOD},
829   {"Orem", "\"rem\"", BINOP_REM},
830   {"Oexpon", "\"**\"", BINOP_EXP},
831   {"Olt", "\"<\"", BINOP_LESS},
832   {"Ole", "\"<=\"", BINOP_LEQ},
833   {"Ogt", "\">\"", BINOP_GTR},
834   {"Oge", "\">=\"", BINOP_GEQ},
835   {"Oeq", "\"=\"", BINOP_EQUAL},
836   {"One", "\"/=\"", BINOP_NOTEQUAL},
837   {"Oand", "\"and\"", BINOP_BITWISE_AND},
838   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
839   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
840   {"Oconcat", "\"&\"", BINOP_CONCAT},
841   {"Oabs", "\"abs\"", UNOP_ABS},
842   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
843   {"Oadd", "\"+\"", UNOP_PLUS},
844   {"Osubtract", "\"-\"", UNOP_NEG},
845   {NULL, NULL}
846 };
847
848 /* The "encoded" form of DECODED, according to GNAT conventions.  If
849    THROW_ERRORS, throw an error if invalid operator name is found.
850    Otherwise, return the empty string in that case.  */
851
852 static std::string
853 ada_encode_1 (const char *decoded, bool throw_errors)
854 {
855   if (decoded == NULL)
856     return {};
857
858   std::string encoding_buffer;
859   for (const char *p = decoded; *p != '\0'; p += 1)
860     {
861       if (*p == '.')
862         encoding_buffer.append ("__");
863       else if (*p == '"')
864         {
865           const struct ada_opname_map *mapping;
866
867           for (mapping = ada_opname_table;
868                mapping->encoded != NULL
869                && !startswith (p, mapping->decoded); mapping += 1)
870             ;
871           if (mapping->encoded == NULL)
872             {
873               if (throw_errors)
874                 error (_("invalid Ada operator name: %s"), p);
875               else
876                 return {};
877             }
878           encoding_buffer.append (mapping->encoded);
879           break;
880         }
881       else
882         encoding_buffer.push_back (*p);
883     }
884
885   return encoding_buffer;
886 }
887
888 /* The "encoded" form of DECODED, according to GNAT conventions.  */
889
890 std::string
891 ada_encode (const char *decoded)
892 {
893   return ada_encode_1 (decoded, true);
894 }
895
896 /* Return NAME folded to lower case, or, if surrounded by single
897    quotes, unfolded, but with the quotes stripped away.  Result good
898    to next call.  */
899
900 static const char *
901 ada_fold_name (gdb::string_view name)
902 {
903   static std::string fold_storage;
904
905   if (!name.empty () && name[0] == '\'')
906     fold_storage = gdb::to_string (name.substr (1, name.size () - 2));
907   else
908     {
909       fold_storage = gdb::to_string (name);
910       for (int i = 0; i < name.size (); i += 1)
911         fold_storage[i] = tolower (fold_storage[i]);
912     }
913
914   return fold_storage.c_str ();
915 }
916
917 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
918
919 static int
920 is_lower_alphanum (const char c)
921 {
922   return (isdigit (c) || (isalpha (c) && islower (c)));
923 }
924
925 /* ENCODED is the linkage name of a symbol and LEN contains its length.
926    This function saves in LEN the length of that same symbol name but
927    without either of these suffixes:
928      . .{DIGIT}+
929      . ${DIGIT}+
930      . ___{DIGIT}+
931      . __{DIGIT}+.
932
933    These are suffixes introduced by the compiler for entities such as
934    nested subprogram for instance, in order to avoid name clashes.
935    They do not serve any purpose for the debugger.  */
936
937 static void
938 ada_remove_trailing_digits (const char *encoded, int *len)
939 {
940   if (*len > 1 && isdigit (encoded[*len - 1]))
941     {
942       int i = *len - 2;
943
944       while (i > 0 && isdigit (encoded[i]))
945         i--;
946       if (i >= 0 && encoded[i] == '.')
947         *len = i;
948       else if (i >= 0 && encoded[i] == '$')
949         *len = i;
950       else if (i >= 2 && startswith (encoded + i - 2, "___"))
951         *len = i - 2;
952       else if (i >= 1 && startswith (encoded + i - 1, "__"))
953         *len = i - 1;
954     }
955 }
956
957 /* Remove the suffix introduced by the compiler for protected object
958    subprograms.  */
959
960 static void
961 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
962 {
963   /* Remove trailing N.  */
964
965   /* Protected entry subprograms are broken into two
966      separate subprograms: The first one is unprotected, and has
967      a 'N' suffix; the second is the protected version, and has
968      the 'P' suffix.  The second calls the first one after handling
969      the protection.  Since the P subprograms are internally generated,
970      we leave these names undecoded, giving the user a clue that this
971      entity is internal.  */
972
973   if (*len > 1
974       && encoded[*len - 1] == 'N'
975       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
976     *len = *len - 1;
977 }
978
979 /* If ENCODED follows the GNAT entity encoding conventions, then return
980    the decoded form of ENCODED.  Otherwise, return "<%s>" where "%s" is
981    replaced by ENCODED.  */
982
983 std::string
984 ada_decode (const char *encoded)
985 {
986   int i, j;
987   int len0;
988   const char *p;
989   int at_start_name;
990   std::string decoded;
991
992   /* With function descriptors on PPC64, the value of a symbol named
993      ".FN", if it exists, is the entry point of the function "FN".  */
994   if (encoded[0] == '.')
995     encoded += 1;
996
997   /* The name of the Ada main procedure starts with "_ada_".
998      This prefix is not part of the decoded name, so skip this part
999      if we see this prefix.  */
1000   if (startswith (encoded, "_ada_"))
1001     encoded += 5;
1002
1003   /* If the name starts with '_', then it is not a properly encoded
1004      name, so do not attempt to decode it.  Similarly, if the name
1005      starts with '<', the name should not be decoded.  */
1006   if (encoded[0] == '_' || encoded[0] == '<')
1007     goto Suppress;
1008
1009   len0 = strlen (encoded);
1010
1011   ada_remove_trailing_digits (encoded, &len0);
1012   ada_remove_po_subprogram_suffix (encoded, &len0);
1013
1014   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1015      the suffix is located before the current "end" of ENCODED.  We want
1016      to avoid re-matching parts of ENCODED that have previously been
1017      marked as discarded (by decrementing LEN0).  */
1018   p = strstr (encoded, "___");
1019   if (p != NULL && p - encoded < len0 - 3)
1020     {
1021       if (p[3] == 'X')
1022         len0 = p - encoded;
1023       else
1024         goto Suppress;
1025     }
1026
1027   /* Remove any trailing TKB suffix.  It tells us that this symbol
1028      is for the body of a task, but that information does not actually
1029      appear in the decoded name.  */
1030
1031   if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1032     len0 -= 3;
1033
1034   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1035      from the TKB suffix because it is used for non-anonymous task
1036      bodies.  */
1037
1038   if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1039     len0 -= 2;
1040
1041   /* Remove trailing "B" suffixes.  */
1042   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1043
1044   if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1045     len0 -= 1;
1046
1047   /* Make decoded big enough for possible expansion by operator name.  */
1048
1049   decoded.resize (2 * len0 + 1, 'X');
1050
1051   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1052
1053   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1054     {
1055       i = len0 - 2;
1056       while ((i >= 0 && isdigit (encoded[i]))
1057              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1058         i -= 1;
1059       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1060         len0 = i - 1;
1061       else if (encoded[i] == '$')
1062         len0 = i;
1063     }
1064
1065   /* The first few characters that are not alphabetic are not part
1066      of any encoding we use, so we can copy them over verbatim.  */
1067
1068   for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1069     decoded[j] = encoded[i];
1070
1071   at_start_name = 1;
1072   while (i < len0)
1073     {
1074       /* Is this a symbol function?  */
1075       if (at_start_name && encoded[i] == 'O')
1076         {
1077           int k;
1078
1079           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1080             {
1081               int op_len = strlen (ada_opname_table[k].encoded);
1082               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1083                             op_len - 1) == 0)
1084                   && !isalnum (encoded[i + op_len]))
1085                 {
1086                   strcpy (&decoded.front() + j, ada_opname_table[k].decoded);
1087                   at_start_name = 0;
1088                   i += op_len;
1089                   j += strlen (ada_opname_table[k].decoded);
1090                   break;
1091                 }
1092             }
1093           if (ada_opname_table[k].encoded != NULL)
1094             continue;
1095         }
1096       at_start_name = 0;
1097
1098       /* Replace "TK__" with "__", which will eventually be translated
1099          into "." (just below).  */
1100
1101       if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1102         i += 2;
1103
1104       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1105          be translated into "." (just below).  These are internal names
1106          generated for anonymous blocks inside which our symbol is nested.  */
1107
1108       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1109           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1110           && isdigit (encoded [i+4]))
1111         {
1112           int k = i + 5;
1113           
1114           while (k < len0 && isdigit (encoded[k]))
1115             k++;  /* Skip any extra digit.  */
1116
1117           /* Double-check that the "__B_{DIGITS}+" sequence we found
1118              is indeed followed by "__".  */
1119           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1120             i = k;
1121         }
1122
1123       /* Remove _E{DIGITS}+[sb] */
1124
1125       /* Just as for protected object subprograms, there are 2 categories
1126          of subprograms created by the compiler for each entry.  The first
1127          one implements the actual entry code, and has a suffix following
1128          the convention above; the second one implements the barrier and
1129          uses the same convention as above, except that the 'E' is replaced
1130          by a 'B'.
1131
1132          Just as above, we do not decode the name of barrier functions
1133          to give the user a clue that the code he is debugging has been
1134          internally generated.  */
1135
1136       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1137           && isdigit (encoded[i+2]))
1138         {
1139           int k = i + 3;
1140
1141           while (k < len0 && isdigit (encoded[k]))
1142             k++;
1143
1144           if (k < len0
1145               && (encoded[k] == 'b' || encoded[k] == 's'))
1146             {
1147               k++;
1148               /* Just as an extra precaution, make sure that if this
1149                  suffix is followed by anything else, it is a '_'.
1150                  Otherwise, we matched this sequence by accident.  */
1151               if (k == len0
1152                   || (k < len0 && encoded[k] == '_'))
1153                 i = k;
1154             }
1155         }
1156
1157       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1158          the GNAT front-end in protected object subprograms.  */
1159
1160       if (i < len0 + 3
1161           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1162         {
1163           /* Backtrack a bit up until we reach either the begining of
1164              the encoded name, or "__".  Make sure that we only find
1165              digits or lowercase characters.  */
1166           const char *ptr = encoded + i - 1;
1167
1168           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1169             ptr--;
1170           if (ptr < encoded
1171               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1172             i++;
1173         }
1174
1175       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1176         {
1177           /* This is a X[bn]* sequence not separated from the previous
1178              part of the name with a non-alpha-numeric character (in other
1179              words, immediately following an alpha-numeric character), then
1180              verify that it is placed at the end of the encoded name.  If
1181              not, then the encoding is not valid and we should abort the
1182              decoding.  Otherwise, just skip it, it is used in body-nested
1183              package names.  */
1184           do
1185             i += 1;
1186           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1187           if (i < len0)
1188             goto Suppress;
1189         }
1190       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1191         {
1192          /* Replace '__' by '.'.  */
1193           decoded[j] = '.';
1194           at_start_name = 1;
1195           i += 2;
1196           j += 1;
1197         }
1198       else
1199         {
1200           /* It's a character part of the decoded name, so just copy it
1201              over.  */
1202           decoded[j] = encoded[i];
1203           i += 1;
1204           j += 1;
1205         }
1206     }
1207   decoded.resize (j);
1208
1209   /* Decoded names should never contain any uppercase character.
1210      Double-check this, and abort the decoding if we find one.  */
1211
1212   for (i = 0; i < decoded.length(); ++i)
1213     if (isupper (decoded[i]) || decoded[i] == ' ')
1214       goto Suppress;
1215
1216   return decoded;
1217
1218 Suppress:
1219   if (encoded[0] == '<')
1220     decoded = encoded;
1221   else
1222     decoded = '<' + std::string(encoded) + '>';
1223   return decoded;
1224
1225 }
1226
1227 /* Table for keeping permanent unique copies of decoded names.  Once
1228    allocated, names in this table are never released.  While this is a
1229    storage leak, it should not be significant unless there are massive
1230    changes in the set of decoded names in successive versions of a 
1231    symbol table loaded during a single session.  */
1232 static struct htab *decoded_names_store;
1233
1234 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1235    in the language-specific part of GSYMBOL, if it has not been
1236    previously computed.  Tries to save the decoded name in the same
1237    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1238    in any case, the decoded symbol has a lifetime at least that of
1239    GSYMBOL).
1240    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1241    const, but nevertheless modified to a semantically equivalent form
1242    when a decoded name is cached in it.  */
1243
1244 const char *
1245 ada_decode_symbol (const struct general_symbol_info *arg)
1246 {
1247   struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1248   const char **resultp =
1249     &gsymbol->language_specific.demangled_name;
1250
1251   if (!gsymbol->ada_mangled)
1252     {
1253       std::string decoded = ada_decode (gsymbol->linkage_name ());
1254       struct obstack *obstack = gsymbol->language_specific.obstack;
1255
1256       gsymbol->ada_mangled = 1;
1257
1258       if (obstack != NULL)
1259         *resultp = obstack_strdup (obstack, decoded.c_str ());
1260       else
1261         {
1262           /* Sometimes, we can't find a corresponding objfile, in
1263              which case, we put the result on the heap.  Since we only
1264              decode when needed, we hope this usually does not cause a
1265              significant memory leak (FIXME).  */
1266
1267           char **slot = (char **) htab_find_slot (decoded_names_store,
1268                                                   decoded.c_str (), INSERT);
1269
1270           if (*slot == NULL)
1271             *slot = xstrdup (decoded.c_str ());
1272           *resultp = *slot;
1273         }
1274     }
1275
1276   return *resultp;
1277 }
1278
1279 static char *
1280 ada_la_decode (const char *encoded, int options)
1281 {
1282   return xstrdup (ada_decode (encoded).c_str ());
1283 }
1284
1285 \f
1286
1287                                 /* Arrays */
1288
1289 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1290    generated by the GNAT compiler to describe the index type used
1291    for each dimension of an array, check whether it follows the latest
1292    known encoding.  If not, fix it up to conform to the latest encoding.
1293    Otherwise, do nothing.  This function also does nothing if
1294    INDEX_DESC_TYPE is NULL.
1295
1296    The GNAT encoding used to describe the array index type evolved a bit.
1297    Initially, the information would be provided through the name of each
1298    field of the structure type only, while the type of these fields was
1299    described as unspecified and irrelevant.  The debugger was then expected
1300    to perform a global type lookup using the name of that field in order
1301    to get access to the full index type description.  Because these global
1302    lookups can be very expensive, the encoding was later enhanced to make
1303    the global lookup unnecessary by defining the field type as being
1304    the full index type description.
1305
1306    The purpose of this routine is to allow us to support older versions
1307    of the compiler by detecting the use of the older encoding, and by
1308    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1309    we essentially replace each field's meaningless type by the associated
1310    index subtype).  */
1311
1312 void
1313 ada_fixup_array_indexes_type (struct type *index_desc_type)
1314 {
1315   int i;
1316
1317   if (index_desc_type == NULL)
1318     return;
1319   gdb_assert (index_desc_type->num_fields () > 0);
1320
1321   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1322      to check one field only, no need to check them all).  If not, return
1323      now.
1324
1325      If our INDEX_DESC_TYPE was generated using the older encoding,
1326      the field type should be a meaningless integer type whose name
1327      is not equal to the field name.  */
1328   if (index_desc_type->field (0).type ()->name () != NULL
1329       && strcmp (index_desc_type->field (0).type ()->name (),
1330                  TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1331     return;
1332
1333   /* Fixup each field of INDEX_DESC_TYPE.  */
1334   for (i = 0; i < index_desc_type->num_fields (); i++)
1335    {
1336      const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1337      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1338
1339      if (raw_type)
1340        index_desc_type->field (i).set_type (raw_type);
1341    }
1342 }
1343
1344 /* The desc_* routines return primitive portions of array descriptors
1345    (fat pointers).  */
1346
1347 /* The descriptor or array type, if any, indicated by TYPE; removes
1348    level of indirection, if needed.  */
1349
1350 static struct type *
1351 desc_base_type (struct type *type)
1352 {
1353   if (type == NULL)
1354     return NULL;
1355   type = ada_check_typedef (type);
1356   if (type->code () == TYPE_CODE_TYPEDEF)
1357     type = ada_typedef_target_type (type);
1358
1359   if (type != NULL
1360       && (type->code () == TYPE_CODE_PTR
1361           || type->code () == TYPE_CODE_REF))
1362     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1363   else
1364     return type;
1365 }
1366
1367 /* True iff TYPE indicates a "thin" array pointer type.  */
1368
1369 static int
1370 is_thin_pntr (struct type *type)
1371 {
1372   return
1373     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1374     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1375 }
1376
1377 /* The descriptor type for thin pointer type TYPE.  */
1378
1379 static struct type *
1380 thin_descriptor_type (struct type *type)
1381 {
1382   struct type *base_type = desc_base_type (type);
1383
1384   if (base_type == NULL)
1385     return NULL;
1386   if (is_suffix (ada_type_name (base_type), "___XVE"))
1387     return base_type;
1388   else
1389     {
1390       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1391
1392       if (alt_type == NULL)
1393         return base_type;
1394       else
1395         return alt_type;
1396     }
1397 }
1398
1399 /* A pointer to the array data for thin-pointer value VAL.  */
1400
1401 static struct value *
1402 thin_data_pntr (struct value *val)
1403 {
1404   struct type *type = ada_check_typedef (value_type (val));
1405   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1406
1407   data_type = lookup_pointer_type (data_type);
1408
1409   if (type->code () == TYPE_CODE_PTR)
1410     return value_cast (data_type, value_copy (val));
1411   else
1412     return value_from_longest (data_type, value_address (val));
1413 }
1414
1415 /* True iff TYPE indicates a "thick" array pointer type.  */
1416
1417 static int
1418 is_thick_pntr (struct type *type)
1419 {
1420   type = desc_base_type (type);
1421   return (type != NULL && type->code () == TYPE_CODE_STRUCT
1422           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1423 }
1424
1425 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1426    pointer to one, the type of its bounds data; otherwise, NULL.  */
1427
1428 static struct type *
1429 desc_bounds_type (struct type *type)
1430 {
1431   struct type *r;
1432
1433   type = desc_base_type (type);
1434
1435   if (type == NULL)
1436     return NULL;
1437   else if (is_thin_pntr (type))
1438     {
1439       type = thin_descriptor_type (type);
1440       if (type == NULL)
1441         return NULL;
1442       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1443       if (r != NULL)
1444         return ada_check_typedef (r);
1445     }
1446   else if (type->code () == TYPE_CODE_STRUCT)
1447     {
1448       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1449       if (r != NULL)
1450         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1451     }
1452   return NULL;
1453 }
1454
1455 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1456    one, a pointer to its bounds data.   Otherwise NULL.  */
1457
1458 static struct value *
1459 desc_bounds (struct value *arr)
1460 {
1461   struct type *type = ada_check_typedef (value_type (arr));
1462
1463   if (is_thin_pntr (type))
1464     {
1465       struct type *bounds_type =
1466         desc_bounds_type (thin_descriptor_type (type));
1467       LONGEST addr;
1468
1469       if (bounds_type == NULL)
1470         error (_("Bad GNAT array descriptor"));
1471
1472       /* NOTE: The following calculation is not really kosher, but
1473          since desc_type is an XVE-encoded type (and shouldn't be),
1474          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1475       if (type->code () == TYPE_CODE_PTR)
1476         addr = value_as_long (arr);
1477       else
1478         addr = value_address (arr);
1479
1480       return
1481         value_from_longest (lookup_pointer_type (bounds_type),
1482                             addr - TYPE_LENGTH (bounds_type));
1483     }
1484
1485   else if (is_thick_pntr (type))
1486     {
1487       struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1488                                                _("Bad GNAT array descriptor"));
1489       struct type *p_bounds_type = value_type (p_bounds);
1490
1491       if (p_bounds_type
1492           && p_bounds_type->code () == TYPE_CODE_PTR)
1493         {
1494           struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1495
1496           if (target_type->is_stub ())
1497             p_bounds = value_cast (lookup_pointer_type
1498                                    (ada_check_typedef (target_type)),
1499                                    p_bounds);
1500         }
1501       else
1502         error (_("Bad GNAT array descriptor"));
1503
1504       return p_bounds;
1505     }
1506   else
1507     return NULL;
1508 }
1509
1510 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1511    position of the field containing the address of the bounds data.  */
1512
1513 static int
1514 fat_pntr_bounds_bitpos (struct type *type)
1515 {
1516   return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1517 }
1518
1519 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1520    size of the field containing the address of the bounds data.  */
1521
1522 static int
1523 fat_pntr_bounds_bitsize (struct type *type)
1524 {
1525   type = desc_base_type (type);
1526
1527   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1528     return TYPE_FIELD_BITSIZE (type, 1);
1529   else
1530     return 8 * TYPE_LENGTH (ada_check_typedef (type->field (1).type ()));
1531 }
1532
1533 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1534    pointer to one, the type of its array data (a array-with-no-bounds type);
1535    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1536    data.  */
1537
1538 static struct type *
1539 desc_data_target_type (struct type *type)
1540 {
1541   type = desc_base_type (type);
1542
1543   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1544   if (is_thin_pntr (type))
1545     return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1546   else if (is_thick_pntr (type))
1547     {
1548       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1549
1550       if (data_type
1551           && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1552         return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1553     }
1554
1555   return NULL;
1556 }
1557
1558 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1559    its array data.  */
1560
1561 static struct value *
1562 desc_data (struct value *arr)
1563 {
1564   struct type *type = value_type (arr);
1565
1566   if (is_thin_pntr (type))
1567     return thin_data_pntr (arr);
1568   else if (is_thick_pntr (type))
1569     return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1570                              _("Bad GNAT array descriptor"));
1571   else
1572     return NULL;
1573 }
1574
1575
1576 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1577    position of the field containing the address of the data.  */
1578
1579 static int
1580 fat_pntr_data_bitpos (struct type *type)
1581 {
1582   return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1583 }
1584
1585 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1586    size of the field containing the address of the data.  */
1587
1588 static int
1589 fat_pntr_data_bitsize (struct type *type)
1590 {
1591   type = desc_base_type (type);
1592
1593   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1594     return TYPE_FIELD_BITSIZE (type, 0);
1595   else
1596     return TARGET_CHAR_BIT * TYPE_LENGTH (type->field (0).type ());
1597 }
1598
1599 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1600    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1601    bound, if WHICH is 1.  The first bound is I=1.  */
1602
1603 static struct value *
1604 desc_one_bound (struct value *bounds, int i, int which)
1605 {
1606   char bound_name[20];
1607   xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1608              which ? 'U' : 'L', i - 1);
1609   return value_struct_elt (&bounds, NULL, bound_name, NULL,
1610                            _("Bad GNAT array descriptor bounds"));
1611 }
1612
1613 /* If BOUNDS is an array-bounds structure type, return the bit position
1614    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1615    bound, if WHICH is 1.  The first bound is I=1.  */
1616
1617 static int
1618 desc_bound_bitpos (struct type *type, int i, int which)
1619 {
1620   return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1621 }
1622
1623 /* If BOUNDS is an array-bounds structure type, return the bit field size
1624    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1625    bound, if WHICH is 1.  The first bound is I=1.  */
1626
1627 static int
1628 desc_bound_bitsize (struct type *type, int i, int which)
1629 {
1630   type = desc_base_type (type);
1631
1632   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1633     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1634   else
1635     return 8 * TYPE_LENGTH (type->field (2 * i + which - 2).type ());
1636 }
1637
1638 /* If TYPE is the type of an array-bounds structure, the type of its
1639    Ith bound (numbering from 1).  Otherwise, NULL.  */
1640
1641 static struct type *
1642 desc_index_type (struct type *type, int i)
1643 {
1644   type = desc_base_type (type);
1645
1646   if (type->code () == TYPE_CODE_STRUCT)
1647     {
1648       char bound_name[20];
1649       xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
1650       return lookup_struct_elt_type (type, bound_name, 1);
1651     }
1652   else
1653     return NULL;
1654 }
1655
1656 /* The number of index positions in the array-bounds type TYPE.
1657    Return 0 if TYPE is NULL.  */
1658
1659 static int
1660 desc_arity (struct type *type)
1661 {
1662   type = desc_base_type (type);
1663
1664   if (type != NULL)
1665     return type->num_fields () / 2;
1666   return 0;
1667 }
1668
1669 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
1670    an array descriptor type (representing an unconstrained array
1671    type).  */
1672
1673 static int
1674 ada_is_direct_array_type (struct type *type)
1675 {
1676   if (type == NULL)
1677     return 0;
1678   type = ada_check_typedef (type);
1679   return (type->code () == TYPE_CODE_ARRAY
1680           || ada_is_array_descriptor_type (type));
1681 }
1682
1683 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1684  * to one.  */
1685
1686 static int
1687 ada_is_array_type (struct type *type)
1688 {
1689   while (type != NULL
1690          && (type->code () == TYPE_CODE_PTR
1691              || type->code () == TYPE_CODE_REF))
1692     type = TYPE_TARGET_TYPE (type);
1693   return ada_is_direct_array_type (type);
1694 }
1695
1696 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
1697
1698 int
1699 ada_is_simple_array_type (struct type *type)
1700 {
1701   if (type == NULL)
1702     return 0;
1703   type = ada_check_typedef (type);
1704   return (type->code () == TYPE_CODE_ARRAY
1705           || (type->code () == TYPE_CODE_PTR
1706               && (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ()
1707                   == TYPE_CODE_ARRAY)));
1708 }
1709
1710 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
1711
1712 int
1713 ada_is_array_descriptor_type (struct type *type)
1714 {
1715   struct type *data_type = desc_data_target_type (type);
1716
1717   if (type == NULL)
1718     return 0;
1719   type = ada_check_typedef (type);
1720   return (data_type != NULL
1721           && data_type->code () == TYPE_CODE_ARRAY
1722           && desc_arity (desc_bounds_type (type)) > 0);
1723 }
1724
1725 /* Non-zero iff type is a partially mal-formed GNAT array
1726    descriptor.  FIXME: This is to compensate for some problems with
1727    debugging output from GNAT.  Re-examine periodically to see if it
1728    is still needed.  */
1729
1730 int
1731 ada_is_bogus_array_descriptor (struct type *type)
1732 {
1733   return
1734     type != NULL
1735     && type->code () == TYPE_CODE_STRUCT
1736     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1737         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1738     && !ada_is_array_descriptor_type (type);
1739 }
1740
1741
1742 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1743    (fat pointer) returns the type of the array data described---specifically,
1744    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
1745    in from the descriptor; otherwise, they are left unspecified.  If
1746    the ARR denotes a null array descriptor and BOUNDS is non-zero,
1747    returns NULL.  The result is simply the type of ARR if ARR is not
1748    a descriptor.  */
1749
1750 static struct type *
1751 ada_type_of_array (struct value *arr, int bounds)
1752 {
1753   if (ada_is_constrained_packed_array_type (value_type (arr)))
1754     return decode_constrained_packed_array_type (value_type (arr));
1755
1756   if (!ada_is_array_descriptor_type (value_type (arr)))
1757     return value_type (arr);
1758
1759   if (!bounds)
1760     {
1761       struct type *array_type =
1762         ada_check_typedef (desc_data_target_type (value_type (arr)));
1763
1764       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1765         TYPE_FIELD_BITSIZE (array_type, 0) =
1766           decode_packed_array_bitsize (value_type (arr));
1767       
1768       return array_type;
1769     }
1770   else
1771     {
1772       struct type *elt_type;
1773       int arity;
1774       struct value *descriptor;
1775
1776       elt_type = ada_array_element_type (value_type (arr), -1);
1777       arity = ada_array_arity (value_type (arr));
1778
1779       if (elt_type == NULL || arity == 0)
1780         return ada_check_typedef (value_type (arr));
1781
1782       descriptor = desc_bounds (arr);
1783       if (value_as_long (descriptor) == 0)
1784         return NULL;
1785       while (arity > 0)
1786         {
1787           struct type *range_type = alloc_type_copy (value_type (arr));
1788           struct type *array_type = alloc_type_copy (value_type (arr));
1789           struct value *low = desc_one_bound (descriptor, arity, 0);
1790           struct value *high = desc_one_bound (descriptor, arity, 1);
1791
1792           arity -= 1;
1793           create_static_range_type (range_type, value_type (low),
1794                                     longest_to_int (value_as_long (low)),
1795                                     longest_to_int (value_as_long (high)));
1796           elt_type = create_array_type (array_type, elt_type, range_type);
1797
1798           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1799             {
1800               /* We need to store the element packed bitsize, as well as
1801                  recompute the array size, because it was previously
1802                  computed based on the unpacked element size.  */
1803               LONGEST lo = value_as_long (low);
1804               LONGEST hi = value_as_long (high);
1805
1806               TYPE_FIELD_BITSIZE (elt_type, 0) =
1807                 decode_packed_array_bitsize (value_type (arr));
1808               /* If the array has no element, then the size is already
1809                  zero, and does not need to be recomputed.  */
1810               if (lo < hi)
1811                 {
1812                   int array_bitsize =
1813                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1814
1815                   TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1816                 }
1817             }
1818         }
1819
1820       return lookup_pointer_type (elt_type);
1821     }
1822 }
1823
1824 /* If ARR does not represent an array, returns ARR unchanged.
1825    Otherwise, returns either a standard GDB array with bounds set
1826    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1827    GDB array.  Returns NULL if ARR is a null fat pointer.  */
1828
1829 struct value *
1830 ada_coerce_to_simple_array_ptr (struct value *arr)
1831 {
1832   if (ada_is_array_descriptor_type (value_type (arr)))
1833     {
1834       struct type *arrType = ada_type_of_array (arr, 1);
1835
1836       if (arrType == NULL)
1837         return NULL;
1838       return value_cast (arrType, value_copy (desc_data (arr)));
1839     }
1840   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1841     return decode_constrained_packed_array (arr);
1842   else
1843     return arr;
1844 }
1845
1846 /* If ARR does not represent an array, returns ARR unchanged.
1847    Otherwise, returns a standard GDB array describing ARR (which may
1848    be ARR itself if it already is in the proper form).  */
1849
1850 struct value *
1851 ada_coerce_to_simple_array (struct value *arr)
1852 {
1853   if (ada_is_array_descriptor_type (value_type (arr)))
1854     {
1855       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1856
1857       if (arrVal == NULL)
1858         error (_("Bounds unavailable for null array pointer."));
1859       ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
1860       return value_ind (arrVal);
1861     }
1862   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1863     return decode_constrained_packed_array (arr);
1864   else
1865     return arr;
1866 }
1867
1868 /* If TYPE represents a GNAT array type, return it translated to an
1869    ordinary GDB array type (possibly with BITSIZE fields indicating
1870    packing).  For other types, is the identity.  */
1871
1872 struct type *
1873 ada_coerce_to_simple_array_type (struct type *type)
1874 {
1875   if (ada_is_constrained_packed_array_type (type))
1876     return decode_constrained_packed_array_type (type);
1877
1878   if (ada_is_array_descriptor_type (type))
1879     return ada_check_typedef (desc_data_target_type (type));
1880
1881   return type;
1882 }
1883
1884 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
1885
1886 static int
1887 ada_is_gnat_encoded_packed_array_type  (struct type *type)
1888 {
1889   if (type == NULL)
1890     return 0;
1891   type = desc_base_type (type);
1892   type = ada_check_typedef (type);
1893   return
1894     ada_type_name (type) != NULL
1895     && strstr (ada_type_name (type), "___XP") != NULL;
1896 }
1897
1898 /* Non-zero iff TYPE represents a standard GNAT constrained
1899    packed-array type.  */
1900
1901 int
1902 ada_is_constrained_packed_array_type (struct type *type)
1903 {
1904   return ada_is_gnat_encoded_packed_array_type (type)
1905     && !ada_is_array_descriptor_type (type);
1906 }
1907
1908 /* Non-zero iff TYPE represents an array descriptor for a
1909    unconstrained packed-array type.  */
1910
1911 static int
1912 ada_is_unconstrained_packed_array_type (struct type *type)
1913 {
1914   if (!ada_is_array_descriptor_type (type))
1915     return 0;
1916
1917   if (ada_is_gnat_encoded_packed_array_type (type))
1918     return 1;
1919
1920   /* If we saw GNAT encodings, then the above code is sufficient.
1921      However, with minimal encodings, we will just have a thick
1922      pointer instead.  */
1923   if (is_thick_pntr (type))
1924     {
1925       type = desc_base_type (type);
1926       /* The structure's first field is a pointer to an array, so this
1927          fetches the array type.  */
1928       type = TYPE_TARGET_TYPE (type->field (0).type ());
1929       /* Now we can see if the array elements are packed.  */
1930       return TYPE_FIELD_BITSIZE (type, 0) > 0;
1931     }
1932
1933   return 0;
1934 }
1935
1936 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
1937    type, or if it is an ordinary (non-Gnat-encoded) packed array.  */
1938
1939 static bool
1940 ada_is_any_packed_array_type (struct type *type)
1941 {
1942   return (ada_is_constrained_packed_array_type (type)
1943           || (type->code () == TYPE_CODE_ARRAY
1944               && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
1945 }
1946
1947 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
1948    return the size of its elements in bits.  */
1949
1950 static long
1951 decode_packed_array_bitsize (struct type *type)
1952 {
1953   const char *raw_name;
1954   const char *tail;
1955   long bits;
1956
1957   /* Access to arrays implemented as fat pointers are encoded as a typedef
1958      of the fat pointer type.  We need the name of the fat pointer type
1959      to do the decoding, so strip the typedef layer.  */
1960   if (type->code () == TYPE_CODE_TYPEDEF)
1961     type = ada_typedef_target_type (type);
1962
1963   raw_name = ada_type_name (ada_check_typedef (type));
1964   if (!raw_name)
1965     raw_name = ada_type_name (desc_base_type (type));
1966
1967   if (!raw_name)
1968     return 0;
1969
1970   tail = strstr (raw_name, "___XP");
1971   if (tail == nullptr)
1972     {
1973       gdb_assert (is_thick_pntr (type));
1974       /* The structure's first field is a pointer to an array, so this
1975          fetches the array type.  */
1976       type = TYPE_TARGET_TYPE (type->field (0).type ());
1977       /* Now we can see if the array elements are packed.  */
1978       return TYPE_FIELD_BITSIZE (type, 0);
1979     }
1980
1981   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1982     {
1983       lim_warning
1984         (_("could not understand bit size information on packed array"));
1985       return 0;
1986     }
1987
1988   return bits;
1989 }
1990
1991 /* Given that TYPE is a standard GDB array type with all bounds filled
1992    in, and that the element size of its ultimate scalar constituents
1993    (that is, either its elements, or, if it is an array of arrays, its
1994    elements' elements, etc.) is *ELT_BITS, return an identical type,
1995    but with the bit sizes of its elements (and those of any
1996    constituent arrays) recorded in the BITSIZE components of its
1997    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1998    in bits.
1999
2000    Note that, for arrays whose index type has an XA encoding where
2001    a bound references a record discriminant, getting that discriminant,
2002    and therefore the actual value of that bound, is not possible
2003    because none of the given parameters gives us access to the record.
2004    This function assumes that it is OK in the context where it is being
2005    used to return an array whose bounds are still dynamic and where
2006    the length is arbitrary.  */
2007
2008 static struct type *
2009 constrained_packed_array_type (struct type *type, long *elt_bits)
2010 {
2011   struct type *new_elt_type;
2012   struct type *new_type;
2013   struct type *index_type_desc;
2014   struct type *index_type;
2015   LONGEST low_bound, high_bound;
2016
2017   type = ada_check_typedef (type);
2018   if (type->code () != TYPE_CODE_ARRAY)
2019     return type;
2020
2021   index_type_desc = ada_find_parallel_type (type, "___XA");
2022   if (index_type_desc)
2023     index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2024                                       NULL);
2025   else
2026     index_type = type->index_type ();
2027
2028   new_type = alloc_type_copy (type);
2029   new_elt_type =
2030     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2031                                    elt_bits);
2032   create_array_type (new_type, new_elt_type, index_type);
2033   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2034   new_type->set_name (ada_type_name (type));
2035
2036   if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2037        && is_dynamic_type (check_typedef (index_type)))
2038       || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2039     low_bound = high_bound = 0;
2040   if (high_bound < low_bound)
2041     *elt_bits = TYPE_LENGTH (new_type) = 0;
2042   else
2043     {
2044       *elt_bits *= (high_bound - low_bound + 1);
2045       TYPE_LENGTH (new_type) =
2046         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2047     }
2048
2049   new_type->set_is_fixed_instance (true);
2050   return new_type;
2051 }
2052
2053 /* The array type encoded by TYPE, where
2054    ada_is_constrained_packed_array_type (TYPE).  */
2055
2056 static struct type *
2057 decode_constrained_packed_array_type (struct type *type)
2058 {
2059   const char *raw_name = ada_type_name (ada_check_typedef (type));
2060   char *name;
2061   const char *tail;
2062   struct type *shadow_type;
2063   long bits;
2064
2065   if (!raw_name)
2066     raw_name = ada_type_name (desc_base_type (type));
2067
2068   if (!raw_name)
2069     return NULL;
2070
2071   name = (char *) alloca (strlen (raw_name) + 1);
2072   tail = strstr (raw_name, "___XP");
2073   type = desc_base_type (type);
2074
2075   memcpy (name, raw_name, tail - raw_name);
2076   name[tail - raw_name] = '\000';
2077
2078   shadow_type = ada_find_parallel_type_with_name (type, name);
2079
2080   if (shadow_type == NULL)
2081     {
2082       lim_warning (_("could not find bounds information on packed array"));
2083       return NULL;
2084     }
2085   shadow_type = check_typedef (shadow_type);
2086
2087   if (shadow_type->code () != TYPE_CODE_ARRAY)
2088     {
2089       lim_warning (_("could not understand bounds "
2090                      "information on packed array"));
2091       return NULL;
2092     }
2093
2094   bits = decode_packed_array_bitsize (type);
2095   return constrained_packed_array_type (shadow_type, &bits);
2096 }
2097
2098 /* Helper function for decode_constrained_packed_array.  Set the field
2099    bitsize on a series of packed arrays.  Returns the number of
2100    elements in TYPE.  */
2101
2102 static LONGEST
2103 recursively_update_array_bitsize (struct type *type)
2104 {
2105   gdb_assert (type->code () == TYPE_CODE_ARRAY);
2106
2107   LONGEST low, high;
2108   if (!get_discrete_bounds (type->index_type (), &low, &high)
2109       || low > high)
2110     return 0;
2111   LONGEST our_len = high - low + 1;
2112
2113   struct type *elt_type = TYPE_TARGET_TYPE (type);
2114   if (elt_type->code () == TYPE_CODE_ARRAY)
2115     {
2116       LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2117       LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2118       TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2119
2120       TYPE_LENGTH (type) = ((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2121                             / HOST_CHAR_BIT);
2122     }
2123
2124   return our_len;
2125 }
2126
2127 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2128    array, returns a simple array that denotes that array.  Its type is a
2129    standard GDB array type except that the BITSIZEs of the array
2130    target types are set to the number of bits in each element, and the
2131    type length is set appropriately.  */
2132
2133 static struct value *
2134 decode_constrained_packed_array (struct value *arr)
2135 {
2136   struct type *type;
2137
2138   /* If our value is a pointer, then dereference it. Likewise if
2139      the value is a reference.  Make sure that this operation does not
2140      cause the target type to be fixed, as this would indirectly cause
2141      this array to be decoded.  The rest of the routine assumes that
2142      the array hasn't been decoded yet, so we use the basic "coerce_ref"
2143      and "value_ind" routines to perform the dereferencing, as opposed
2144      to using "ada_coerce_ref" or "ada_value_ind".  */
2145   arr = coerce_ref (arr);
2146   if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2147     arr = value_ind (arr);
2148
2149   type = decode_constrained_packed_array_type (value_type (arr));
2150   if (type == NULL)
2151     {
2152       error (_("can't unpack array"));
2153       return NULL;
2154     }
2155
2156   /* Decoding the packed array type could not correctly set the field
2157      bitsizes for any dimension except the innermost, because the
2158      bounds may be variable and were not passed to that function.  So,
2159      we further resolve the array bounds here and then update the
2160      sizes.  */
2161   const gdb_byte *valaddr = value_contents_for_printing (arr);
2162   CORE_ADDR address = value_address (arr);
2163   gdb::array_view<const gdb_byte> view
2164     = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
2165   type = resolve_dynamic_type (type, view, address);
2166   recursively_update_array_bitsize (type);
2167
2168   if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2169       && ada_is_modular_type (value_type (arr)))
2170     {
2171        /* This is a (right-justified) modular type representing a packed
2172          array with no wrapper.  In order to interpret the value through
2173          the (left-justified) packed array type we just built, we must
2174          first left-justify it.  */
2175       int bit_size, bit_pos;
2176       ULONGEST mod;
2177
2178       mod = ada_modulus (value_type (arr)) - 1;
2179       bit_size = 0;
2180       while (mod > 0)
2181         {
2182           bit_size += 1;
2183           mod >>= 1;
2184         }
2185       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2186       arr = ada_value_primitive_packed_val (arr, NULL,
2187                                             bit_pos / HOST_CHAR_BIT,
2188                                             bit_pos % HOST_CHAR_BIT,
2189                                             bit_size,
2190                                             type);
2191     }
2192
2193   return coerce_unspec_val_to_type (arr, type);
2194 }
2195
2196
2197 /* The value of the element of packed array ARR at the ARITY indices
2198    given in IND.   ARR must be a simple array.  */
2199
2200 static struct value *
2201 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2202 {
2203   int i;
2204   int bits, elt_off, bit_off;
2205   long elt_total_bit_offset;
2206   struct type *elt_type;
2207   struct value *v;
2208
2209   bits = 0;
2210   elt_total_bit_offset = 0;
2211   elt_type = ada_check_typedef (value_type (arr));
2212   for (i = 0; i < arity; i += 1)
2213     {
2214       if (elt_type->code () != TYPE_CODE_ARRAY
2215           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2216         error
2217           (_("attempt to do packed indexing of "
2218              "something other than a packed array"));
2219       else
2220         {
2221           struct type *range_type = elt_type->index_type ();
2222           LONGEST lowerbound, upperbound;
2223           LONGEST idx;
2224
2225           if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2226             {
2227               lim_warning (_("don't know bounds of array"));
2228               lowerbound = upperbound = 0;
2229             }
2230
2231           idx = pos_atr (ind[i]);
2232           if (idx < lowerbound || idx > upperbound)
2233             lim_warning (_("packed array index %ld out of bounds"),
2234                          (long) idx);
2235           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2236           elt_total_bit_offset += (idx - lowerbound) * bits;
2237           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2238         }
2239     }
2240   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2241   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2242
2243   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2244                                       bits, elt_type);
2245   return v;
2246 }
2247
2248 /* Non-zero iff TYPE includes negative integer values.  */
2249
2250 static int
2251 has_negatives (struct type *type)
2252 {
2253   switch (type->code ())
2254     {
2255     default:
2256       return 0;
2257     case TYPE_CODE_INT:
2258       return !type->is_unsigned ();
2259     case TYPE_CODE_RANGE:
2260       return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2261     }
2262 }
2263
2264 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2265    unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
2266    the unpacked buffer.
2267
2268    The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2269    enough to contain at least BIT_OFFSET bits.  If not, an error is raised.
2270
2271    IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2272    zero otherwise.
2273
2274    IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2275
2276    IS_SCALAR is nonzero if the data corresponds to a signed type.  */
2277
2278 static void
2279 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2280                           gdb_byte *unpacked, int unpacked_len,
2281                           int is_big_endian, int is_signed_type,
2282                           int is_scalar)
2283 {
2284   int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2285   int src_idx;                  /* Index into the source area */
2286   int src_bytes_left;           /* Number of source bytes left to process.  */
2287   int srcBitsLeft;              /* Number of source bits left to move */
2288   int unusedLS;                 /* Number of bits in next significant
2289                                    byte of source that are unused */
2290
2291   int unpacked_idx;             /* Index into the unpacked buffer */
2292   int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */
2293
2294   unsigned long accum;          /* Staging area for bits being transferred */
2295   int accumSize;                /* Number of meaningful bits in accum */
2296   unsigned char sign;
2297
2298   /* Transmit bytes from least to most significant; delta is the direction
2299      the indices move.  */
2300   int delta = is_big_endian ? -1 : 1;
2301
2302   /* Make sure that unpacked is large enough to receive the BIT_SIZE
2303      bits from SRC.  .*/
2304   if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2305     error (_("Cannot unpack %d bits into buffer of %d bytes"),
2306            bit_size, unpacked_len);
2307
2308   srcBitsLeft = bit_size;
2309   src_bytes_left = src_len;
2310   unpacked_bytes_left = unpacked_len;
2311   sign = 0;
2312
2313   if (is_big_endian)
2314     {
2315       src_idx = src_len - 1;
2316       if (is_signed_type
2317           && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2318         sign = ~0;
2319
2320       unusedLS =
2321         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2322         % HOST_CHAR_BIT;
2323
2324       if (is_scalar)
2325         {
2326           accumSize = 0;
2327           unpacked_idx = unpacked_len - 1;
2328         }
2329       else
2330         {
2331           /* Non-scalar values must be aligned at a byte boundary...  */
2332           accumSize =
2333             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2334           /* ... And are placed at the beginning (most-significant) bytes
2335              of the target.  */
2336           unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2337           unpacked_bytes_left = unpacked_idx + 1;
2338         }
2339     }
2340   else
2341     {
2342       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2343
2344       src_idx = unpacked_idx = 0;
2345       unusedLS = bit_offset;
2346       accumSize = 0;
2347
2348       if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2349         sign = ~0;
2350     }
2351
2352   accum = 0;
2353   while (src_bytes_left > 0)
2354     {
2355       /* Mask for removing bits of the next source byte that are not
2356          part of the value.  */
2357       unsigned int unusedMSMask =
2358         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2359         1;
2360       /* Sign-extend bits for this byte.  */
2361       unsigned int signMask = sign & ~unusedMSMask;
2362
2363       accum |=
2364         (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2365       accumSize += HOST_CHAR_BIT - unusedLS;
2366       if (accumSize >= HOST_CHAR_BIT)
2367         {
2368           unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2369           accumSize -= HOST_CHAR_BIT;
2370           accum >>= HOST_CHAR_BIT;
2371           unpacked_bytes_left -= 1;
2372           unpacked_idx += delta;
2373         }
2374       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2375       unusedLS = 0;
2376       src_bytes_left -= 1;
2377       src_idx += delta;
2378     }
2379   while (unpacked_bytes_left > 0)
2380     {
2381       accum |= sign << accumSize;
2382       unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2383       accumSize -= HOST_CHAR_BIT;
2384       if (accumSize < 0)
2385         accumSize = 0;
2386       accum >>= HOST_CHAR_BIT;
2387       unpacked_bytes_left -= 1;
2388       unpacked_idx += delta;
2389     }
2390 }
2391
2392 /* Create a new value of type TYPE from the contents of OBJ starting
2393    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2394    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2395    assigning through the result will set the field fetched from.
2396    VALADDR is ignored unless OBJ is NULL, in which case,
2397    VALADDR+OFFSET must address the start of storage containing the 
2398    packed value.  The value returned  in this case is never an lval.
2399    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2400
2401 struct value *
2402 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2403                                 long offset, int bit_offset, int bit_size,
2404                                 struct type *type)
2405 {
2406   struct value *v;
2407   const gdb_byte *src;                /* First byte containing data to unpack */
2408   gdb_byte *unpacked;
2409   const int is_scalar = is_scalar_type (type);
2410   const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2411   gdb::byte_vector staging;
2412
2413   type = ada_check_typedef (type);
2414
2415   if (obj == NULL)
2416     src = valaddr + offset;
2417   else
2418     src = value_contents (obj) + offset;
2419
2420   if (is_dynamic_type (type))
2421     {
2422       /* The length of TYPE might by dynamic, so we need to resolve
2423          TYPE in order to know its actual size, which we then use
2424          to create the contents buffer of the value we return.
2425          The difficulty is that the data containing our object is
2426          packed, and therefore maybe not at a byte boundary.  So, what
2427          we do, is unpack the data into a byte-aligned buffer, and then
2428          use that buffer as our object's value for resolving the type.  */
2429       int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2430       staging.resize (staging_len);
2431
2432       ada_unpack_from_contents (src, bit_offset, bit_size,
2433                                 staging.data (), staging.size (),
2434                                 is_big_endian, has_negatives (type),
2435                                 is_scalar);
2436       type = resolve_dynamic_type (type, staging, 0);
2437       if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2438         {
2439           /* This happens when the length of the object is dynamic,
2440              and is actually smaller than the space reserved for it.
2441              For instance, in an array of variant records, the bit_size
2442              we're given is the array stride, which is constant and
2443              normally equal to the maximum size of its element.
2444              But, in reality, each element only actually spans a portion
2445              of that stride.  */
2446           bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2447         }
2448     }
2449
2450   if (obj == NULL)
2451     {
2452       v = allocate_value (type);
2453       src = valaddr + offset;
2454     }
2455   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2456     {
2457       int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2458       gdb_byte *buf;
2459
2460       v = value_at (type, value_address (obj) + offset);
2461       buf = (gdb_byte *) alloca (src_len);
2462       read_memory (value_address (v), buf, src_len);
2463       src = buf;
2464     }
2465   else
2466     {
2467       v = allocate_value (type);
2468       src = value_contents (obj) + offset;
2469     }
2470
2471   if (obj != NULL)
2472     {
2473       long new_offset = offset;
2474
2475       set_value_component_location (v, obj);
2476       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2477       set_value_bitsize (v, bit_size);
2478       if (value_bitpos (v) >= HOST_CHAR_BIT)
2479         {
2480           ++new_offset;
2481           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2482         }
2483       set_value_offset (v, new_offset);
2484
2485       /* Also set the parent value.  This is needed when trying to
2486          assign a new value (in inferior memory).  */
2487       set_value_parent (v, obj);
2488     }
2489   else
2490     set_value_bitsize (v, bit_size);
2491   unpacked = value_contents_writeable (v);
2492
2493   if (bit_size == 0)
2494     {
2495       memset (unpacked, 0, TYPE_LENGTH (type));
2496       return v;
2497     }
2498
2499   if (staging.size () == TYPE_LENGTH (type))
2500     {
2501       /* Small short-cut: If we've unpacked the data into a buffer
2502          of the same size as TYPE's length, then we can reuse that,
2503          instead of doing the unpacking again.  */
2504       memcpy (unpacked, staging.data (), staging.size ());
2505     }
2506   else
2507     ada_unpack_from_contents (src, bit_offset, bit_size,
2508                               unpacked, TYPE_LENGTH (type),
2509                               is_big_endian, has_negatives (type), is_scalar);
2510
2511   return v;
2512 }
2513
2514 /* Store the contents of FROMVAL into the location of TOVAL.
2515    Return a new value with the location of TOVAL and contents of
2516    FROMVAL.   Handles assignment into packed fields that have
2517    floating-point or non-scalar types.  */
2518
2519 static struct value *
2520 ada_value_assign (struct value *toval, struct value *fromval)
2521 {
2522   struct type *type = value_type (toval);
2523   int bits = value_bitsize (toval);
2524
2525   toval = ada_coerce_ref (toval);
2526   fromval = ada_coerce_ref (fromval);
2527
2528   if (ada_is_direct_array_type (value_type (toval)))
2529     toval = ada_coerce_to_simple_array (toval);
2530   if (ada_is_direct_array_type (value_type (fromval)))
2531     fromval = ada_coerce_to_simple_array (fromval);
2532
2533   if (!deprecated_value_modifiable (toval))
2534     error (_("Left operand of assignment is not a modifiable lvalue."));
2535
2536   if (VALUE_LVAL (toval) == lval_memory
2537       && bits > 0
2538       && (type->code () == TYPE_CODE_FLT
2539           || type->code () == TYPE_CODE_STRUCT))
2540     {
2541       int len = (value_bitpos (toval)
2542                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2543       int from_size;
2544       gdb_byte *buffer = (gdb_byte *) alloca (len);
2545       struct value *val;
2546       CORE_ADDR to_addr = value_address (toval);
2547
2548       if (type->code () == TYPE_CODE_FLT)
2549         fromval = value_cast (type, fromval);
2550
2551       read_memory (to_addr, buffer, len);
2552       from_size = value_bitsize (fromval);
2553       if (from_size == 0)
2554         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2555
2556       const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2557       ULONGEST from_offset = 0;
2558       if (is_big_endian && is_scalar_type (value_type (fromval)))
2559         from_offset = from_size - bits;
2560       copy_bitwise (buffer, value_bitpos (toval),
2561                     value_contents (fromval), from_offset,
2562                     bits, is_big_endian);
2563       write_memory_with_notification (to_addr, buffer, len);
2564
2565       val = value_copy (toval);
2566       memcpy (value_contents_raw (val), value_contents (fromval),
2567               TYPE_LENGTH (type));
2568       deprecated_set_value_type (val, type);
2569
2570       return val;
2571     }
2572
2573   return value_assign (toval, fromval);
2574 }
2575
2576
2577 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2578    CONTAINER, assign the contents of VAL to COMPONENTS's place in
2579    CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2580    COMPONENT, and not the inferior's memory.  The current contents
2581    of COMPONENT are ignored.
2582
2583    Although not part of the initial design, this function also works
2584    when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2585    had a null address, and COMPONENT had an address which is equal to
2586    its offset inside CONTAINER.  */
2587
2588 static void
2589 value_assign_to_component (struct value *container, struct value *component,
2590                            struct value *val)
2591 {
2592   LONGEST offset_in_container =
2593     (LONGEST)  (value_address (component) - value_address (container));
2594   int bit_offset_in_container =
2595     value_bitpos (component) - value_bitpos (container);
2596   int bits;
2597
2598   val = value_cast (value_type (component), val);
2599
2600   if (value_bitsize (component) == 0)
2601     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2602   else
2603     bits = value_bitsize (component);
2604
2605   if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2606     {
2607       int src_offset;
2608
2609       if (is_scalar_type (check_typedef (value_type (component))))
2610         src_offset
2611           = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2612       else
2613         src_offset = 0;
2614       copy_bitwise (value_contents_writeable (container) + offset_in_container,
2615                     value_bitpos (container) + bit_offset_in_container,
2616                     value_contents (val), src_offset, bits, 1);
2617     }
2618   else
2619     copy_bitwise (value_contents_writeable (container) + offset_in_container,
2620                   value_bitpos (container) + bit_offset_in_container,
2621                   value_contents (val), 0, bits, 0);
2622 }
2623
2624 /* Determine if TYPE is an access to an unconstrained array.  */
2625
2626 bool
2627 ada_is_access_to_unconstrained_array (struct type *type)
2628 {
2629   return (type->code () == TYPE_CODE_TYPEDEF
2630           && is_thick_pntr (ada_typedef_target_type (type)));
2631 }
2632
2633 /* The value of the element of array ARR at the ARITY indices given in IND.
2634    ARR may be either a simple array, GNAT array descriptor, or pointer
2635    thereto.  */
2636
2637 struct value *
2638 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2639 {
2640   int k;
2641   struct value *elt;
2642   struct type *elt_type;
2643
2644   elt = ada_coerce_to_simple_array (arr);
2645
2646   elt_type = ada_check_typedef (value_type (elt));
2647   if (elt_type->code () == TYPE_CODE_ARRAY
2648       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2649     return value_subscript_packed (elt, arity, ind);
2650
2651   for (k = 0; k < arity; k += 1)
2652     {
2653       struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
2654
2655       if (elt_type->code () != TYPE_CODE_ARRAY)
2656         error (_("too many subscripts (%d expected)"), k);
2657
2658       elt = value_subscript (elt, pos_atr (ind[k]));
2659
2660       if (ada_is_access_to_unconstrained_array (saved_elt_type)
2661           && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
2662         {
2663           /* The element is a typedef to an unconstrained array,
2664              except that the value_subscript call stripped the
2665              typedef layer.  The typedef layer is GNAT's way to
2666              specify that the element is, at the source level, an
2667              access to the unconstrained array, rather than the
2668              unconstrained array.  So, we need to restore that
2669              typedef layer, which we can do by forcing the element's
2670              type back to its original type. Otherwise, the returned
2671              value is going to be printed as the array, rather
2672              than as an access.  Another symptom of the same issue
2673              would be that an expression trying to dereference the
2674              element would also be improperly rejected.  */
2675           deprecated_set_value_type (elt, saved_elt_type);
2676         }
2677
2678       elt_type = ada_check_typedef (value_type (elt));
2679     }
2680
2681   return elt;
2682 }
2683
2684 /* Assuming ARR is a pointer to a GDB array, the value of the element
2685    of *ARR at the ARITY indices given in IND.
2686    Does not read the entire array into memory.
2687
2688    Note: Unlike what one would expect, this function is used instead of
2689    ada_value_subscript for basically all non-packed array types.  The reason
2690    for this is that a side effect of doing our own pointer arithmetics instead
2691    of relying on value_subscript is that there is no implicit typedef peeling.
2692    This is important for arrays of array accesses, where it allows us to
2693    preserve the fact that the array's element is an array access, where the
2694    access part os encoded in a typedef layer.  */
2695
2696 static struct value *
2697 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2698 {
2699   int k;
2700   struct value *array_ind = ada_value_ind (arr);
2701   struct type *type
2702     = check_typedef (value_enclosing_type (array_ind));
2703
2704   if (type->code () == TYPE_CODE_ARRAY
2705       && TYPE_FIELD_BITSIZE (type, 0) > 0)
2706     return value_subscript_packed (array_ind, arity, ind);
2707
2708   for (k = 0; k < arity; k += 1)
2709     {
2710       LONGEST lwb, upb;
2711
2712       if (type->code () != TYPE_CODE_ARRAY)
2713         error (_("too many subscripts (%d expected)"), k);
2714       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2715                         value_copy (arr));
2716       get_discrete_bounds (type->index_type (), &lwb, &upb);
2717       arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
2718       type = TYPE_TARGET_TYPE (type);
2719     }
2720
2721   return value_ind (arr);
2722 }
2723
2724 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2725    actual type of ARRAY_PTR is ignored), returns the Ada slice of
2726    HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
2727    this array is LOW, as per Ada rules.  */
2728 static struct value *
2729 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2730                           int low, int high)
2731 {
2732   struct type *type0 = ada_check_typedef (type);
2733   struct type *base_index_type = TYPE_TARGET_TYPE (type0->index_type ());
2734   struct type *index_type
2735     = create_static_range_type (NULL, base_index_type, low, high);
2736   struct type *slice_type = create_array_type_with_stride
2737                               (NULL, TYPE_TARGET_TYPE (type0), index_type,
2738                                type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
2739                                TYPE_FIELD_BITSIZE (type0, 0));
2740   int base_low =  ada_discrete_type_low_bound (type0->index_type ());
2741   gdb::optional<LONGEST> base_low_pos, low_pos;
2742   CORE_ADDR base;
2743
2744   low_pos = discrete_position (base_index_type, low);
2745   base_low_pos = discrete_position (base_index_type, base_low);
2746
2747   if (!low_pos.has_value () || !base_low_pos.has_value ())
2748     {
2749       warning (_("unable to get positions in slice, use bounds instead"));
2750       low_pos = low;
2751       base_low_pos = base_low;
2752     }
2753
2754   ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
2755   if (stride == 0)
2756     stride = TYPE_LENGTH (TYPE_TARGET_TYPE (type0));
2757
2758   base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
2759   return value_at_lazy (slice_type, base);
2760 }
2761
2762
2763 static struct value *
2764 ada_value_slice (struct value *array, int low, int high)
2765 {
2766   struct type *type = ada_check_typedef (value_type (array));
2767   struct type *base_index_type = TYPE_TARGET_TYPE (type->index_type ());
2768   struct type *index_type
2769     = create_static_range_type (NULL, type->index_type (), low, high);
2770   struct type *slice_type = create_array_type_with_stride
2771                               (NULL, TYPE_TARGET_TYPE (type), index_type,
2772                                type->dyn_prop (DYN_PROP_BYTE_STRIDE),
2773                                TYPE_FIELD_BITSIZE (type, 0));
2774   gdb::optional<LONGEST> low_pos, high_pos;
2775
2776
2777   low_pos = discrete_position (base_index_type, low);
2778   high_pos = discrete_position (base_index_type, high);
2779
2780   if (!low_pos.has_value () || !high_pos.has_value ())
2781     {
2782       warning (_("unable to get positions in slice, use bounds instead"));
2783       low_pos = low;
2784       high_pos = high;
2785     }
2786
2787   return value_cast (slice_type,
2788                      value_slice (array, low, *high_pos - *low_pos + 1));
2789 }
2790
2791 /* If type is a record type in the form of a standard GNAT array
2792    descriptor, returns the number of dimensions for type.  If arr is a
2793    simple array, returns the number of "array of"s that prefix its
2794    type designation.  Otherwise, returns 0.  */
2795
2796 int
2797 ada_array_arity (struct type *type)
2798 {
2799   int arity;
2800
2801   if (type == NULL)
2802     return 0;
2803
2804   type = desc_base_type (type);
2805
2806   arity = 0;
2807   if (type->code () == TYPE_CODE_STRUCT)
2808     return desc_arity (desc_bounds_type (type));
2809   else
2810     while (type->code () == TYPE_CODE_ARRAY)
2811       {
2812         arity += 1;
2813         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2814       }
2815
2816   return arity;
2817 }
2818
2819 /* If TYPE is a record type in the form of a standard GNAT array
2820    descriptor or a simple array type, returns the element type for
2821    TYPE after indexing by NINDICES indices, or by all indices if
2822    NINDICES is -1.  Otherwise, returns NULL.  */
2823
2824 struct type *
2825 ada_array_element_type (struct type *type, int nindices)
2826 {
2827   type = desc_base_type (type);
2828
2829   if (type->code () == TYPE_CODE_STRUCT)
2830     {
2831       int k;
2832       struct type *p_array_type;
2833
2834       p_array_type = desc_data_target_type (type);
2835
2836       k = ada_array_arity (type);
2837       if (k == 0)
2838         return NULL;
2839
2840       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
2841       if (nindices >= 0 && k > nindices)
2842         k = nindices;
2843       while (k > 0 && p_array_type != NULL)
2844         {
2845           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2846           k -= 1;
2847         }
2848       return p_array_type;
2849     }
2850   else if (type->code () == TYPE_CODE_ARRAY)
2851     {
2852       while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
2853         {
2854           type = TYPE_TARGET_TYPE (type);
2855           nindices -= 1;
2856         }
2857       return type;
2858     }
2859
2860   return NULL;
2861 }
2862
2863 /* See ada-lang.h.  */
2864
2865 struct type *
2866 ada_index_type (struct type *type, int n, const char *name)
2867 {
2868   struct type *result_type;
2869
2870   type = desc_base_type (type);
2871
2872   if (n < 0 || n > ada_array_arity (type))
2873     error (_("invalid dimension number to '%s"), name);
2874
2875   if (ada_is_simple_array_type (type))
2876     {
2877       int i;
2878
2879       for (i = 1; i < n; i += 1)
2880         type = TYPE_TARGET_TYPE (type);
2881       result_type = TYPE_TARGET_TYPE (type->index_type ());
2882       /* FIXME: The stabs type r(0,0);bound;bound in an array type
2883          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
2884          perhaps stabsread.c would make more sense.  */
2885       if (result_type && result_type->code () == TYPE_CODE_UNDEF)
2886         result_type = NULL;
2887     }
2888   else
2889     {
2890       result_type = desc_index_type (desc_bounds_type (type), n);
2891       if (result_type == NULL)
2892         error (_("attempt to take bound of something that is not an array"));
2893     }
2894
2895   return result_type;
2896 }
2897
2898 /* Given that arr is an array type, returns the lower bound of the
2899    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2900    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
2901    array-descriptor type.  It works for other arrays with bounds supplied
2902    by run-time quantities other than discriminants.  */
2903
2904 static LONGEST
2905 ada_array_bound_from_type (struct type *arr_type, int n, int which)
2906 {
2907   struct type *type, *index_type_desc, *index_type;
2908   int i;
2909
2910   gdb_assert (which == 0 || which == 1);
2911
2912   if (ada_is_constrained_packed_array_type (arr_type))
2913     arr_type = decode_constrained_packed_array_type (arr_type);
2914
2915   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2916     return (LONGEST) - which;
2917
2918   if (arr_type->code () == TYPE_CODE_PTR)
2919     type = TYPE_TARGET_TYPE (arr_type);
2920   else
2921     type = arr_type;
2922
2923   if (type->is_fixed_instance ())
2924     {
2925       /* The array has already been fixed, so we do not need to
2926          check the parallel ___XA type again.  That encoding has
2927          already been applied, so ignore it now.  */
2928       index_type_desc = NULL;
2929     }
2930   else
2931     {
2932       index_type_desc = ada_find_parallel_type (type, "___XA");
2933       ada_fixup_array_indexes_type (index_type_desc);
2934     }
2935
2936   if (index_type_desc != NULL)
2937     index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
2938                                       NULL);
2939   else
2940     {
2941       struct type *elt_type = check_typedef (type);
2942
2943       for (i = 1; i < n; i++)
2944         elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
2945
2946       index_type = elt_type->index_type ();
2947     }
2948
2949   return
2950     (LONGEST) (which == 0
2951                ? ada_discrete_type_low_bound (index_type)
2952                : ada_discrete_type_high_bound (index_type));
2953 }
2954
2955 /* Given that arr is an array value, returns the lower bound of the
2956    nth index (numbering from 1) if WHICH is 0, and the upper bound if
2957    WHICH is 1.  This routine will also work for arrays with bounds
2958    supplied by run-time quantities other than discriminants.  */
2959
2960 static LONGEST
2961 ada_array_bound (struct value *arr, int n, int which)
2962 {
2963   struct type *arr_type;
2964
2965   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2966     arr = value_ind (arr);
2967   arr_type = value_enclosing_type (arr);
2968
2969   if (ada_is_constrained_packed_array_type (arr_type))
2970     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
2971   else if (ada_is_simple_array_type (arr_type))
2972     return ada_array_bound_from_type (arr_type, n, which);
2973   else
2974     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
2975 }
2976
2977 /* Given that arr is an array value, returns the length of the
2978    nth index.  This routine will also work for arrays with bounds
2979    supplied by run-time quantities other than discriminants.
2980    Does not work for arrays indexed by enumeration types with representation
2981    clauses at the moment.  */
2982
2983 static LONGEST
2984 ada_array_length (struct value *arr, int n)
2985 {
2986   struct type *arr_type, *index_type;
2987   int low, high;
2988
2989   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2990     arr = value_ind (arr);
2991   arr_type = value_enclosing_type (arr);
2992
2993   if (ada_is_constrained_packed_array_type (arr_type))
2994     return ada_array_length (decode_constrained_packed_array (arr), n);
2995
2996   if (ada_is_simple_array_type (arr_type))
2997     {
2998       low = ada_array_bound_from_type (arr_type, n, 0);
2999       high = ada_array_bound_from_type (arr_type, n, 1);
3000     }
3001   else
3002     {
3003       low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3004       high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3005     }
3006
3007   arr_type = check_typedef (arr_type);
3008   index_type = ada_index_type (arr_type, n, "length");
3009   if (index_type != NULL)
3010     {
3011       struct type *base_type;
3012       if (index_type->code () == TYPE_CODE_RANGE)
3013         base_type = TYPE_TARGET_TYPE (index_type);
3014       else
3015         base_type = index_type;
3016
3017       low = pos_atr (value_from_longest (base_type, low));
3018       high = pos_atr (value_from_longest (base_type, high));
3019     }
3020   return high - low + 1;
3021 }
3022
3023 /* An array whose type is that of ARR_TYPE (an array type), with
3024    bounds LOW to HIGH, but whose contents are unimportant.  If HIGH is
3025    less than LOW, then LOW-1 is used.  */
3026
3027 static struct value *
3028 empty_array (struct type *arr_type, int low, int high)
3029 {
3030   struct type *arr_type0 = ada_check_typedef (arr_type);
3031   struct type *index_type
3032     = create_static_range_type
3033         (NULL, TYPE_TARGET_TYPE (arr_type0->index_type ()), low,
3034          high < low ? low - 1 : high);
3035   struct type *elt_type = ada_array_element_type (arr_type0, 1);
3036
3037   return allocate_value (create_array_type (NULL, elt_type, index_type));
3038 }
3039 \f
3040
3041                                 /* Name resolution */
3042
3043 /* The "decoded" name for the user-definable Ada operator corresponding
3044    to OP.  */
3045
3046 static const char *
3047 ada_decoded_op_name (enum exp_opcode op)
3048 {
3049   int i;
3050
3051   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3052     {
3053       if (ada_opname_table[i].op == op)
3054         return ada_opname_table[i].decoded;
3055     }
3056   error (_("Could not find operator name for opcode"));
3057 }
3058
3059 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3060    in a listing of choices during disambiguation (see sort_choices, below).
3061    The idea is that overloadings of a subprogram name from the
3062    same package should sort in their source order.  We settle for ordering
3063    such symbols by their trailing number (__N  or $N).  */
3064
3065 static int
3066 encoded_ordered_before (const char *N0, const char *N1)
3067 {
3068   if (N1 == NULL)
3069     return 0;
3070   else if (N0 == NULL)
3071     return 1;
3072   else
3073     {
3074       int k0, k1;
3075
3076       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3077         ;
3078       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3079         ;
3080       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3081           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3082         {
3083           int n0, n1;
3084
3085           n0 = k0;
3086           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3087             n0 -= 1;
3088           n1 = k1;
3089           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3090             n1 -= 1;
3091           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3092             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3093         }
3094       return (strcmp (N0, N1) < 0);
3095     }
3096 }
3097
3098 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3099    encoded names.  */
3100
3101 static void
3102 sort_choices (struct block_symbol syms[], int nsyms)
3103 {
3104   int i;
3105
3106   for (i = 1; i < nsyms; i += 1)
3107     {
3108       struct block_symbol sym = syms[i];
3109       int j;
3110
3111       for (j = i - 1; j >= 0; j -= 1)
3112         {
3113           if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3114                                       sym.symbol->linkage_name ()))
3115             break;
3116           syms[j + 1] = syms[j];
3117         }
3118       syms[j + 1] = sym;
3119     }
3120 }
3121
3122 /* Whether GDB should display formals and return types for functions in the
3123    overloads selection menu.  */
3124 static bool print_signatures = true;
3125
3126 /* Print the signature for SYM on STREAM according to the FLAGS options.  For
3127    all but functions, the signature is just the name of the symbol.  For
3128    functions, this is the name of the function, the list of types for formals
3129    and the return type (if any).  */
3130
3131 static void
3132 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3133                             const struct type_print_options *flags)
3134 {
3135   struct type *type = SYMBOL_TYPE (sym);
3136
3137   fprintf_filtered (stream, "%s", sym->print_name ());
3138   if (!print_signatures
3139       || type == NULL
3140       || type->code () != TYPE_CODE_FUNC)
3141     return;
3142
3143   if (type->num_fields () > 0)
3144     {
3145       int i;
3146
3147       fprintf_filtered (stream, " (");
3148       for (i = 0; i < type->num_fields (); ++i)
3149         {
3150           if (i > 0)
3151             fprintf_filtered (stream, "; ");
3152           ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3153                           flags);
3154         }
3155       fprintf_filtered (stream, ")");
3156     }
3157   if (TYPE_TARGET_TYPE (type) != NULL
3158       && TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_VOID)
3159     {
3160       fprintf_filtered (stream, " return ");
3161       ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3162     }
3163 }
3164
3165 /* Read and validate a set of numeric choices from the user in the
3166    range 0 .. N_CHOICES-1.  Place the results in increasing
3167    order in CHOICES[0 .. N-1], and return N.
3168
3169    The user types choices as a sequence of numbers on one line
3170    separated by blanks, encoding them as follows:
3171
3172      + A choice of 0 means to cancel the selection, throwing an error.
3173      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3174      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3175
3176    The user is not allowed to choose more than MAX_RESULTS values.
3177
3178    ANNOTATION_SUFFIX, if present, is used to annotate the input
3179    prompts (for use with the -f switch).  */
3180
3181 static int
3182 get_selections (int *choices, int n_choices, int max_results,
3183                 int is_all_choice, const char *annotation_suffix)
3184 {
3185   const char *args;
3186   const char *prompt;
3187   int n_chosen;
3188   int first_choice = is_all_choice ? 2 : 1;
3189
3190   prompt = getenv ("PS2");
3191   if (prompt == NULL)
3192     prompt = "> ";
3193
3194   args = command_line_input (prompt, annotation_suffix);
3195
3196   if (args == NULL)
3197     error_no_arg (_("one or more choice numbers"));
3198
3199   n_chosen = 0;
3200
3201   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3202      order, as given in args.  Choices are validated.  */
3203   while (1)
3204     {
3205       char *args2;
3206       int choice, j;
3207
3208       args = skip_spaces (args);
3209       if (*args == '\0' && n_chosen == 0)
3210         error_no_arg (_("one or more choice numbers"));
3211       else if (*args == '\0')
3212         break;
3213
3214       choice = strtol (args, &args2, 10);
3215       if (args == args2 || choice < 0
3216           || choice > n_choices + first_choice - 1)
3217         error (_("Argument must be choice number"));
3218       args = args2;
3219
3220       if (choice == 0)
3221         error (_("cancelled"));
3222
3223       if (choice < first_choice)
3224         {
3225           n_chosen = n_choices;
3226           for (j = 0; j < n_choices; j += 1)
3227             choices[j] = j;
3228           break;
3229         }
3230       choice -= first_choice;
3231
3232       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3233         {
3234         }
3235
3236       if (j < 0 || choice != choices[j])
3237         {
3238           int k;
3239
3240           for (k = n_chosen - 1; k > j; k -= 1)
3241             choices[k + 1] = choices[k];
3242           choices[j + 1] = choice;
3243           n_chosen += 1;
3244         }
3245     }
3246
3247   if (n_chosen > max_results)
3248     error (_("Select no more than %d of the above"), max_results);
3249
3250   return n_chosen;
3251 }
3252
3253 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3254    by asking the user (if necessary), returning the number selected,
3255    and setting the first elements of SYMS items.  Error if no symbols
3256    selected.  */
3257
3258 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3259    to be re-integrated one of these days.  */
3260
3261 static int
3262 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3263 {
3264   int i;
3265   int *chosen = XALLOCAVEC (int , nsyms);
3266   int n_chosen;
3267   int first_choice = (max_results == 1) ? 1 : 2;
3268   const char *select_mode = multiple_symbols_select_mode ();
3269
3270   if (max_results < 1)
3271     error (_("Request to select 0 symbols!"));
3272   if (nsyms <= 1)
3273     return nsyms;
3274
3275   if (select_mode == multiple_symbols_cancel)
3276     error (_("\
3277 canceled because the command is ambiguous\n\
3278 See set/show multiple-symbol."));
3279
3280   /* If select_mode is "all", then return all possible symbols.
3281      Only do that if more than one symbol can be selected, of course.
3282      Otherwise, display the menu as usual.  */
3283   if (select_mode == multiple_symbols_all && max_results > 1)
3284     return nsyms;
3285
3286   printf_filtered (_("[0] cancel\n"));
3287   if (max_results > 1)
3288     printf_filtered (_("[1] all\n"));
3289
3290   sort_choices (syms, nsyms);
3291
3292   for (i = 0; i < nsyms; i += 1)
3293     {
3294       if (syms[i].symbol == NULL)
3295         continue;
3296
3297       if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
3298         {
3299           struct symtab_and_line sal =
3300             find_function_start_sal (syms[i].symbol, 1);
3301
3302           printf_filtered ("[%d] ", i + first_choice);
3303           ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3304                                       &type_print_raw_options);
3305           if (sal.symtab == NULL)
3306             printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3307                              metadata_style.style ().ptr (), nullptr, sal.line);
3308           else
3309             printf_filtered
3310               (_(" at %ps:%d\n"),
3311                styled_string (file_name_style.style (),
3312                               symtab_to_filename_for_display (sal.symtab)),
3313                sal.line);
3314           continue;
3315         }
3316       else
3317         {
3318           int is_enumeral =
3319             (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3320              && SYMBOL_TYPE (syms[i].symbol) != NULL
3321              && SYMBOL_TYPE (syms[i].symbol)->code () == TYPE_CODE_ENUM);
3322           struct symtab *symtab = NULL;
3323
3324           if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3325             symtab = symbol_symtab (syms[i].symbol);
3326
3327           if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
3328             {
3329               printf_filtered ("[%d] ", i + first_choice);
3330               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3331                                           &type_print_raw_options);
3332               printf_filtered (_(" at %s:%d\n"),
3333                                symtab_to_filename_for_display (symtab),
3334                                SYMBOL_LINE (syms[i].symbol));
3335             }
3336           else if (is_enumeral
3337                    && SYMBOL_TYPE (syms[i].symbol)->name () != NULL)
3338             {
3339               printf_filtered (("[%d] "), i + first_choice);
3340               ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
3341                               gdb_stdout, -1, 0, &type_print_raw_options);
3342               printf_filtered (_("'(%s) (enumeral)\n"),
3343                                syms[i].symbol->print_name ());
3344             }
3345           else
3346             {
3347               printf_filtered ("[%d] ", i + first_choice);
3348               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3349                                           &type_print_raw_options);
3350
3351               if (symtab != NULL)
3352                 printf_filtered (is_enumeral
3353                                  ? _(" in %s (enumeral)\n")
3354                                  : _(" at %s:?\n"),
3355                                  symtab_to_filename_for_display (symtab));
3356               else
3357                 printf_filtered (is_enumeral
3358                                  ? _(" (enumeral)\n")
3359                                  : _(" at ?\n"));
3360             }
3361         }
3362     }
3363
3364   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3365                              "overload-choice");
3366
3367   for (i = 0; i < n_chosen; i += 1)
3368     syms[i] = syms[chosen[i]];
3369
3370   return n_chosen;
3371 }
3372
3373 /* See ada-lang.h.  */
3374
3375 block_symbol
3376 ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
3377                           int nargs, value *argvec[])
3378 {
3379   if (possible_user_operator_p (op, argvec))
3380     {
3381       std::vector<struct block_symbol> candidates
3382         = ada_lookup_symbol_list (ada_decoded_op_name (op),
3383                                   NULL, VAR_DOMAIN);
3384
3385       int i = ada_resolve_function (candidates, argvec,
3386                                     nargs, ada_decoded_op_name (op), NULL,
3387                                     parse_completion);
3388       if (i >= 0)
3389         return candidates[i];
3390     }
3391   return {};
3392 }
3393
3394 /* See ada-lang.h.  */
3395
3396 block_symbol
3397 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3398                      struct type *context_type,
3399                      bool parse_completion,
3400                      int nargs, value *argvec[],
3401                      innermost_block_tracker *tracker)
3402 {
3403   std::vector<struct block_symbol> candidates
3404     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3405
3406   int i;
3407   if (candidates.size () == 1)
3408     i = 0;
3409   else
3410     {
3411       i = ada_resolve_function
3412         (candidates,
3413          argvec, nargs,
3414          sym->linkage_name (),
3415          context_type, parse_completion);
3416       if (i < 0)
3417         error (_("Could not find a match for %s"), sym->print_name ());
3418     }
3419
3420   tracker->update (candidates[i]);
3421   return candidates[i];
3422 }
3423
3424 /* See ada-lang.h.  */
3425
3426 block_symbol
3427 ada_resolve_variable (struct symbol *sym, const struct block *block,
3428                       struct type *context_type,
3429                       bool parse_completion,
3430                       int deprocedure_p,
3431                       innermost_block_tracker *tracker)
3432 {
3433   std::vector<struct block_symbol> candidates
3434     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3435
3436   if (std::any_of (candidates.begin (),
3437                    candidates.end (),
3438                    [] (block_symbol &bsym)
3439                    {
3440                      switch (SYMBOL_CLASS (bsym.symbol))
3441                        {
3442                        case LOC_REGISTER:
3443                        case LOC_ARG:
3444                        case LOC_REF_ARG:
3445                        case LOC_REGPARM_ADDR:
3446                        case LOC_LOCAL:
3447                        case LOC_COMPUTED:
3448                          return true;
3449                        default:
3450                          return false;
3451                        }
3452                    }))
3453     {
3454       /* Types tend to get re-introduced locally, so if there
3455          are any local symbols that are not types, first filter
3456          out all types.  */
3457       candidates.erase
3458         (std::remove_if
3459          (candidates.begin (),
3460           candidates.end (),
3461           [] (block_symbol &bsym)
3462           {
3463             return SYMBOL_CLASS (bsym.symbol) == LOC_TYPEDEF;
3464           }),
3465          candidates.end ());
3466     }
3467
3468   int i;
3469   if (candidates.empty ())
3470     error (_("No definition found for %s"), sym->print_name ());
3471   else if (candidates.size () == 1)
3472     i = 0;
3473   else if (deprocedure_p && !is_nonfunction (candidates))
3474     {
3475       i = ada_resolve_function
3476         (candidates, NULL, 0,
3477          sym->linkage_name (),
3478          context_type, parse_completion);
3479       if (i < 0)
3480         error (_("Could not find a match for %s"), sym->print_name ());
3481     }
3482   else
3483     {
3484       printf_filtered (_("Multiple matches for %s\n"), sym->print_name ());
3485       user_select_syms (candidates.data (), candidates.size (), 1);
3486       i = 0;
3487     }
3488
3489   tracker->update (candidates[i]);
3490   return candidates[i];
3491 }
3492
3493 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  */
3494 /* The term "match" here is rather loose.  The match is heuristic and
3495    liberal.  */
3496
3497 static int
3498 ada_type_match (struct type *ftype, struct type *atype)
3499 {
3500   ftype = ada_check_typedef (ftype);
3501   atype = ada_check_typedef (atype);
3502
3503   if (ftype->code () == TYPE_CODE_REF)
3504     ftype = TYPE_TARGET_TYPE (ftype);
3505   if (atype->code () == TYPE_CODE_REF)
3506     atype = TYPE_TARGET_TYPE (atype);
3507
3508   switch (ftype->code ())
3509     {
3510     default:
3511       return ftype->code () == atype->code ();
3512     case TYPE_CODE_PTR:
3513       if (atype->code () != TYPE_CODE_PTR)
3514         return 0;
3515       atype = TYPE_TARGET_TYPE (atype);
3516       /* This can only happen if the actual argument is 'null'.  */
3517       if (atype->code () == TYPE_CODE_INT && TYPE_LENGTH (atype) == 0)
3518         return 1;
3519       return ada_type_match (TYPE_TARGET_TYPE (ftype), atype);
3520     case TYPE_CODE_INT:
3521     case TYPE_CODE_ENUM:
3522     case TYPE_CODE_RANGE:
3523       switch (atype->code ())
3524         {
3525         case TYPE_CODE_INT:
3526         case TYPE_CODE_ENUM:
3527         case TYPE_CODE_RANGE:
3528           return 1;
3529         default:
3530           return 0;
3531         }
3532
3533     case TYPE_CODE_ARRAY:
3534       return (atype->code () == TYPE_CODE_ARRAY
3535               || ada_is_array_descriptor_type (atype));
3536
3537     case TYPE_CODE_STRUCT:
3538       if (ada_is_array_descriptor_type (ftype))
3539         return (atype->code () == TYPE_CODE_ARRAY
3540                 || ada_is_array_descriptor_type (atype));
3541       else
3542         return (atype->code () == TYPE_CODE_STRUCT
3543                 && !ada_is_array_descriptor_type (atype));
3544
3545     case TYPE_CODE_UNION:
3546     case TYPE_CODE_FLT:
3547       return (atype->code () == ftype->code ());
3548     }
3549 }
3550
3551 /* Return non-zero if the formals of FUNC "sufficiently match" the
3552    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3553    may also be an enumeral, in which case it is treated as a 0-
3554    argument function.  */
3555
3556 static int
3557 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3558 {
3559   int i;
3560   struct type *func_type = SYMBOL_TYPE (func);
3561
3562   if (SYMBOL_CLASS (func) == LOC_CONST
3563       && func_type->code () == TYPE_CODE_ENUM)
3564     return (n_actuals == 0);
3565   else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3566     return 0;
3567
3568   if (func_type->num_fields () != n_actuals)
3569     return 0;
3570
3571   for (i = 0; i < n_actuals; i += 1)
3572     {
3573       if (actuals[i] == NULL)
3574         return 0;
3575       else
3576         {
3577           struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3578           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3579
3580           if (!ada_type_match (ftype, atype))
3581             return 0;
3582         }
3583     }
3584   return 1;
3585 }
3586
3587 /* False iff function type FUNC_TYPE definitely does not produce a value
3588    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3589    FUNC_TYPE is not a valid function type with a non-null return type
3590    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3591
3592 static int
3593 return_match (struct type *func_type, struct type *context_type)
3594 {
3595   struct type *return_type;
3596
3597   if (func_type == NULL)
3598     return 1;
3599
3600   if (func_type->code () == TYPE_CODE_FUNC)
3601     return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3602   else
3603     return_type = get_base_type (func_type);
3604   if (return_type == NULL)
3605     return 1;
3606
3607   context_type = get_base_type (context_type);
3608
3609   if (return_type->code () == TYPE_CODE_ENUM)
3610     return context_type == NULL || return_type == context_type;
3611   else if (context_type == NULL)
3612     return return_type->code () != TYPE_CODE_VOID;
3613   else
3614     return return_type->code () == context_type->code ();
3615 }
3616
3617
3618 /* Returns the index in SYMS that contains the symbol for the
3619    function (if any) that matches the types of the NARGS arguments in
3620    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
3621    that returns that type, then eliminate matches that don't.  If
3622    CONTEXT_TYPE is void and there is at least one match that does not
3623    return void, eliminate all matches that do.
3624
3625    Asks the user if there is more than one match remaining.  Returns -1
3626    if there is no such symbol or none is selected.  NAME is used
3627    solely for messages.  May re-arrange and modify SYMS in
3628    the process; the index returned is for the modified vector.  */
3629
3630 static int
3631 ada_resolve_function (std::vector<struct block_symbol> &syms,
3632                       struct value **args, int nargs,
3633                       const char *name, struct type *context_type,
3634                       bool parse_completion)
3635 {
3636   int fallback;
3637   int k;
3638   int m;                        /* Number of hits */
3639
3640   m = 0;
3641   /* In the first pass of the loop, we only accept functions matching
3642      context_type.  If none are found, we add a second pass of the loop
3643      where every function is accepted.  */
3644   for (fallback = 0; m == 0 && fallback < 2; fallback++)
3645     {
3646       for (k = 0; k < syms.size (); k += 1)
3647         {
3648           struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
3649
3650           if (ada_args_match (syms[k].symbol, args, nargs)
3651               && (fallback || return_match (type, context_type)))
3652             {
3653               syms[m] = syms[k];
3654               m += 1;
3655             }
3656         }
3657     }
3658
3659   /* If we got multiple matches, ask the user which one to use.  Don't do this
3660      interactive thing during completion, though, as the purpose of the
3661      completion is providing a list of all possible matches.  Prompting the
3662      user to filter it down would be completely unexpected in this case.  */
3663   if (m == 0)
3664     return -1;
3665   else if (m > 1 && !parse_completion)
3666     {
3667       printf_filtered (_("Multiple matches for %s\n"), name);
3668       user_select_syms (syms.data (), m, 1);
3669       return 0;
3670     }
3671   return 0;
3672 }
3673
3674 /* Type-class predicates */
3675
3676 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3677    or FLOAT).  */
3678
3679 static int
3680 numeric_type_p (struct type *type)
3681 {
3682   if (type == NULL)
3683     return 0;
3684   else
3685     {
3686       switch (type->code ())
3687         {
3688         case TYPE_CODE_INT:
3689         case TYPE_CODE_FLT:
3690         case TYPE_CODE_FIXED_POINT:
3691           return 1;
3692         case TYPE_CODE_RANGE:
3693           return (type == TYPE_TARGET_TYPE (type)
3694                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
3695         default:
3696           return 0;
3697         }
3698     }
3699 }
3700
3701 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
3702
3703 static int
3704 integer_type_p (struct type *type)
3705 {
3706   if (type == NULL)
3707     return 0;
3708   else
3709     {
3710       switch (type->code ())
3711         {
3712         case TYPE_CODE_INT:
3713           return 1;
3714         case TYPE_CODE_RANGE:
3715           return (type == TYPE_TARGET_TYPE (type)
3716                   || integer_type_p (TYPE_TARGET_TYPE (type)));
3717         default:
3718           return 0;
3719         }
3720     }
3721 }
3722
3723 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
3724
3725 static int
3726 scalar_type_p (struct type *type)
3727 {
3728   if (type == NULL)
3729     return 0;
3730   else
3731     {
3732       switch (type->code ())
3733         {
3734         case TYPE_CODE_INT:
3735         case TYPE_CODE_RANGE:
3736         case TYPE_CODE_ENUM:
3737         case TYPE_CODE_FLT:
3738         case TYPE_CODE_FIXED_POINT:
3739           return 1;
3740         default:
3741           return 0;
3742         }
3743     }
3744 }
3745
3746 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
3747
3748 static int
3749 discrete_type_p (struct type *type)
3750 {
3751   if (type == NULL)
3752     return 0;
3753   else
3754     {
3755       switch (type->code ())
3756         {
3757         case TYPE_CODE_INT:
3758         case TYPE_CODE_RANGE:
3759         case TYPE_CODE_ENUM:
3760         case TYPE_CODE_BOOL:
3761           return 1;
3762         default:
3763           return 0;
3764         }
3765     }
3766 }
3767
3768 /* Returns non-zero if OP with operands in the vector ARGS could be
3769    a user-defined function.  Errs on the side of pre-defined operators
3770    (i.e., result 0).  */
3771
3772 static int
3773 possible_user_operator_p (enum exp_opcode op, struct value *args[])
3774 {
3775   struct type *type0 =
3776     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
3777   struct type *type1 =
3778     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
3779
3780   if (type0 == NULL)
3781     return 0;
3782
3783   switch (op)
3784     {
3785     default:
3786       return 0;
3787
3788     case BINOP_ADD:
3789     case BINOP_SUB:
3790     case BINOP_MUL:
3791     case BINOP_DIV:
3792       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
3793
3794     case BINOP_REM:
3795     case BINOP_MOD:
3796     case BINOP_BITWISE_AND:
3797     case BINOP_BITWISE_IOR:
3798     case BINOP_BITWISE_XOR:
3799       return (!(integer_type_p (type0) && integer_type_p (type1)));
3800
3801     case BINOP_EQUAL:
3802     case BINOP_NOTEQUAL:
3803     case BINOP_LESS:
3804     case BINOP_GTR:
3805     case BINOP_LEQ:
3806     case BINOP_GEQ:
3807       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
3808
3809     case BINOP_CONCAT:
3810       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
3811
3812     case BINOP_EXP:
3813       return (!(numeric_type_p (type0) && integer_type_p (type1)));
3814
3815     case UNOP_NEG:
3816     case UNOP_PLUS:
3817     case UNOP_LOGICAL_NOT:
3818     case UNOP_ABS:
3819       return (!numeric_type_p (type0));
3820
3821     }
3822 }
3823 \f
3824                                 /* Renaming */
3825
3826 /* NOTES: 
3827
3828    1. In the following, we assume that a renaming type's name may
3829       have an ___XD suffix.  It would be nice if this went away at some
3830       point.
3831    2. We handle both the (old) purely type-based representation of 
3832       renamings and the (new) variable-based encoding.  At some point,
3833       it is devoutly to be hoped that the former goes away 
3834       (FIXME: hilfinger-2007-07-09).
3835    3. Subprogram renamings are not implemented, although the XRS
3836       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
3837
3838 /* If SYM encodes a renaming, 
3839
3840        <renaming> renames <renamed entity>,
3841
3842    sets *LEN to the length of the renamed entity's name,
3843    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3844    the string describing the subcomponent selected from the renamed
3845    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3846    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3847    are undefined).  Otherwise, returns a value indicating the category
3848    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3849    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3850    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
3851    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3852    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3853    may be NULL, in which case they are not assigned.
3854
3855    [Currently, however, GCC does not generate subprogram renamings.]  */
3856
3857 enum ada_renaming_category
3858 ada_parse_renaming (struct symbol *sym,
3859                     const char **renamed_entity, int *len, 
3860                     const char **renaming_expr)
3861 {
3862   enum ada_renaming_category kind;
3863   const char *info;
3864   const char *suffix;
3865
3866   if (sym == NULL)
3867     return ADA_NOT_RENAMING;
3868   switch (SYMBOL_CLASS (sym)) 
3869     {
3870     default:
3871       return ADA_NOT_RENAMING;
3872     case LOC_LOCAL:
3873     case LOC_STATIC:
3874     case LOC_COMPUTED:
3875     case LOC_OPTIMIZED_OUT:
3876       info = strstr (sym->linkage_name (), "___XR");
3877       if (info == NULL)
3878         return ADA_NOT_RENAMING;
3879       switch (info[5])
3880         {
3881         case '_':
3882           kind = ADA_OBJECT_RENAMING;
3883           info += 6;
3884           break;
3885         case 'E':
3886           kind = ADA_EXCEPTION_RENAMING;
3887           info += 7;
3888           break;
3889         case 'P':
3890           kind = ADA_PACKAGE_RENAMING;
3891           info += 7;
3892           break;
3893         case 'S':
3894           kind = ADA_SUBPROGRAM_RENAMING;
3895           info += 7;
3896           break;
3897         default:
3898           return ADA_NOT_RENAMING;
3899         }
3900     }
3901
3902   if (renamed_entity != NULL)
3903     *renamed_entity = info;
3904   suffix = strstr (info, "___XE");
3905   if (suffix == NULL || suffix == info)
3906     return ADA_NOT_RENAMING;
3907   if (len != NULL)
3908     *len = strlen (info) - strlen (suffix);
3909   suffix += 5;
3910   if (renaming_expr != NULL)
3911     *renaming_expr = suffix;
3912   return kind;
3913 }
3914
3915 /* Compute the value of the given RENAMING_SYM, which is expected to
3916    be a symbol encoding a renaming expression.  BLOCK is the block
3917    used to evaluate the renaming.  */
3918
3919 static struct value *
3920 ada_read_renaming_var_value (struct symbol *renaming_sym,
3921                              const struct block *block)
3922 {
3923   const char *sym_name;
3924
3925   sym_name = renaming_sym->linkage_name ();
3926   expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
3927   return evaluate_expression (expr.get ());
3928 }
3929 \f
3930
3931                                 /* Evaluation: Function Calls */
3932
3933 /* Return an lvalue containing the value VAL.  This is the identity on
3934    lvalues, and otherwise has the side-effect of allocating memory
3935    in the inferior where a copy of the value contents is copied.  */
3936
3937 static struct value *
3938 ensure_lval (struct value *val)
3939 {
3940   if (VALUE_LVAL (val) == not_lval
3941       || VALUE_LVAL (val) == lval_internalvar)
3942     {
3943       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
3944       const CORE_ADDR addr =
3945         value_as_long (value_allocate_space_in_inferior (len));
3946
3947       VALUE_LVAL (val) = lval_memory;
3948       set_value_address (val, addr);
3949       write_memory (addr, value_contents (val), len);
3950     }
3951
3952   return val;
3953 }
3954
3955 /* Given ARG, a value of type (pointer or reference to a)*
3956    structure/union, extract the component named NAME from the ultimate
3957    target structure/union and return it as a value with its
3958    appropriate type.
3959
3960    The routine searches for NAME among all members of the structure itself
3961    and (recursively) among all members of any wrapper members
3962    (e.g., '_parent').
3963
3964    If NO_ERR, then simply return NULL in case of error, rather than
3965    calling error.  */
3966
3967 static struct value *
3968 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
3969 {
3970   struct type *t, *t1;
3971   struct value *v;
3972   int check_tag;
3973
3974   v = NULL;
3975   t1 = t = ada_check_typedef (value_type (arg));
3976   if (t->code () == TYPE_CODE_REF)
3977     {
3978       t1 = TYPE_TARGET_TYPE (t);
3979       if (t1 == NULL)
3980         goto BadValue;
3981       t1 = ada_check_typedef (t1);
3982       if (t1->code () == TYPE_CODE_PTR)
3983         {
3984           arg = coerce_ref (arg);
3985           t = t1;
3986         }
3987     }
3988
3989   while (t->code () == TYPE_CODE_PTR)
3990     {
3991       t1 = TYPE_TARGET_TYPE (t);
3992       if (t1 == NULL)
3993         goto BadValue;
3994       t1 = ada_check_typedef (t1);
3995       if (t1->code () == TYPE_CODE_PTR)
3996         {
3997           arg = value_ind (arg);
3998           t = t1;
3999         }
4000       else
4001         break;
4002     }
4003
4004   if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4005     goto BadValue;
4006
4007   if (t1 == t)
4008     v = ada_search_struct_field (name, arg, 0, t);
4009   else
4010     {
4011       int bit_offset, bit_size, byte_offset;
4012       struct type *field_type;
4013       CORE_ADDR address;
4014
4015       if (t->code () == TYPE_CODE_PTR)
4016         address = value_address (ada_value_ind (arg));
4017       else
4018         address = value_address (ada_coerce_ref (arg));
4019
4020       /* Check to see if this is a tagged type.  We also need to handle
4021          the case where the type is a reference to a tagged type, but
4022          we have to be careful to exclude pointers to tagged types.
4023          The latter should be shown as usual (as a pointer), whereas
4024          a reference should mostly be transparent to the user.  */
4025
4026       if (ada_is_tagged_type (t1, 0)
4027           || (t1->code () == TYPE_CODE_REF
4028               && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
4029         {
4030           /* We first try to find the searched field in the current type.
4031              If not found then let's look in the fixed type.  */
4032
4033           if (!find_struct_field (name, t1, 0,
4034                                   &field_type, &byte_offset, &bit_offset,
4035                                   &bit_size, NULL))
4036             check_tag = 1;
4037           else
4038             check_tag = 0;
4039         }
4040       else
4041         check_tag = 0;
4042
4043       /* Convert to fixed type in all cases, so that we have proper
4044          offsets to each field in unconstrained record types.  */
4045       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4046                               address, NULL, check_tag);
4047
4048       /* Resolve the dynamic type as well.  */
4049       arg = value_from_contents_and_address (t1, nullptr, address);
4050       t1 = value_type (arg);
4051
4052       if (find_struct_field (name, t1, 0,
4053                              &field_type, &byte_offset, &bit_offset,
4054                              &bit_size, NULL))
4055         {
4056           if (bit_size != 0)
4057             {
4058               if (t->code () == TYPE_CODE_REF)
4059                 arg = ada_coerce_ref (arg);
4060               else
4061                 arg = ada_value_ind (arg);
4062               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4063                                                   bit_offset, bit_size,
4064                                                   field_type);
4065             }
4066           else
4067             v = value_at_lazy (field_type, address + byte_offset);
4068         }
4069     }
4070
4071   if (v != NULL || no_err)
4072     return v;
4073   else
4074     error (_("There is no member named %s."), name);
4075
4076  BadValue:
4077   if (no_err)
4078     return NULL;
4079   else
4080     error (_("Attempt to extract a component of "
4081              "a value that is not a record."));
4082 }
4083
4084 /* Return the value ACTUAL, converted to be an appropriate value for a
4085    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4086    allocating any necessary descriptors (fat pointers), or copies of
4087    values not residing in memory, updating it as needed.  */
4088
4089 struct value *
4090 ada_convert_actual (struct value *actual, struct type *formal_type0)
4091 {
4092   struct type *actual_type = ada_check_typedef (value_type (actual));
4093   struct type *formal_type = ada_check_typedef (formal_type0);
4094   struct type *formal_target =
4095     formal_type->code () == TYPE_CODE_PTR
4096     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4097   struct type *actual_target =
4098     actual_type->code () == TYPE_CODE_PTR
4099     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4100
4101   if (ada_is_array_descriptor_type (formal_target)
4102       && actual_target->code () == TYPE_CODE_ARRAY)
4103     return make_array_descriptor (formal_type, actual);
4104   else if (formal_type->code () == TYPE_CODE_PTR
4105            || formal_type->code () == TYPE_CODE_REF)
4106     {
4107       struct value *result;
4108
4109       if (formal_target->code () == TYPE_CODE_ARRAY
4110           && ada_is_array_descriptor_type (actual_target))
4111         result = desc_data (actual);
4112       else if (formal_type->code () != TYPE_CODE_PTR)
4113         {
4114           if (VALUE_LVAL (actual) != lval_memory)
4115             {
4116               struct value *val;
4117
4118               actual_type = ada_check_typedef (value_type (actual));
4119               val = allocate_value (actual_type);
4120               memcpy ((char *) value_contents_raw (val),
4121                       (char *) value_contents (actual),
4122                       TYPE_LENGTH (actual_type));
4123               actual = ensure_lval (val);
4124             }
4125           result = value_addr (actual);
4126         }
4127       else
4128         return actual;
4129       return value_cast_pointers (formal_type, result, 0);
4130     }
4131   else if (actual_type->code () == TYPE_CODE_PTR)
4132     return ada_value_ind (actual);
4133   else if (ada_is_aligner_type (formal_type))
4134     {
4135       /* We need to turn this parameter into an aligner type
4136          as well.  */
4137       struct value *aligner = allocate_value (formal_type);
4138       struct value *component = ada_value_struct_elt (aligner, "F", 0);
4139
4140       value_assign_to_component (aligner, component, actual);
4141       return aligner;
4142     }
4143
4144   return actual;
4145 }
4146
4147 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4148    type TYPE.  This is usually an inefficient no-op except on some targets
4149    (such as AVR) where the representation of a pointer and an address
4150    differs.  */
4151
4152 static CORE_ADDR
4153 value_pointer (struct value *value, struct type *type)
4154 {
4155   unsigned len = TYPE_LENGTH (type);
4156   gdb_byte *buf = (gdb_byte *) alloca (len);
4157   CORE_ADDR addr;
4158
4159   addr = value_address (value);
4160   gdbarch_address_to_pointer (type->arch (), type, buf, addr);
4161   addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4162   return addr;
4163 }
4164
4165
4166 /* Push a descriptor of type TYPE for array value ARR on the stack at
4167    *SP, updating *SP to reflect the new descriptor.  Return either
4168    an lvalue representing the new descriptor, or (if TYPE is a pointer-
4169    to-descriptor type rather than a descriptor type), a struct value *
4170    representing a pointer to this descriptor.  */
4171
4172 static struct value *
4173 make_array_descriptor (struct type *type, struct value *arr)
4174 {
4175   struct type *bounds_type = desc_bounds_type (type);
4176   struct type *desc_type = desc_base_type (type);
4177   struct value *descriptor = allocate_value (desc_type);
4178   struct value *bounds = allocate_value (bounds_type);
4179   int i;
4180
4181   for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4182        i > 0; i -= 1)
4183     {
4184       modify_field (value_type (bounds), value_contents_writeable (bounds),
4185                     ada_array_bound (arr, i, 0),
4186                     desc_bound_bitpos (bounds_type, i, 0),
4187                     desc_bound_bitsize (bounds_type, i, 0));
4188       modify_field (value_type (bounds), value_contents_writeable (bounds),
4189                     ada_array_bound (arr, i, 1),
4190                     desc_bound_bitpos (bounds_type, i, 1),
4191                     desc_bound_bitsize (bounds_type, i, 1));
4192     }
4193
4194   bounds = ensure_lval (bounds);
4195
4196   modify_field (value_type (descriptor),
4197                 value_contents_writeable (descriptor),
4198                 value_pointer (ensure_lval (arr),
4199                                desc_type->field (0).type ()),
4200                 fat_pntr_data_bitpos (desc_type),
4201                 fat_pntr_data_bitsize (desc_type));
4202
4203   modify_field (value_type (descriptor),
4204                 value_contents_writeable (descriptor),
4205                 value_pointer (bounds,
4206                                desc_type->field (1).type ()),
4207                 fat_pntr_bounds_bitpos (desc_type),
4208                 fat_pntr_bounds_bitsize (desc_type));
4209
4210   descriptor = ensure_lval (descriptor);
4211
4212   if (type->code () == TYPE_CODE_PTR)
4213     return value_addr (descriptor);
4214   else
4215     return descriptor;
4216 }
4217 \f
4218                                 /* Symbol Cache Module */
4219
4220 /* Performance measurements made as of 2010-01-15 indicate that
4221    this cache does bring some noticeable improvements.  Depending
4222    on the type of entity being printed, the cache can make it as much
4223    as an order of magnitude faster than without it.
4224
4225    The descriptive type DWARF extension has significantly reduced
4226    the need for this cache, at least when DWARF is being used.  However,
4227    even in this case, some expensive name-based symbol searches are still
4228    sometimes necessary - to find an XVZ variable, mostly.  */
4229
4230 /* Return the symbol cache associated to the given program space PSPACE.
4231    If not allocated for this PSPACE yet, allocate and initialize one.  */
4232
4233 static struct ada_symbol_cache *
4234 ada_get_symbol_cache (struct program_space *pspace)
4235 {
4236   struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4237
4238   if (pspace_data->sym_cache == nullptr)
4239     pspace_data->sym_cache.reset (new ada_symbol_cache);
4240
4241   return pspace_data->sym_cache.get ();
4242 }
4243
4244 /* Clear all entries from the symbol cache.  */
4245
4246 static void
4247 ada_clear_symbol_cache ()
4248 {
4249   struct ada_pspace_data *pspace_data
4250     = get_ada_pspace_data (current_program_space);
4251
4252   if (pspace_data->sym_cache != nullptr)
4253     pspace_data->sym_cache.reset ();
4254 }
4255
4256 /* Search our cache for an entry matching NAME and DOMAIN.
4257    Return it if found, or NULL otherwise.  */
4258
4259 static struct cache_entry **
4260 find_entry (const char *name, domain_enum domain)
4261 {
4262   struct ada_symbol_cache *sym_cache
4263     = ada_get_symbol_cache (current_program_space);
4264   int h = msymbol_hash (name) % HASH_SIZE;
4265   struct cache_entry **e;
4266
4267   for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4268     {
4269       if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4270         return e;
4271     }
4272   return NULL;
4273 }
4274
4275 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4276    Return 1 if found, 0 otherwise.
4277
4278    If an entry was found and SYM is not NULL, set *SYM to the entry's
4279    SYM.  Same principle for BLOCK if not NULL.  */
4280
4281 static int
4282 lookup_cached_symbol (const char *name, domain_enum domain,
4283                       struct symbol **sym, const struct block **block)
4284 {
4285   struct cache_entry **e = find_entry (name, domain);
4286
4287   if (e == NULL)
4288     return 0;
4289   if (sym != NULL)
4290     *sym = (*e)->sym;
4291   if (block != NULL)
4292     *block = (*e)->block;
4293   return 1;
4294 }
4295
4296 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4297    in domain DOMAIN, save this result in our symbol cache.  */
4298
4299 static void
4300 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4301               const struct block *block)
4302 {
4303   struct ada_symbol_cache *sym_cache
4304     = ada_get_symbol_cache (current_program_space);
4305   int h;
4306   struct cache_entry *e;
4307
4308   /* Symbols for builtin types don't have a block.
4309      For now don't cache such symbols.  */
4310   if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4311     return;
4312
4313   /* If the symbol is a local symbol, then do not cache it, as a search
4314      for that symbol depends on the context.  To determine whether
4315      the symbol is local or not, we check the block where we found it
4316      against the global and static blocks of its associated symtab.  */
4317   if (sym
4318       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4319                             GLOBAL_BLOCK) != block
4320       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4321                             STATIC_BLOCK) != block)
4322     return;
4323
4324   h = msymbol_hash (name) % HASH_SIZE;
4325   e = XOBNEW (&sym_cache->cache_space, cache_entry);
4326   e->next = sym_cache->root[h];
4327   sym_cache->root[h] = e;
4328   e->name = obstack_strdup (&sym_cache->cache_space, name);
4329   e->sym = sym;
4330   e->domain = domain;
4331   e->block = block;
4332 }
4333 \f
4334                                 /* Symbol Lookup */
4335
4336 /* Return the symbol name match type that should be used used when
4337    searching for all symbols matching LOOKUP_NAME.
4338
4339    LOOKUP_NAME is expected to be a symbol name after transformation
4340    for Ada lookups.  */
4341
4342 static symbol_name_match_type
4343 name_match_type_from_name (const char *lookup_name)
4344 {
4345   return (strstr (lookup_name, "__") == NULL
4346           ? symbol_name_match_type::WILD
4347           : symbol_name_match_type::FULL);
4348 }
4349
4350 /* Return the result of a standard (literal, C-like) lookup of NAME in
4351    given DOMAIN, visible from lexical block BLOCK.  */
4352
4353 static struct symbol *
4354 standard_lookup (const char *name, const struct block *block,
4355                  domain_enum domain)
4356 {
4357   /* Initialize it just to avoid a GCC false warning.  */
4358   struct block_symbol sym = {};
4359
4360   if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4361     return sym.symbol;
4362   ada_lookup_encoded_symbol (name, block, domain, &sym);
4363   cache_symbol (name, domain, sym.symbol, sym.block);
4364   return sym.symbol;
4365 }
4366
4367
4368 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4369    in the symbol fields of SYMS.  We treat enumerals as functions, 
4370    since they contend in overloading in the same way.  */
4371 static int
4372 is_nonfunction (const std::vector<struct block_symbol> &syms)
4373 {
4374   for (const block_symbol &sym : syms)
4375     if (SYMBOL_TYPE (sym.symbol)->code () != TYPE_CODE_FUNC
4376         && (SYMBOL_TYPE (sym.symbol)->code () != TYPE_CODE_ENUM
4377             || SYMBOL_CLASS (sym.symbol) != LOC_CONST))
4378       return 1;
4379
4380   return 0;
4381 }
4382
4383 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4384    struct types.  Otherwise, they may not.  */
4385
4386 static int
4387 equiv_types (struct type *type0, struct type *type1)
4388 {
4389   if (type0 == type1)
4390     return 1;
4391   if (type0 == NULL || type1 == NULL
4392       || type0->code () != type1->code ())
4393     return 0;
4394   if ((type0->code () == TYPE_CODE_STRUCT
4395        || type0->code () == TYPE_CODE_ENUM)
4396       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4397       && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4398     return 1;
4399
4400   return 0;
4401 }
4402
4403 /* True iff SYM0 represents the same entity as SYM1, or one that is
4404    no more defined than that of SYM1.  */
4405
4406 static int
4407 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4408 {
4409   if (sym0 == sym1)
4410     return 1;
4411   if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4412       || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4413     return 0;
4414
4415   switch (SYMBOL_CLASS (sym0))
4416     {
4417     case LOC_UNDEF:
4418       return 1;
4419     case LOC_TYPEDEF:
4420       {
4421         struct type *type0 = SYMBOL_TYPE (sym0);
4422         struct type *type1 = SYMBOL_TYPE (sym1);
4423         const char *name0 = sym0->linkage_name ();
4424         const char *name1 = sym1->linkage_name ();
4425         int len0 = strlen (name0);
4426
4427         return
4428           type0->code () == type1->code ()
4429           && (equiv_types (type0, type1)
4430               || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4431                   && startswith (name1 + len0, "___XV")));
4432       }
4433     case LOC_CONST:
4434       return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4435         && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4436
4437     case LOC_STATIC:
4438       {
4439         const char *name0 = sym0->linkage_name ();
4440         const char *name1 = sym1->linkage_name ();
4441         return (strcmp (name0, name1) == 0
4442                 && SYMBOL_VALUE_ADDRESS (sym0) == SYMBOL_VALUE_ADDRESS (sym1));
4443       }
4444
4445     default:
4446       return 0;
4447     }
4448 }
4449
4450 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4451    records in RESULT.  Do nothing if SYM is a duplicate.  */
4452
4453 static void
4454 add_defn_to_vec (std::vector<struct block_symbol> &result,
4455                  struct symbol *sym,
4456                  const struct block *block)
4457 {
4458   /* Do not try to complete stub types, as the debugger is probably
4459      already scanning all symbols matching a certain name at the
4460      time when this function is called.  Trying to replace the stub
4461      type by its associated full type will cause us to restart a scan
4462      which may lead to an infinite recursion.  Instead, the client
4463      collecting the matching symbols will end up collecting several
4464      matches, with at least one of them complete.  It can then filter
4465      out the stub ones if needed.  */
4466
4467   for (int i = result.size () - 1; i >= 0; i -= 1)
4468     {
4469       if (lesseq_defined_than (sym, result[i].symbol))
4470         return;
4471       else if (lesseq_defined_than (result[i].symbol, sym))
4472         {
4473           result[i].symbol = sym;
4474           result[i].block = block;
4475           return;
4476         }
4477     }
4478
4479   struct block_symbol info;
4480   info.symbol = sym;
4481   info.block = block;
4482   result.push_back (info);
4483 }
4484
4485 /* Return a bound minimal symbol matching NAME according to Ada
4486    decoding rules.  Returns an invalid symbol if there is no such
4487    minimal symbol.  Names prefixed with "standard__" are handled
4488    specially: "standard__" is first stripped off, and only static and
4489    global symbols are searched.  */
4490
4491 struct bound_minimal_symbol
4492 ada_lookup_simple_minsym (const char *name)
4493 {
4494   struct bound_minimal_symbol result;
4495
4496   memset (&result, 0, sizeof (result));
4497
4498   symbol_name_match_type match_type = name_match_type_from_name (name);
4499   lookup_name_info lookup_name (name, match_type);
4500
4501   symbol_name_matcher_ftype *match_name
4502     = ada_get_symbol_name_matcher (lookup_name);
4503
4504   for (objfile *objfile : current_program_space->objfiles ())
4505     {
4506       for (minimal_symbol *msymbol : objfile->msymbols ())
4507         {
4508           if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4509               && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4510             {
4511               result.minsym = msymbol;
4512               result.objfile = objfile;
4513               break;
4514             }
4515         }
4516     }
4517
4518   return result;
4519 }
4520
4521 /* For all subprograms that statically enclose the subprogram of the
4522    selected frame, add symbols matching identifier NAME in DOMAIN
4523    and their blocks to the list of data in RESULT, as for
4524    ada_add_block_symbols (q.v.).   If WILD_MATCH_P, treat as NAME
4525    with a wildcard prefix.  */
4526
4527 static void
4528 add_symbols_from_enclosing_procs (std::vector<struct block_symbol> &result,
4529                                   const lookup_name_info &lookup_name,
4530                                   domain_enum domain)
4531 {
4532 }
4533
4534 /* True if TYPE is definitely an artificial type supplied to a symbol
4535    for which no debugging information was given in the symbol file.  */
4536
4537 static int
4538 is_nondebugging_type (struct type *type)
4539 {
4540   const char *name = ada_type_name (type);
4541
4542   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4543 }
4544
4545 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4546    that are deemed "identical" for practical purposes.
4547
4548    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4549    types and that their number of enumerals is identical (in other
4550    words, type1->num_fields () == type2->num_fields ()).  */
4551
4552 static int
4553 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4554 {
4555   int i;
4556
4557   /* The heuristic we use here is fairly conservative.  We consider
4558      that 2 enumerate types are identical if they have the same
4559      number of enumerals and that all enumerals have the same
4560      underlying value and name.  */
4561
4562   /* All enums in the type should have an identical underlying value.  */
4563   for (i = 0; i < type1->num_fields (); i++)
4564     if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
4565       return 0;
4566
4567   /* All enumerals should also have the same name (modulo any numerical
4568      suffix).  */
4569   for (i = 0; i < type1->num_fields (); i++)
4570     {
4571       const char *name_1 = TYPE_FIELD_NAME (type1, i);
4572       const char *name_2 = TYPE_FIELD_NAME (type2, i);
4573       int len_1 = strlen (name_1);
4574       int len_2 = strlen (name_2);
4575
4576       ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4577       ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4578       if (len_1 != len_2
4579           || strncmp (TYPE_FIELD_NAME (type1, i),
4580                       TYPE_FIELD_NAME (type2, i),
4581                       len_1) != 0)
4582         return 0;
4583     }
4584
4585   return 1;
4586 }
4587
4588 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4589    that are deemed "identical" for practical purposes.  Sometimes,
4590    enumerals are not strictly identical, but their types are so similar
4591    that they can be considered identical.
4592
4593    For instance, consider the following code:
4594
4595       type Color is (Black, Red, Green, Blue, White);
4596       type RGB_Color is new Color range Red .. Blue;
4597
4598    Type RGB_Color is a subrange of an implicit type which is a copy
4599    of type Color. If we call that implicit type RGB_ColorB ("B" is
4600    for "Base Type"), then type RGB_ColorB is a copy of type Color.
4601    As a result, when an expression references any of the enumeral
4602    by name (Eg. "print green"), the expression is technically
4603    ambiguous and the user should be asked to disambiguate. But
4604    doing so would only hinder the user, since it wouldn't matter
4605    what choice he makes, the outcome would always be the same.
4606    So, for practical purposes, we consider them as the same.  */
4607
4608 static int
4609 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
4610 {
4611   int i;
4612
4613   /* Before performing a thorough comparison check of each type,
4614      we perform a series of inexpensive checks.  We expect that these
4615      checks will quickly fail in the vast majority of cases, and thus
4616      help prevent the unnecessary use of a more expensive comparison.
4617      Said comparison also expects us to make some of these checks
4618      (see ada_identical_enum_types_p).  */
4619
4620   /* Quick check: All symbols should have an enum type.  */
4621   for (i = 0; i < syms.size (); i++)
4622     if (SYMBOL_TYPE (syms[i].symbol)->code () != TYPE_CODE_ENUM)
4623       return 0;
4624
4625   /* Quick check: They should all have the same value.  */
4626   for (i = 1; i < syms.size (); i++)
4627     if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
4628       return 0;
4629
4630   /* Quick check: They should all have the same number of enumerals.  */
4631   for (i = 1; i < syms.size (); i++)
4632     if (SYMBOL_TYPE (syms[i].symbol)->num_fields ()
4633         != SYMBOL_TYPE (syms[0].symbol)->num_fields ())
4634       return 0;
4635
4636   /* All the sanity checks passed, so we might have a set of
4637      identical enumeration types.  Perform a more complete
4638      comparison of the type of each symbol.  */
4639   for (i = 1; i < syms.size (); i++)
4640     if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
4641                                      SYMBOL_TYPE (syms[0].symbol)))
4642       return 0;
4643
4644   return 1;
4645 }
4646
4647 /* Remove any non-debugging symbols in SYMS that definitely
4648    duplicate other symbols in the list (The only case I know of where
4649    this happens is when object files containing stabs-in-ecoff are
4650    linked with files containing ordinary ecoff debugging symbols (or no
4651    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.  */
4652
4653 static void
4654 remove_extra_symbols (std::vector<struct block_symbol> *syms)
4655 {
4656   int i, j;
4657
4658   /* We should never be called with less than 2 symbols, as there
4659      cannot be any extra symbol in that case.  But it's easy to
4660      handle, since we have nothing to do in that case.  */
4661   if (syms->size () < 2)
4662     return;
4663
4664   i = 0;
4665   while (i < syms->size ())
4666     {
4667       int remove_p = 0;
4668
4669       /* If two symbols have the same name and one of them is a stub type,
4670          the get rid of the stub.  */
4671
4672       if (SYMBOL_TYPE ((*syms)[i].symbol)->is_stub ()
4673           && (*syms)[i].symbol->linkage_name () != NULL)
4674         {
4675           for (j = 0; j < syms->size (); j++)
4676             {
4677               if (j != i
4678                   && !SYMBOL_TYPE ((*syms)[j].symbol)->is_stub ()
4679                   && (*syms)[j].symbol->linkage_name () != NULL
4680                   && strcmp ((*syms)[i].symbol->linkage_name (),
4681                              (*syms)[j].symbol->linkage_name ()) == 0)
4682                 remove_p = 1;
4683             }
4684         }
4685
4686       /* Two symbols with the same name, same class and same address
4687          should be identical.  */
4688
4689       else if ((*syms)[i].symbol->linkage_name () != NULL
4690           && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
4691           && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
4692         {
4693           for (j = 0; j < syms->size (); j += 1)
4694             {
4695               if (i != j
4696                   && (*syms)[j].symbol->linkage_name () != NULL
4697                   && strcmp ((*syms)[i].symbol->linkage_name (),
4698                              (*syms)[j].symbol->linkage_name ()) == 0
4699                   && SYMBOL_CLASS ((*syms)[i].symbol)
4700                        == SYMBOL_CLASS ((*syms)[j].symbol)
4701                   && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
4702                   == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
4703                 remove_p = 1;
4704             }
4705         }
4706       
4707       if (remove_p)
4708         syms->erase (syms->begin () + i);
4709       else
4710         i += 1;
4711     }
4712
4713   /* If all the remaining symbols are identical enumerals, then
4714      just keep the first one and discard the rest.
4715
4716      Unlike what we did previously, we do not discard any entry
4717      unless they are ALL identical.  This is because the symbol
4718      comparison is not a strict comparison, but rather a practical
4719      comparison.  If all symbols are considered identical, then
4720      we can just go ahead and use the first one and discard the rest.
4721      But if we cannot reduce the list to a single element, we have
4722      to ask the user to disambiguate anyways.  And if we have to
4723      present a multiple-choice menu, it's less confusing if the list
4724      isn't missing some choices that were identical and yet distinct.  */
4725   if (symbols_are_identical_enums (*syms))
4726     syms->resize (1);
4727 }
4728
4729 /* Given a type that corresponds to a renaming entity, use the type name
4730    to extract the scope (package name or function name, fully qualified,
4731    and following the GNAT encoding convention) where this renaming has been
4732    defined.  */
4733
4734 static std::string
4735 xget_renaming_scope (struct type *renaming_type)
4736 {
4737   /* The renaming types adhere to the following convention:
4738      <scope>__<rename>___<XR extension>.
4739      So, to extract the scope, we search for the "___XR" extension,
4740      and then backtrack until we find the first "__".  */
4741
4742   const char *name = renaming_type->name ();
4743   const char *suffix = strstr (name, "___XR");
4744   const char *last;
4745
4746   /* Now, backtrack a bit until we find the first "__".  Start looking
4747      at suffix - 3, as the <rename> part is at least one character long.  */
4748
4749   for (last = suffix - 3; last > name; last--)
4750     if (last[0] == '_' && last[1] == '_')
4751       break;
4752
4753   /* Make a copy of scope and return it.  */
4754   return std::string (name, last);
4755 }
4756
4757 /* Return nonzero if NAME corresponds to a package name.  */
4758
4759 static int
4760 is_package_name (const char *name)
4761 {
4762   /* Here, We take advantage of the fact that no symbols are generated
4763      for packages, while symbols are generated for each function.
4764      So the condition for NAME represent a package becomes equivalent
4765      to NAME not existing in our list of symbols.  There is only one
4766      small complication with library-level functions (see below).  */
4767
4768   /* If it is a function that has not been defined at library level,
4769      then we should be able to look it up in the symbols.  */
4770   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4771     return 0;
4772
4773   /* Library-level function names start with "_ada_".  See if function
4774      "_ada_" followed by NAME can be found.  */
4775
4776   /* Do a quick check that NAME does not contain "__", since library-level
4777      functions names cannot contain "__" in them.  */
4778   if (strstr (name, "__") != NULL)
4779     return 0;
4780
4781   std::string fun_name = string_printf ("_ada_%s", name);
4782
4783   return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
4784 }
4785
4786 /* Return nonzero if SYM corresponds to a renaming entity that is
4787    not visible from FUNCTION_NAME.  */
4788
4789 static int
4790 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
4791 {
4792   if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4793     return 0;
4794
4795   std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
4796
4797   /* If the rename has been defined in a package, then it is visible.  */
4798   if (is_package_name (scope.c_str ()))
4799     return 0;
4800
4801   /* Check that the rename is in the current function scope by checking
4802      that its name starts with SCOPE.  */
4803
4804   /* If the function name starts with "_ada_", it means that it is
4805      a library-level function.  Strip this prefix before doing the
4806      comparison, as the encoding for the renaming does not contain
4807      this prefix.  */
4808   if (startswith (function_name, "_ada_"))
4809     function_name += 5;
4810
4811   return !startswith (function_name, scope.c_str ());
4812 }
4813
4814 /* Remove entries from SYMS that corresponds to a renaming entity that
4815    is not visible from the function associated with CURRENT_BLOCK or
4816    that is superfluous due to the presence of more specific renaming
4817    information.  Places surviving symbols in the initial entries of
4818    SYMS.
4819
4820    Rationale:
4821    First, in cases where an object renaming is implemented as a
4822    reference variable, GNAT may produce both the actual reference
4823    variable and the renaming encoding.  In this case, we discard the
4824    latter.
4825
4826    Second, GNAT emits a type following a specified encoding for each renaming
4827    entity.  Unfortunately, STABS currently does not support the definition
4828    of types that are local to a given lexical block, so all renamings types
4829    are emitted at library level.  As a consequence, if an application
4830    contains two renaming entities using the same name, and a user tries to
4831    print the value of one of these entities, the result of the ada symbol
4832    lookup will also contain the wrong renaming type.
4833
4834    This function partially covers for this limitation by attempting to
4835    remove from the SYMS list renaming symbols that should be visible
4836    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
4837    method with the current information available.  The implementation
4838    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
4839    
4840       - When the user tries to print a rename in a function while there
4841         is another rename entity defined in a package:  Normally, the
4842         rename in the function has precedence over the rename in the
4843         package, so the latter should be removed from the list.  This is
4844         currently not the case.
4845         
4846       - This function will incorrectly remove valid renames if
4847         the CURRENT_BLOCK corresponds to a function which symbol name
4848         has been changed by an "Export" pragma.  As a consequence,
4849         the user will be unable to print such rename entities.  */
4850
4851 static void
4852 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
4853                              const struct block *current_block)
4854 {
4855   struct symbol *current_function;
4856   const char *current_function_name;
4857   int i;
4858   int is_new_style_renaming;
4859
4860   /* If there is both a renaming foo___XR... encoded as a variable and
4861      a simple variable foo in the same block, discard the latter.
4862      First, zero out such symbols, then compress.  */
4863   is_new_style_renaming = 0;
4864   for (i = 0; i < syms->size (); i += 1)
4865     {
4866       struct symbol *sym = (*syms)[i].symbol;
4867       const struct block *block = (*syms)[i].block;
4868       const char *name;
4869       const char *suffix;
4870
4871       if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4872         continue;
4873       name = sym->linkage_name ();
4874       suffix = strstr (name, "___XR");
4875
4876       if (suffix != NULL)
4877         {
4878           int name_len = suffix - name;
4879           int j;
4880
4881           is_new_style_renaming = 1;
4882           for (j = 0; j < syms->size (); j += 1)
4883             if (i != j && (*syms)[j].symbol != NULL
4884                 && strncmp (name, (*syms)[j].symbol->linkage_name (),
4885                             name_len) == 0
4886                 && block == (*syms)[j].block)
4887               (*syms)[j].symbol = NULL;
4888         }
4889     }
4890   if (is_new_style_renaming)
4891     {
4892       int j, k;
4893
4894       for (j = k = 0; j < syms->size (); j += 1)
4895         if ((*syms)[j].symbol != NULL)
4896             {
4897               (*syms)[k] = (*syms)[j];
4898               k += 1;
4899             }
4900       syms->resize (k);
4901       return;
4902     }
4903
4904   /* Extract the function name associated to CURRENT_BLOCK.
4905      Abort if unable to do so.  */
4906
4907   if (current_block == NULL)
4908     return;
4909
4910   current_function = block_linkage_function (current_block);
4911   if (current_function == NULL)
4912     return;
4913
4914   current_function_name = current_function->linkage_name ();
4915   if (current_function_name == NULL)
4916     return;
4917
4918   /* Check each of the symbols, and remove it from the list if it is
4919      a type corresponding to a renaming that is out of the scope of
4920      the current block.  */
4921
4922   i = 0;
4923   while (i < syms->size ())
4924     {
4925       if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
4926           == ADA_OBJECT_RENAMING
4927           && old_renaming_is_invisible ((*syms)[i].symbol,
4928                                         current_function_name))
4929         syms->erase (syms->begin () + i);
4930       else
4931         i += 1;
4932     }
4933 }
4934
4935 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
4936    whose name and domain match NAME and DOMAIN respectively.
4937    If no match was found, then extend the search to "enclosing"
4938    routines (in other words, if we're inside a nested function,
4939    search the symbols defined inside the enclosing functions).
4940    If WILD_MATCH_P is nonzero, perform the naming matching in
4941    "wild" mode (see function "wild_match" for more info).
4942
4943    Note: This function assumes that RESULT has 0 (zero) element in it.  */
4944
4945 static void
4946 ada_add_local_symbols (std::vector<struct block_symbol> &result,
4947                        const lookup_name_info &lookup_name,
4948                        const struct block *block, domain_enum domain)
4949 {
4950   int block_depth = 0;
4951
4952   while (block != NULL)
4953     {
4954       block_depth += 1;
4955       ada_add_block_symbols (result, block, lookup_name, domain, NULL);
4956
4957       /* If we found a non-function match, assume that's the one.  */
4958       if (is_nonfunction (result))
4959         return;
4960
4961       block = BLOCK_SUPERBLOCK (block);
4962     }
4963
4964   /* If no luck so far, try to find NAME as a local symbol in some lexically
4965      enclosing subprogram.  */
4966   if (result.empty () && block_depth > 2)
4967     add_symbols_from_enclosing_procs (result, lookup_name, domain);
4968 }
4969
4970 /* An object of this type is used as the callback argument when
4971    calling the map_matching_symbols method.  */
4972
4973 struct match_data
4974 {
4975   explicit match_data (std::vector<struct block_symbol> *rp)
4976     : resultp (rp)
4977   {
4978   }
4979   DISABLE_COPY_AND_ASSIGN (match_data);
4980
4981   bool operator() (struct block_symbol *bsym);
4982
4983   struct objfile *objfile = nullptr;
4984   std::vector<struct block_symbol> *resultp;
4985   struct symbol *arg_sym = nullptr;
4986   bool found_sym = false;
4987 };
4988
4989 /* A callback for add_nonlocal_symbols that adds symbol, found in
4990    BSYM, to a list of symbols.  */
4991
4992 bool
4993 match_data::operator() (struct block_symbol *bsym)
4994 {
4995   const struct block *block = bsym->block;
4996   struct symbol *sym = bsym->symbol;
4997
4998   if (sym == NULL)
4999     {
5000       if (!found_sym && arg_sym != NULL)
5001         add_defn_to_vec (*resultp,
5002                          fixup_symbol_section (arg_sym, objfile),
5003                          block);
5004       found_sym = false;
5005       arg_sym = NULL;
5006     }
5007   else 
5008     {
5009       if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5010         return true;
5011       else if (SYMBOL_IS_ARGUMENT (sym))
5012         arg_sym = sym;
5013       else
5014         {
5015           found_sym = true;
5016           add_defn_to_vec (*resultp,
5017                            fixup_symbol_section (sym, objfile),
5018                            block);
5019         }
5020     }
5021   return true;
5022 }
5023
5024 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5025    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5026    symbols to RESULT.  Return whether we found such symbols.  */
5027
5028 static int
5029 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5030                          const struct block *block,
5031                          const lookup_name_info &lookup_name,
5032                          domain_enum domain)
5033 {
5034   struct using_direct *renaming;
5035   int defns_mark = result.size ();
5036
5037   symbol_name_matcher_ftype *name_match
5038     = ada_get_symbol_name_matcher (lookup_name);
5039
5040   for (renaming = block_using (block);
5041        renaming != NULL;
5042        renaming = renaming->next)
5043     {
5044       const char *r_name;
5045
5046       /* Avoid infinite recursions: skip this renaming if we are actually
5047          already traversing it.
5048
5049          Currently, symbol lookup in Ada don't use the namespace machinery from
5050          C++/Fortran support: skip namespace imports that use them.  */
5051       if (renaming->searched
5052           || (renaming->import_src != NULL
5053               && renaming->import_src[0] != '\0')
5054           || (renaming->import_dest != NULL
5055               && renaming->import_dest[0] != '\0'))
5056         continue;
5057       renaming->searched = 1;
5058
5059       /* TODO: here, we perform another name-based symbol lookup, which can
5060          pull its own multiple overloads.  In theory, we should be able to do
5061          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5062          not a simple name.  But in order to do this, we would need to enhance
5063          the DWARF reader to associate a symbol to this renaming, instead of a
5064          name.  So, for now, we do something simpler: re-use the C++/Fortran
5065          namespace machinery.  */
5066       r_name = (renaming->alias != NULL
5067                 ? renaming->alias
5068                 : renaming->declaration);
5069       if (name_match (r_name, lookup_name, NULL))
5070         {
5071           lookup_name_info decl_lookup_name (renaming->declaration,
5072                                              lookup_name.match_type ());
5073           ada_add_all_symbols (result, block, decl_lookup_name, domain,
5074                                1, NULL);
5075         }
5076       renaming->searched = 0;
5077     }
5078   return result.size () != defns_mark;
5079 }
5080
5081 /* Implements compare_names, but only applying the comparision using
5082    the given CASING.  */
5083
5084 static int
5085 compare_names_with_case (const char *string1, const char *string2,
5086                          enum case_sensitivity casing)
5087 {
5088   while (*string1 != '\0' && *string2 != '\0')
5089     {
5090       char c1, c2;
5091
5092       if (isspace (*string1) || isspace (*string2))
5093         return strcmp_iw_ordered (string1, string2);
5094
5095       if (casing == case_sensitive_off)
5096         {
5097           c1 = tolower (*string1);
5098           c2 = tolower (*string2);
5099         }
5100       else
5101         {
5102           c1 = *string1;
5103           c2 = *string2;
5104         }
5105       if (c1 != c2)
5106         break;
5107
5108       string1 += 1;
5109       string2 += 1;
5110     }
5111
5112   switch (*string1)
5113     {
5114     case '(':
5115       return strcmp_iw_ordered (string1, string2);
5116     case '_':
5117       if (*string2 == '\0')
5118         {
5119           if (is_name_suffix (string1))
5120             return 0;
5121           else
5122             return 1;
5123         }
5124       /* FALLTHROUGH */
5125     default:
5126       if (*string2 == '(')
5127         return strcmp_iw_ordered (string1, string2);
5128       else
5129         {
5130           if (casing == case_sensitive_off)
5131             return tolower (*string1) - tolower (*string2);
5132           else
5133             return *string1 - *string2;
5134         }
5135     }
5136 }
5137
5138 /* Compare STRING1 to STRING2, with results as for strcmp.
5139    Compatible with strcmp_iw_ordered in that...
5140
5141        strcmp_iw_ordered (STRING1, STRING2) <= 0
5142
5143    ... implies...
5144
5145        compare_names (STRING1, STRING2) <= 0
5146
5147    (they may differ as to what symbols compare equal).  */
5148
5149 static int
5150 compare_names (const char *string1, const char *string2)
5151 {
5152   int result;
5153
5154   /* Similar to what strcmp_iw_ordered does, we need to perform
5155      a case-insensitive comparison first, and only resort to
5156      a second, case-sensitive, comparison if the first one was
5157      not sufficient to differentiate the two strings.  */
5158
5159   result = compare_names_with_case (string1, string2, case_sensitive_off);
5160   if (result == 0)
5161     result = compare_names_with_case (string1, string2, case_sensitive_on);
5162
5163   return result;
5164 }
5165
5166 /* Convenience function to get at the Ada encoded lookup name for
5167    LOOKUP_NAME, as a C string.  */
5168
5169 static const char *
5170 ada_lookup_name (const lookup_name_info &lookup_name)
5171 {
5172   return lookup_name.ada ().lookup_name ().c_str ();
5173 }
5174
5175 /* A helper for add_nonlocal_symbols.  Call expand_matching_symbols
5176    for OBJFILE, then walk the objfile's symtabs and update the
5177    results.  */
5178
5179 static void
5180 map_matching_symbols (struct objfile *objfile,
5181                       const lookup_name_info &lookup_name,
5182                       bool is_wild_match,
5183                       domain_enum domain,
5184                       int global,
5185                       match_data &data)
5186 {
5187   data.objfile = objfile;
5188   objfile->expand_matching_symbols (lookup_name, domain, global,
5189                                     is_wild_match ? nullptr : compare_names);
5190
5191   const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5192   for (compunit_symtab *symtab : objfile->compunits ())
5193     {
5194       const struct block *block
5195         = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (symtab), block_kind);
5196       if (!iterate_over_symbols_terminated (block, lookup_name,
5197                                             domain, data))
5198         break;
5199     }
5200 }
5201
5202 /* Add to RESULT all non-local symbols whose name and domain match
5203    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5204    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5205    symbols otherwise.  */
5206
5207 static void
5208 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5209                       const lookup_name_info &lookup_name,
5210                       domain_enum domain, int global)
5211 {
5212   struct match_data data (&result);
5213
5214   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5215
5216   for (objfile *objfile : current_program_space->objfiles ())
5217     {
5218       map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5219                             global, data);
5220
5221       for (compunit_symtab *cu : objfile->compunits ())
5222         {
5223           const struct block *global_block
5224             = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5225
5226           if (ada_add_block_renamings (result, global_block, lookup_name,
5227                                        domain))
5228             data.found_sym = true;
5229         }
5230     }
5231
5232   if (result.empty () && global && !is_wild_match)
5233     {
5234       const char *name = ada_lookup_name (lookup_name);
5235       std::string bracket_name = std::string ("<_ada_") + name + '>';
5236       lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5237
5238       for (objfile *objfile : current_program_space->objfiles ())
5239         map_matching_symbols (objfile, name1, false, domain, global, data);
5240     }
5241 }
5242
5243 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5244    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5245    returning the number of matches.  Add these to RESULT.
5246
5247    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5248    symbol match within the nest of blocks whose innermost member is BLOCK,
5249    is the one match returned (no other matches in that or
5250    enclosing blocks is returned).  If there are any matches in or
5251    surrounding BLOCK, then these alone are returned.
5252
5253    Names prefixed with "standard__" are handled specially:
5254    "standard__" is first stripped off (by the lookup_name
5255    constructor), and only static and global symbols are searched.
5256
5257    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5258    to lookup global symbols.  */
5259
5260 static void
5261 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5262                      const struct block *block,
5263                      const lookup_name_info &lookup_name,
5264                      domain_enum domain,
5265                      int full_search,
5266                      int *made_global_lookup_p)
5267 {
5268   struct symbol *sym;
5269
5270   if (made_global_lookup_p)
5271     *made_global_lookup_p = 0;
5272
5273   /* Special case: If the user specifies a symbol name inside package
5274      Standard, do a non-wild matching of the symbol name without
5275      the "standard__" prefix.  This was primarily introduced in order
5276      to allow the user to specifically access the standard exceptions
5277      using, for instance, Standard.Constraint_Error when Constraint_Error
5278      is ambiguous (due to the user defining its own Constraint_Error
5279      entity inside its program).  */
5280   if (lookup_name.ada ().standard_p ())
5281     block = NULL;
5282
5283   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5284
5285   if (block != NULL)
5286     {
5287       if (full_search)
5288         ada_add_local_symbols (result, lookup_name, block, domain);
5289       else
5290         {
5291           /* In the !full_search case we're are being called by
5292              iterate_over_symbols, and we don't want to search
5293              superblocks.  */
5294           ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5295         }
5296       if (!result.empty () || !full_search)
5297         return;
5298     }
5299
5300   /* No non-global symbols found.  Check our cache to see if we have
5301      already performed this search before.  If we have, then return
5302      the same result.  */
5303
5304   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5305                             domain, &sym, &block))
5306     {
5307       if (sym != NULL)
5308         add_defn_to_vec (result, sym, block);
5309       return;
5310     }
5311
5312   if (made_global_lookup_p)
5313     *made_global_lookup_p = 1;
5314
5315   /* Search symbols from all global blocks.  */
5316  
5317   add_nonlocal_symbols (result, lookup_name, domain, 1);
5318
5319   /* Now add symbols from all per-file blocks if we've gotten no hits
5320      (not strictly correct, but perhaps better than an error).  */
5321
5322   if (result.empty ())
5323     add_nonlocal_symbols (result, lookup_name, domain, 0);
5324 }
5325
5326 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5327    is non-zero, enclosing scope and in global scopes.
5328
5329    Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5330    blocks and symbol tables (if any) in which they were found.
5331
5332    When full_search is non-zero, any non-function/non-enumeral
5333    symbol match within the nest of blocks whose innermost member is BLOCK,
5334    is the one match returned (no other matches in that or
5335    enclosing blocks is returned).  If there are any matches in or
5336    surrounding BLOCK, then these alone are returned.
5337
5338    Names prefixed with "standard__" are handled specially: "standard__"
5339    is first stripped off, and only static and global symbols are searched.  */
5340
5341 static std::vector<struct block_symbol>
5342 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5343                                const struct block *block,
5344                                domain_enum domain,
5345                                int full_search)
5346 {
5347   int syms_from_global_search;
5348   std::vector<struct block_symbol> results;
5349
5350   ada_add_all_symbols (results, block, lookup_name,
5351                        domain, full_search, &syms_from_global_search);
5352
5353   remove_extra_symbols (&results);
5354
5355   if (results.empty () && full_search && syms_from_global_search)
5356     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5357
5358   if (results.size () == 1 && full_search && syms_from_global_search)
5359     cache_symbol (ada_lookup_name (lookup_name), domain,
5360                   results[0].symbol, results[0].block);
5361
5362   remove_irrelevant_renamings (&results, block);
5363   return results;
5364 }
5365
5366 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5367    in global scopes, returning (SYM,BLOCK) tuples.
5368
5369    See ada_lookup_symbol_list_worker for further details.  */
5370
5371 std::vector<struct block_symbol>
5372 ada_lookup_symbol_list (const char *name, const struct block *block,
5373                         domain_enum domain)
5374 {
5375   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5376   lookup_name_info lookup_name (name, name_match_type);
5377
5378   return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5379 }
5380
5381 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5382    to 1, but choosing the first symbol found if there are multiple
5383    choices.
5384
5385    The result is stored in *INFO, which must be non-NULL.
5386    If no match is found, INFO->SYM is set to NULL.  */
5387
5388 void
5389 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5390                            domain_enum domain,
5391                            struct block_symbol *info)
5392 {
5393   /* Since we already have an encoded name, wrap it in '<>' to force a
5394      verbatim match.  Otherwise, if the name happens to not look like
5395      an encoded name (because it doesn't include a "__"),
5396      ada_lookup_name_info would re-encode/fold it again, and that
5397      would e.g., incorrectly lowercase object renaming names like
5398      "R28b" -> "r28b".  */
5399   std::string verbatim = add_angle_brackets (name);
5400
5401   gdb_assert (info != NULL);
5402   *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5403 }
5404
5405 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5406    scope and in global scopes, or NULL if none.  NAME is folded and
5407    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5408    choosing the first symbol if there are multiple choices.  */
5409
5410 struct block_symbol
5411 ada_lookup_symbol (const char *name, const struct block *block0,
5412                    domain_enum domain)
5413 {
5414   std::vector<struct block_symbol> candidates
5415     = ada_lookup_symbol_list (name, block0, domain);
5416
5417   if (candidates.empty ())
5418     return {};
5419
5420   block_symbol info = candidates[0];
5421   info.symbol = fixup_symbol_section (info.symbol, NULL);
5422   return info;
5423 }
5424
5425
5426 /* True iff STR is a possible encoded suffix of a normal Ada name
5427    that is to be ignored for matching purposes.  Suffixes of parallel
5428    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5429    are given by any of the regular expressions:
5430
5431    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5432    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5433    TKB              [subprogram suffix for task bodies]
5434    _E[0-9]+[bs]$    [protected object entry suffixes]
5435    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5436
5437    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5438    match is performed.  This sequence is used to differentiate homonyms,
5439    is an optional part of a valid name suffix.  */
5440
5441 static int
5442 is_name_suffix (const char *str)
5443 {
5444   int k;
5445   const char *matching;
5446   const int len = strlen (str);
5447
5448   /* Skip optional leading __[0-9]+.  */
5449
5450   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5451     {
5452       str += 3;
5453       while (isdigit (str[0]))
5454         str += 1;
5455     }
5456   
5457   /* [.$][0-9]+ */
5458
5459   if (str[0] == '.' || str[0] == '$')
5460     {
5461       matching = str + 1;
5462       while (isdigit (matching[0]))
5463         matching += 1;
5464       if (matching[0] == '\0')
5465         return 1;
5466     }
5467
5468   /* ___[0-9]+ */
5469
5470   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5471     {
5472       matching = str + 3;
5473       while (isdigit (matching[0]))
5474         matching += 1;
5475       if (matching[0] == '\0')
5476         return 1;
5477     }
5478
5479   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
5480
5481   if (strcmp (str, "TKB") == 0)
5482     return 1;
5483
5484 #if 0
5485   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5486      with a N at the end.  Unfortunately, the compiler uses the same
5487      convention for other internal types it creates.  So treating
5488      all entity names that end with an "N" as a name suffix causes
5489      some regressions.  For instance, consider the case of an enumerated
5490      type.  To support the 'Image attribute, it creates an array whose
5491      name ends with N.
5492      Having a single character like this as a suffix carrying some
5493      information is a bit risky.  Perhaps we should change the encoding
5494      to be something like "_N" instead.  In the meantime, do not do
5495      the following check.  */
5496   /* Protected Object Subprograms */
5497   if (len == 1 && str [0] == 'N')
5498     return 1;
5499 #endif
5500
5501   /* _E[0-9]+[bs]$ */
5502   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5503     {
5504       matching = str + 3;
5505       while (isdigit (matching[0]))
5506         matching += 1;
5507       if ((matching[0] == 'b' || matching[0] == 's')
5508           && matching [1] == '\0')
5509         return 1;
5510     }
5511
5512   /* ??? We should not modify STR directly, as we are doing below.  This
5513      is fine in this case, but may become problematic later if we find
5514      that this alternative did not work, and want to try matching
5515      another one from the begining of STR.  Since we modified it, we
5516      won't be able to find the begining of the string anymore!  */
5517   if (str[0] == 'X')
5518     {
5519       str += 1;
5520       while (str[0] != '_' && str[0] != '\0')
5521         {
5522           if (str[0] != 'n' && str[0] != 'b')
5523             return 0;
5524           str += 1;
5525         }
5526     }
5527
5528   if (str[0] == '\000')
5529     return 1;
5530
5531   if (str[0] == '_')
5532     {
5533       if (str[1] != '_' || str[2] == '\000')
5534         return 0;
5535       if (str[2] == '_')
5536         {
5537           if (strcmp (str + 3, "JM") == 0)
5538             return 1;
5539           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5540              the LJM suffix in favor of the JM one.  But we will
5541              still accept LJM as a valid suffix for a reasonable
5542              amount of time, just to allow ourselves to debug programs
5543              compiled using an older version of GNAT.  */
5544           if (strcmp (str + 3, "LJM") == 0)
5545             return 1;
5546           if (str[3] != 'X')
5547             return 0;
5548           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5549               || str[4] == 'U' || str[4] == 'P')
5550             return 1;
5551           if (str[4] == 'R' && str[5] != 'T')
5552             return 1;
5553           return 0;
5554         }
5555       if (!isdigit (str[2]))
5556         return 0;
5557       for (k = 3; str[k] != '\0'; k += 1)
5558         if (!isdigit (str[k]) && str[k] != '_')
5559           return 0;
5560       return 1;
5561     }
5562   if (str[0] == '$' && isdigit (str[1]))
5563     {
5564       for (k = 2; str[k] != '\0'; k += 1)
5565         if (!isdigit (str[k]) && str[k] != '_')
5566           return 0;
5567       return 1;
5568     }
5569   return 0;
5570 }
5571
5572 /* Return non-zero if the string starting at NAME and ending before
5573    NAME_END contains no capital letters.  */
5574
5575 static int
5576 is_valid_name_for_wild_match (const char *name0)
5577 {
5578   std::string decoded_name = ada_decode (name0);
5579   int i;
5580
5581   /* If the decoded name starts with an angle bracket, it means that
5582      NAME0 does not follow the GNAT encoding format.  It should then
5583      not be allowed as a possible wild match.  */
5584   if (decoded_name[0] == '<')
5585     return 0;
5586
5587   for (i=0; decoded_name[i] != '\0'; i++)
5588     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5589       return 0;
5590
5591   return 1;
5592 }
5593
5594 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5595    character which could start a simple name.  Assumes that *NAMEP points
5596    somewhere inside the string beginning at NAME0.  */
5597
5598 static int
5599 advance_wild_match (const char **namep, const char *name0, char target0)
5600 {
5601   const char *name = *namep;
5602
5603   while (1)
5604     {
5605       char t0, t1;
5606
5607       t0 = *name;
5608       if (t0 == '_')
5609         {
5610           t1 = name[1];
5611           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5612             {
5613               name += 1;
5614               if (name == name0 + 5 && startswith (name0, "_ada"))
5615                 break;
5616               else
5617                 name += 1;
5618             }
5619           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5620                                  || name[2] == target0))
5621             {
5622               name += 2;
5623               break;
5624             }
5625           else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
5626             {
5627               /* Names like "pkg__B_N__name", where N is a number, are
5628                  block-local.  We can handle these by simply skipping
5629                  the "B_" here.  */
5630               name += 4;
5631             }
5632           else
5633             return 0;
5634         }
5635       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5636         name += 1;
5637       else
5638         return 0;
5639     }
5640
5641   *namep = name;
5642   return 1;
5643 }
5644
5645 /* Return true iff NAME encodes a name of the form prefix.PATN.
5646    Ignores any informational suffixes of NAME (i.e., for which
5647    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
5648    simple name.  */
5649
5650 static bool
5651 wild_match (const char *name, const char *patn)
5652 {
5653   const char *p;
5654   const char *name0 = name;
5655
5656   while (1)
5657     {
5658       const char *match = name;
5659
5660       if (*name == *patn)
5661         {
5662           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5663             if (*p != *name)
5664               break;
5665           if (*p == '\0' && is_name_suffix (name))
5666             return match == name0 || is_valid_name_for_wild_match (name0);
5667
5668           if (name[-1] == '_')
5669             name -= 1;
5670         }
5671       if (!advance_wild_match (&name, name0, *patn))
5672         return false;
5673     }
5674 }
5675
5676 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
5677    necessary).  OBJFILE is the section containing BLOCK.  */
5678
5679 static void
5680 ada_add_block_symbols (std::vector<struct block_symbol> &result,
5681                        const struct block *block,
5682                        const lookup_name_info &lookup_name,
5683                        domain_enum domain, struct objfile *objfile)
5684 {
5685   struct block_iterator iter;
5686   /* A matching argument symbol, if any.  */
5687   struct symbol *arg_sym;
5688   /* Set true when we find a matching non-argument symbol.  */
5689   bool found_sym;
5690   struct symbol *sym;
5691
5692   arg_sym = NULL;
5693   found_sym = false;
5694   for (sym = block_iter_match_first (block, lookup_name, &iter);
5695        sym != NULL;
5696        sym = block_iter_match_next (lookup_name, &iter))
5697     {
5698       if (symbol_matches_domain (sym->language (), SYMBOL_DOMAIN (sym), domain))
5699         {
5700           if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5701             {
5702               if (SYMBOL_IS_ARGUMENT (sym))
5703                 arg_sym = sym;
5704               else
5705                 {
5706                   found_sym = true;
5707                   add_defn_to_vec (result,
5708                                    fixup_symbol_section (sym, objfile),
5709                                    block);
5710                 }
5711             }
5712         }
5713     }
5714
5715   /* Handle renamings.  */
5716
5717   if (ada_add_block_renamings (result, block, lookup_name, domain))
5718     found_sym = true;
5719
5720   if (!found_sym && arg_sym != NULL)
5721     {
5722       add_defn_to_vec (result,
5723                        fixup_symbol_section (arg_sym, objfile),
5724                        block);
5725     }
5726
5727   if (!lookup_name.ada ().wild_match_p ())
5728     {
5729       arg_sym = NULL;
5730       found_sym = false;
5731       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
5732       const char *name = ada_lookup_name.c_str ();
5733       size_t name_len = ada_lookup_name.size ();
5734
5735       ALL_BLOCK_SYMBOLS (block, iter, sym)
5736       {
5737         if (symbol_matches_domain (sym->language (),
5738                                    SYMBOL_DOMAIN (sym), domain))
5739           {
5740             int cmp;
5741
5742             cmp = (int) '_' - (int) sym->linkage_name ()[0];
5743             if (cmp == 0)
5744               {
5745                 cmp = !startswith (sym->linkage_name (), "_ada_");
5746                 if (cmp == 0)
5747                   cmp = strncmp (name, sym->linkage_name () + 5,
5748                                  name_len);
5749               }
5750
5751             if (cmp == 0
5752                 && is_name_suffix (sym->linkage_name () + name_len + 5))
5753               {
5754                 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5755                   {
5756                     if (SYMBOL_IS_ARGUMENT (sym))
5757                       arg_sym = sym;
5758                     else
5759                       {
5760                         found_sym = true;
5761                         add_defn_to_vec (result,
5762                                          fixup_symbol_section (sym, objfile),
5763                                          block);
5764                       }
5765                   }
5766               }
5767           }
5768       }
5769
5770       /* NOTE: This really shouldn't be needed for _ada_ symbols.
5771          They aren't parameters, right?  */
5772       if (!found_sym && arg_sym != NULL)
5773         {
5774           add_defn_to_vec (result,
5775                            fixup_symbol_section (arg_sym, objfile),
5776                            block);
5777         }
5778     }
5779 }
5780 \f
5781
5782                                 /* Symbol Completion */
5783
5784 /* See symtab.h.  */
5785
5786 bool
5787 ada_lookup_name_info::matches
5788   (const char *sym_name,
5789    symbol_name_match_type match_type,
5790    completion_match_result *comp_match_res) const
5791 {
5792   bool match = false;
5793   const char *text = m_encoded_name.c_str ();
5794   size_t text_len = m_encoded_name.size ();
5795
5796   /* First, test against the fully qualified name of the symbol.  */
5797
5798   if (strncmp (sym_name, text, text_len) == 0)
5799     match = true;
5800
5801   std::string decoded_name = ada_decode (sym_name);
5802   if (match && !m_encoded_p)
5803     {
5804       /* One needed check before declaring a positive match is to verify
5805          that iff we are doing a verbatim match, the decoded version
5806          of the symbol name starts with '<'.  Otherwise, this symbol name
5807          is not a suitable completion.  */
5808
5809       bool has_angle_bracket = (decoded_name[0] == '<');
5810       match = (has_angle_bracket == m_verbatim_p);
5811     }
5812
5813   if (match && !m_verbatim_p)
5814     {
5815       /* When doing non-verbatim match, another check that needs to
5816          be done is to verify that the potentially matching symbol name
5817          does not include capital letters, because the ada-mode would
5818          not be able to understand these symbol names without the
5819          angle bracket notation.  */
5820       const char *tmp;
5821
5822       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5823       if (*tmp != '\0')
5824         match = false;
5825     }
5826
5827   /* Second: Try wild matching...  */
5828
5829   if (!match && m_wild_match_p)
5830     {
5831       /* Since we are doing wild matching, this means that TEXT
5832          may represent an unqualified symbol name.  We therefore must
5833          also compare TEXT against the unqualified name of the symbol.  */
5834       sym_name = ada_unqualified_name (decoded_name.c_str ());
5835
5836       if (strncmp (sym_name, text, text_len) == 0)
5837         match = true;
5838     }
5839
5840   /* Finally: If we found a match, prepare the result to return.  */
5841
5842   if (!match)
5843     return false;
5844
5845   if (comp_match_res != NULL)
5846     {
5847       std::string &match_str = comp_match_res->match.storage ();
5848
5849       if (!m_encoded_p)
5850         match_str = ada_decode (sym_name);
5851       else
5852         {
5853           if (m_verbatim_p)
5854             match_str = add_angle_brackets (sym_name);
5855           else
5856             match_str = sym_name;
5857
5858         }
5859
5860       comp_match_res->set_match (match_str.c_str ());
5861     }
5862
5863   return true;
5864 }
5865
5866                                 /* Field Access */
5867
5868 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5869    for tagged types.  */
5870
5871 static int
5872 ada_is_dispatch_table_ptr_type (struct type *type)
5873 {
5874   const char *name;
5875
5876   if (type->code () != TYPE_CODE_PTR)
5877     return 0;
5878
5879   name = TYPE_TARGET_TYPE (type)->name ();
5880   if (name == NULL)
5881     return 0;
5882
5883   return (strcmp (name, "ada__tags__dispatch_table") == 0);
5884 }
5885
5886 /* Return non-zero if TYPE is an interface tag.  */
5887
5888 static int
5889 ada_is_interface_tag (struct type *type)
5890 {
5891   const char *name = type->name ();
5892
5893   if (name == NULL)
5894     return 0;
5895
5896   return (strcmp (name, "ada__tags__interface_tag") == 0);
5897 }
5898
5899 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5900    to be invisible to users.  */
5901
5902 int
5903 ada_is_ignored_field (struct type *type, int field_num)
5904 {
5905   if (field_num < 0 || field_num > type->num_fields ())
5906     return 1;
5907
5908   /* Check the name of that field.  */
5909   {
5910     const char *name = TYPE_FIELD_NAME (type, field_num);
5911
5912     /* Anonymous field names should not be printed.
5913        brobecker/2007-02-20: I don't think this can actually happen
5914        but we don't want to print the value of anonymous fields anyway.  */
5915     if (name == NULL)
5916       return 1;
5917
5918     /* Normally, fields whose name start with an underscore ("_")
5919        are fields that have been internally generated by the compiler,
5920        and thus should not be printed.  The "_parent" field is special,
5921        however: This is a field internally generated by the compiler
5922        for tagged types, and it contains the components inherited from
5923        the parent type.  This field should not be printed as is, but
5924        should not be ignored either.  */
5925     if (name[0] == '_' && !startswith (name, "_parent"))
5926       return 1;
5927   }
5928
5929   /* If this is the dispatch table of a tagged type or an interface tag,
5930      then ignore.  */
5931   if (ada_is_tagged_type (type, 1)
5932       && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
5933           || ada_is_interface_tag (type->field (field_num).type ())))
5934     return 1;
5935
5936   /* Not a special field, so it should not be ignored.  */
5937   return 0;
5938 }
5939
5940 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
5941    pointer or reference type whose ultimate target has a tag field.  */
5942
5943 int
5944 ada_is_tagged_type (struct type *type, int refok)
5945 {
5946   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
5947 }
5948
5949 /* True iff TYPE represents the type of X'Tag */
5950
5951 int
5952 ada_is_tag_type (struct type *type)
5953 {
5954   type = ada_check_typedef (type);
5955
5956   if (type == NULL || type->code () != TYPE_CODE_PTR)
5957     return 0;
5958   else
5959     {
5960       const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5961
5962       return (name != NULL
5963               && strcmp (name, "ada__tags__dispatch_table") == 0);
5964     }
5965 }
5966
5967 /* The type of the tag on VAL.  */
5968
5969 static struct type *
5970 ada_tag_type (struct value *val)
5971 {
5972   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
5973 }
5974
5975 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
5976    retired at Ada 05).  */
5977
5978 static int
5979 is_ada95_tag (struct value *tag)
5980 {
5981   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
5982 }
5983
5984 /* The value of the tag on VAL.  */
5985
5986 static struct value *
5987 ada_value_tag (struct value *val)
5988 {
5989   return ada_value_struct_elt (val, "_tag", 0);
5990 }
5991
5992 /* The value of the tag on the object of type TYPE whose contents are
5993    saved at VALADDR, if it is non-null, or is at memory address
5994    ADDRESS.  */
5995
5996 static struct value *
5997 value_tag_from_contents_and_address (struct type *type,
5998                                      const gdb_byte *valaddr,
5999                                      CORE_ADDR address)
6000 {
6001   int tag_byte_offset;
6002   struct type *tag_type;
6003
6004   if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
6005                          NULL, NULL, NULL))
6006     {
6007       const gdb_byte *valaddr1 = ((valaddr == NULL)
6008                                   ? NULL
6009                                   : valaddr + tag_byte_offset);
6010       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6011
6012       return value_from_contents_and_address (tag_type, valaddr1, address1);
6013     }
6014   return NULL;
6015 }
6016
6017 static struct type *
6018 type_from_tag (struct value *tag)
6019 {
6020   gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6021
6022   if (type_name != NULL)
6023     return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6024   return NULL;
6025 }
6026
6027 /* Given a value OBJ of a tagged type, return a value of this
6028    type at the base address of the object.  The base address, as
6029    defined in Ada.Tags, it is the address of the primary tag of
6030    the object, and therefore where the field values of its full
6031    view can be fetched.  */
6032
6033 struct value *
6034 ada_tag_value_at_base_address (struct value *obj)
6035 {
6036   struct value *val;
6037   LONGEST offset_to_top = 0;
6038   struct type *ptr_type, *obj_type;
6039   struct value *tag;
6040   CORE_ADDR base_address;
6041
6042   obj_type = value_type (obj);
6043
6044   /* It is the responsability of the caller to deref pointers.  */
6045
6046   if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6047     return obj;
6048
6049   tag = ada_value_tag (obj);
6050   if (!tag)
6051     return obj;
6052
6053   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6054
6055   if (is_ada95_tag (tag))
6056     return obj;
6057
6058   ptr_type = language_lookup_primitive_type
6059     (language_def (language_ada), target_gdbarch(), "storage_offset");
6060   ptr_type = lookup_pointer_type (ptr_type);
6061   val = value_cast (ptr_type, tag);
6062   if (!val)
6063     return obj;
6064
6065   /* It is perfectly possible that an exception be raised while
6066      trying to determine the base address, just like for the tag;
6067      see ada_tag_name for more details.  We do not print the error
6068      message for the same reason.  */
6069
6070   try
6071     {
6072       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6073     }
6074
6075   catch (const gdb_exception_error &e)
6076     {
6077       return obj;
6078     }
6079
6080   /* If offset is null, nothing to do.  */
6081
6082   if (offset_to_top == 0)
6083     return obj;
6084
6085   /* -1 is a special case in Ada.Tags; however, what should be done
6086      is not quite clear from the documentation.  So do nothing for
6087      now.  */
6088
6089   if (offset_to_top == -1)
6090     return obj;
6091
6092   /* OFFSET_TO_TOP used to be a positive value to be subtracted
6093      from the base address.  This was however incompatible with
6094      C++ dispatch table: C++ uses a *negative* value to *add*
6095      to the base address.  Ada's convention has therefore been
6096      changed in GNAT 19.0w 20171023: since then, C++ and Ada
6097      use the same convention.  Here, we support both cases by
6098      checking the sign of OFFSET_TO_TOP.  */
6099
6100   if (offset_to_top > 0)
6101     offset_to_top = -offset_to_top;
6102
6103   base_address = value_address (obj) + offset_to_top;
6104   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6105
6106   /* Make sure that we have a proper tag at the new address.
6107      Otherwise, offset_to_top is bogus (which can happen when
6108      the object is not initialized yet).  */
6109
6110   if (!tag)
6111     return obj;
6112
6113   obj_type = type_from_tag (tag);
6114
6115   if (!obj_type)
6116     return obj;
6117
6118   return value_from_contents_and_address (obj_type, NULL, base_address);
6119 }
6120
6121 /* Return the "ada__tags__type_specific_data" type.  */
6122
6123 static struct type *
6124 ada_get_tsd_type (struct inferior *inf)
6125 {
6126   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6127
6128   if (data->tsd_type == 0)
6129     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6130   return data->tsd_type;
6131 }
6132
6133 /* Return the TSD (type-specific data) associated to the given TAG.
6134    TAG is assumed to be the tag of a tagged-type entity.
6135
6136    May return NULL if we are unable to get the TSD.  */
6137
6138 static struct value *
6139 ada_get_tsd_from_tag (struct value *tag)
6140 {
6141   struct value *val;
6142   struct type *type;
6143
6144   /* First option: The TSD is simply stored as a field of our TAG.
6145      Only older versions of GNAT would use this format, but we have
6146      to test it first, because there are no visible markers for
6147      the current approach except the absence of that field.  */
6148
6149   val = ada_value_struct_elt (tag, "tsd", 1);
6150   if (val)
6151     return val;
6152
6153   /* Try the second representation for the dispatch table (in which
6154      there is no explicit 'tsd' field in the referent of the tag pointer,
6155      and instead the tsd pointer is stored just before the dispatch
6156      table.  */
6157
6158   type = ada_get_tsd_type (current_inferior());
6159   if (type == NULL)
6160     return NULL;
6161   type = lookup_pointer_type (lookup_pointer_type (type));
6162   val = value_cast (type, tag);
6163   if (val == NULL)
6164     return NULL;
6165   return value_ind (value_ptradd (val, -1));
6166 }
6167
6168 /* Given the TSD of a tag (type-specific data), return a string
6169    containing the name of the associated type.
6170
6171    May return NULL if we are unable to determine the tag name.  */
6172
6173 static gdb::unique_xmalloc_ptr<char>
6174 ada_tag_name_from_tsd (struct value *tsd)
6175 {
6176   char *p;
6177   struct value *val;
6178
6179   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6180   if (val == NULL)
6181     return NULL;
6182   gdb::unique_xmalloc_ptr<char> buffer
6183     = target_read_string (value_as_address (val), INT_MAX);
6184   if (buffer == nullptr)
6185     return nullptr;
6186
6187   for (p = buffer.get (); *p != '\0'; ++p)
6188     {
6189       if (isalpha (*p))
6190         *p = tolower (*p);
6191     }
6192
6193   return buffer;
6194 }
6195
6196 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6197    a C string.
6198
6199    Return NULL if the TAG is not an Ada tag, or if we were unable to
6200    determine the name of that tag.  */
6201
6202 gdb::unique_xmalloc_ptr<char>
6203 ada_tag_name (struct value *tag)
6204 {
6205   gdb::unique_xmalloc_ptr<char> name;
6206
6207   if (!ada_is_tag_type (value_type (tag)))
6208     return NULL;
6209
6210   /* It is perfectly possible that an exception be raised while trying
6211      to determine the TAG's name, even under normal circumstances:
6212      The associated variable may be uninitialized or corrupted, for
6213      instance. We do not let any exception propagate past this point.
6214      instead we return NULL.
6215
6216      We also do not print the error message either (which often is very
6217      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6218      the caller print a more meaningful message if necessary.  */
6219   try
6220     {
6221       struct value *tsd = ada_get_tsd_from_tag (tag);
6222
6223       if (tsd != NULL)
6224         name = ada_tag_name_from_tsd (tsd);
6225     }
6226   catch (const gdb_exception_error &e)
6227     {
6228     }
6229
6230   return name;
6231 }
6232
6233 /* The parent type of TYPE, or NULL if none.  */
6234
6235 struct type *
6236 ada_parent_type (struct type *type)
6237 {
6238   int i;
6239
6240   type = ada_check_typedef (type);
6241
6242   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6243     return NULL;
6244
6245   for (i = 0; i < type->num_fields (); i += 1)
6246     if (ada_is_parent_field (type, i))
6247       {
6248         struct type *parent_type = type->field (i).type ();
6249
6250         /* If the _parent field is a pointer, then dereference it.  */
6251         if (parent_type->code () == TYPE_CODE_PTR)
6252           parent_type = TYPE_TARGET_TYPE (parent_type);
6253         /* If there is a parallel XVS type, get the actual base type.  */
6254         parent_type = ada_get_base_type (parent_type);
6255
6256         return ada_check_typedef (parent_type);
6257       }
6258
6259   return NULL;
6260 }
6261
6262 /* True iff field number FIELD_NUM of structure type TYPE contains the
6263    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6264    a structure type with at least FIELD_NUM+1 fields.  */
6265
6266 int
6267 ada_is_parent_field (struct type *type, int field_num)
6268 {
6269   const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
6270
6271   return (name != NULL
6272           && (startswith (name, "PARENT")
6273               || startswith (name, "_parent")));
6274 }
6275
6276 /* True iff field number FIELD_NUM of structure type TYPE is a
6277    transparent wrapper field (which should be silently traversed when doing
6278    field selection and flattened when printing).  Assumes TYPE is a
6279    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6280    structures.  */
6281
6282 int
6283 ada_is_wrapper_field (struct type *type, int field_num)
6284 {
6285   const char *name = TYPE_FIELD_NAME (type, field_num);
6286
6287   if (name != NULL && strcmp (name, "RETVAL") == 0)
6288     {
6289       /* This happens in functions with "out" or "in out" parameters
6290          which are passed by copy.  For such functions, GNAT describes
6291          the function's return type as being a struct where the return
6292          value is in a field called RETVAL, and where the other "out"
6293          or "in out" parameters are fields of that struct.  This is not
6294          a wrapper.  */
6295       return 0;
6296     }
6297
6298   return (name != NULL
6299           && (startswith (name, "PARENT")
6300               || strcmp (name, "REP") == 0
6301               || startswith (name, "_parent")
6302               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6303 }
6304
6305 /* True iff field number FIELD_NUM of structure or union type TYPE
6306    is a variant wrapper.  Assumes TYPE is a structure type with at least
6307    FIELD_NUM+1 fields.  */
6308
6309 int
6310 ada_is_variant_part (struct type *type, int field_num)
6311 {
6312   /* Only Ada types are eligible.  */
6313   if (!ADA_TYPE_P (type))
6314     return 0;
6315
6316   struct type *field_type = type->field (field_num).type ();
6317
6318   return (field_type->code () == TYPE_CODE_UNION
6319           || (is_dynamic_field (type, field_num)
6320               && (TYPE_TARGET_TYPE (field_type)->code ()
6321                   == TYPE_CODE_UNION)));
6322 }
6323
6324 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6325    whose discriminants are contained in the record type OUTER_TYPE,
6326    returns the type of the controlling discriminant for the variant.
6327    May return NULL if the type could not be found.  */
6328
6329 struct type *
6330 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6331 {
6332   const char *name = ada_variant_discrim_name (var_type);
6333
6334   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6335 }
6336
6337 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6338    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6339    represents a 'when others' clause; otherwise 0.  */
6340
6341 static int
6342 ada_is_others_clause (struct type *type, int field_num)
6343 {
6344   const char *name = TYPE_FIELD_NAME (type, field_num);
6345
6346   return (name != NULL && name[0] == 'O');
6347 }
6348
6349 /* Assuming that TYPE0 is the type of the variant part of a record,
6350    returns the name of the discriminant controlling the variant.
6351    The value is valid until the next call to ada_variant_discrim_name.  */
6352
6353 const char *
6354 ada_variant_discrim_name (struct type *type0)
6355 {
6356   static std::string result;
6357   struct type *type;
6358   const char *name;
6359   const char *discrim_end;
6360   const char *discrim_start;
6361
6362   if (type0->code () == TYPE_CODE_PTR)
6363     type = TYPE_TARGET_TYPE (type0);
6364   else
6365     type = type0;
6366
6367   name = ada_type_name (type);
6368
6369   if (name == NULL || name[0] == '\000')
6370     return "";
6371
6372   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6373        discrim_end -= 1)
6374     {
6375       if (startswith (discrim_end, "___XVN"))
6376         break;
6377     }
6378   if (discrim_end == name)
6379     return "";
6380
6381   for (discrim_start = discrim_end; discrim_start != name + 3;
6382        discrim_start -= 1)
6383     {
6384       if (discrim_start == name + 1)
6385         return "";
6386       if ((discrim_start > name + 3
6387            && startswith (discrim_start - 3, "___"))
6388           || discrim_start[-1] == '.')
6389         break;
6390     }
6391
6392   result = std::string (discrim_start, discrim_end - discrim_start);
6393   return result.c_str ();
6394 }
6395
6396 /* Scan STR for a subtype-encoded number, beginning at position K.
6397    Put the position of the character just past the number scanned in
6398    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
6399    Return 1 if there was a valid number at the given position, and 0
6400    otherwise.  A "subtype-encoded" number consists of the absolute value
6401    in decimal, followed by the letter 'm' to indicate a negative number.
6402    Assumes 0m does not occur.  */
6403
6404 int
6405 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6406 {
6407   ULONGEST RU;
6408
6409   if (!isdigit (str[k]))
6410     return 0;
6411
6412   /* Do it the hard way so as not to make any assumption about
6413      the relationship of unsigned long (%lu scan format code) and
6414      LONGEST.  */
6415   RU = 0;
6416   while (isdigit (str[k]))
6417     {
6418       RU = RU * 10 + (str[k] - '0');
6419       k += 1;
6420     }
6421
6422   if (str[k] == 'm')
6423     {
6424       if (R != NULL)
6425         *R = (-(LONGEST) (RU - 1)) - 1;
6426       k += 1;
6427     }
6428   else if (R != NULL)
6429     *R = (LONGEST) RU;
6430
6431   /* NOTE on the above: Technically, C does not say what the results of
6432      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6433      number representable as a LONGEST (although either would probably work
6434      in most implementations).  When RU>0, the locution in the then branch
6435      above is always equivalent to the negative of RU.  */
6436
6437   if (new_k != NULL)
6438     *new_k = k;
6439   return 1;
6440 }
6441
6442 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6443    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6444    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
6445
6446 static int
6447 ada_in_variant (LONGEST val, struct type *type, int field_num)
6448 {
6449   const char *name = TYPE_FIELD_NAME (type, field_num);
6450   int p;
6451
6452   p = 0;
6453   while (1)
6454     {
6455       switch (name[p])
6456         {
6457         case '\0':
6458           return 0;
6459         case 'S':
6460           {
6461             LONGEST W;
6462
6463             if (!ada_scan_number (name, p + 1, &W, &p))
6464               return 0;
6465             if (val == W)
6466               return 1;
6467             break;
6468           }
6469         case 'R':
6470           {
6471             LONGEST L, U;
6472
6473             if (!ada_scan_number (name, p + 1, &L, &p)
6474                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6475               return 0;
6476             if (val >= L && val <= U)
6477               return 1;
6478             break;
6479           }
6480         case 'O':
6481           return 1;
6482         default:
6483           return 0;
6484         }
6485     }
6486 }
6487
6488 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
6489
6490 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6491    ARG_TYPE, extract and return the value of one of its (non-static)
6492    fields.  FIELDNO says which field.   Differs from value_primitive_field
6493    only in that it can handle packed values of arbitrary type.  */
6494
6495 struct value *
6496 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6497                            struct type *arg_type)
6498 {
6499   struct type *type;
6500
6501   arg_type = ada_check_typedef (arg_type);
6502   type = arg_type->field (fieldno).type ();
6503
6504   /* Handle packed fields.  It might be that the field is not packed
6505      relative to its containing structure, but the structure itself is
6506      packed; in this case we must take the bit-field path.  */
6507   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6508     {
6509       int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6510       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6511
6512       return ada_value_primitive_packed_val (arg1, value_contents (arg1),
6513                                              offset + bit_pos / 8,
6514                                              bit_pos % 8, bit_size, type);
6515     }
6516   else
6517     return value_primitive_field (arg1, offset, fieldno, arg_type);
6518 }
6519
6520 /* Find field with name NAME in object of type TYPE.  If found, 
6521    set the following for each argument that is non-null:
6522     - *FIELD_TYPE_P to the field's type; 
6523     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
6524       an object of that type;
6525     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
6526     - *BIT_SIZE_P to its size in bits if the field is packed, and 
6527       0 otherwise;
6528    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6529    fields up to but not including the desired field, or by the total
6530    number of fields if not found.   A NULL value of NAME never
6531    matches; the function just counts visible fields in this case.
6532    
6533    Notice that we need to handle when a tagged record hierarchy
6534    has some components with the same name, like in this scenario:
6535
6536       type Top_T is tagged record
6537          N : Integer := 1;
6538          U : Integer := 974;
6539          A : Integer := 48;
6540       end record;
6541
6542       type Middle_T is new Top.Top_T with record
6543          N : Character := 'a';
6544          C : Integer := 3;
6545       end record;
6546
6547      type Bottom_T is new Middle.Middle_T with record
6548         N : Float := 4.0;
6549         C : Character := '5';
6550         X : Integer := 6;
6551         A : Character := 'J';
6552      end record;
6553
6554    Let's say we now have a variable declared and initialized as follow:
6555
6556      TC : Top_A := new Bottom_T;
6557
6558    And then we use this variable to call this function
6559
6560      procedure Assign (Obj: in out Top_T; TV : Integer);
6561
6562    as follow:
6563
6564       Assign (Top_T (B), 12);
6565
6566    Now, we're in the debugger, and we're inside that procedure
6567    then and we want to print the value of obj.c:
6568
6569    Usually, the tagged record or one of the parent type owns the
6570    component to print and there's no issue but in this particular
6571    case, what does it mean to ask for Obj.C? Since the actual
6572    type for object is type Bottom_T, it could mean two things: type
6573    component C from the Middle_T view, but also component C from
6574    Bottom_T.  So in that "undefined" case, when the component is
6575    not found in the non-resolved type (which includes all the
6576    components of the parent type), then resolve it and see if we
6577    get better luck once expanded.
6578
6579    In the case of homonyms in the derived tagged type, we don't
6580    guaranty anything, and pick the one that's easiest for us
6581    to program.
6582
6583    Returns 1 if found, 0 otherwise.  */
6584
6585 static int
6586 find_struct_field (const char *name, struct type *type, int offset,
6587                    struct type **field_type_p,
6588                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6589                    int *index_p)
6590 {
6591   int i;
6592   int parent_offset = -1;
6593
6594   type = ada_check_typedef (type);
6595
6596   if (field_type_p != NULL)
6597     *field_type_p = NULL;
6598   if (byte_offset_p != NULL)
6599     *byte_offset_p = 0;
6600   if (bit_offset_p != NULL)
6601     *bit_offset_p = 0;
6602   if (bit_size_p != NULL)
6603     *bit_size_p = 0;
6604
6605   for (i = 0; i < type->num_fields (); i += 1)
6606     {
6607       int bit_pos = TYPE_FIELD_BITPOS (type, i);
6608       int fld_offset = offset + bit_pos / 8;
6609       const char *t_field_name = TYPE_FIELD_NAME (type, i);
6610
6611       if (t_field_name == NULL)
6612         continue;
6613
6614       else if (ada_is_parent_field (type, i))
6615         {
6616           /* This is a field pointing us to the parent type of a tagged
6617              type.  As hinted in this function's documentation, we give
6618              preference to fields in the current record first, so what
6619              we do here is just record the index of this field before
6620              we skip it.  If it turns out we couldn't find our field
6621              in the current record, then we'll get back to it and search
6622              inside it whether the field might exist in the parent.  */
6623
6624           parent_offset = i;
6625           continue;
6626         }
6627
6628       else if (name != NULL && field_name_match (t_field_name, name))
6629         {
6630           int bit_size = TYPE_FIELD_BITSIZE (type, i);
6631
6632           if (field_type_p != NULL)
6633             *field_type_p = type->field (i).type ();
6634           if (byte_offset_p != NULL)
6635             *byte_offset_p = fld_offset;
6636           if (bit_offset_p != NULL)
6637             *bit_offset_p = bit_pos % 8;
6638           if (bit_size_p != NULL)
6639             *bit_size_p = bit_size;
6640           return 1;
6641         }
6642       else if (ada_is_wrapper_field (type, i))
6643         {
6644           if (find_struct_field (name, type->field (i).type (), fld_offset,
6645                                  field_type_p, byte_offset_p, bit_offset_p,
6646                                  bit_size_p, index_p))
6647             return 1;
6648         }
6649       else if (ada_is_variant_part (type, i))
6650         {
6651           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
6652              fixed type?? */
6653           int j;
6654           struct type *field_type
6655             = ada_check_typedef (type->field (i).type ());
6656
6657           for (j = 0; j < field_type->num_fields (); j += 1)
6658             {
6659               if (find_struct_field (name, field_type->field (j).type (),
6660                                      fld_offset
6661                                      + TYPE_FIELD_BITPOS (field_type, j) / 8,
6662                                      field_type_p, byte_offset_p,
6663                                      bit_offset_p, bit_size_p, index_p))
6664                 return 1;
6665             }
6666         }
6667       else if (index_p != NULL)
6668         *index_p += 1;
6669     }
6670
6671   /* Field not found so far.  If this is a tagged type which
6672      has a parent, try finding that field in the parent now.  */
6673
6674   if (parent_offset != -1)
6675     {
6676       int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
6677       int fld_offset = offset + bit_pos / 8;
6678
6679       if (find_struct_field (name, type->field (parent_offset).type (),
6680                              fld_offset, field_type_p, byte_offset_p,
6681                              bit_offset_p, bit_size_p, index_p))
6682         return 1;
6683     }
6684
6685   return 0;
6686 }
6687
6688 /* Number of user-visible fields in record type TYPE.  */
6689
6690 static int
6691 num_visible_fields (struct type *type)
6692 {
6693   int n;
6694
6695   n = 0;
6696   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6697   return n;
6698 }
6699
6700 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
6701    and search in it assuming it has (class) type TYPE.
6702    If found, return value, else return NULL.
6703
6704    Searches recursively through wrapper fields (e.g., '_parent').
6705
6706    In the case of homonyms in the tagged types, please refer to the
6707    long explanation in find_struct_field's function documentation.  */
6708
6709 static struct value *
6710 ada_search_struct_field (const char *name, struct value *arg, int offset,
6711                          struct type *type)
6712 {
6713   int i;
6714   int parent_offset = -1;
6715
6716   type = ada_check_typedef (type);
6717   for (i = 0; i < type->num_fields (); i += 1)
6718     {
6719       const char *t_field_name = TYPE_FIELD_NAME (type, i);
6720
6721       if (t_field_name == NULL)
6722         continue;
6723
6724       else if (ada_is_parent_field (type, i))
6725         {
6726           /* This is a field pointing us to the parent type of a tagged
6727              type.  As hinted in this function's documentation, we give
6728              preference to fields in the current record first, so what
6729              we do here is just record the index of this field before
6730              we skip it.  If it turns out we couldn't find our field
6731              in the current record, then we'll get back to it and search
6732              inside it whether the field might exist in the parent.  */
6733
6734           parent_offset = i;
6735           continue;
6736         }
6737
6738       else if (field_name_match (t_field_name, name))
6739         return ada_value_primitive_field (arg, offset, i, type);
6740
6741       else if (ada_is_wrapper_field (type, i))
6742         {
6743           struct value *v =     /* Do not let indent join lines here.  */
6744             ada_search_struct_field (name, arg,
6745                                      offset + TYPE_FIELD_BITPOS (type, i) / 8,
6746                                      type->field (i).type ());
6747
6748           if (v != NULL)
6749             return v;
6750         }
6751
6752       else if (ada_is_variant_part (type, i))
6753         {
6754           /* PNH: Do we ever get here?  See find_struct_field.  */
6755           int j;
6756           struct type *field_type = ada_check_typedef (type->field (i).type ());
6757           int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6758
6759           for (j = 0; j < field_type->num_fields (); j += 1)
6760             {
6761               struct value *v = ada_search_struct_field /* Force line
6762                                                            break.  */
6763                 (name, arg,
6764                  var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6765                  field_type->field (j).type ());
6766
6767               if (v != NULL)
6768                 return v;
6769             }
6770         }
6771     }
6772
6773   /* Field not found so far.  If this is a tagged type which
6774      has a parent, try finding that field in the parent now.  */
6775
6776   if (parent_offset != -1)
6777     {
6778       struct value *v = ada_search_struct_field (
6779         name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
6780         type->field (parent_offset).type ());
6781
6782       if (v != NULL)
6783         return v;
6784     }
6785
6786   return NULL;
6787 }
6788
6789 static struct value *ada_index_struct_field_1 (int *, struct value *,
6790                                                int, struct type *);
6791
6792
6793 /* Return field #INDEX in ARG, where the index is that returned by
6794  * find_struct_field through its INDEX_P argument.  Adjust the address
6795  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6796  * If found, return value, else return NULL.  */
6797
6798 static struct value *
6799 ada_index_struct_field (int index, struct value *arg, int offset,
6800                         struct type *type)
6801 {
6802   return ada_index_struct_field_1 (&index, arg, offset, type);
6803 }
6804
6805
6806 /* Auxiliary function for ada_index_struct_field.  Like
6807  * ada_index_struct_field, but takes index from *INDEX_P and modifies
6808  * *INDEX_P.  */
6809
6810 static struct value *
6811 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6812                           struct type *type)
6813 {
6814   int i;
6815   type = ada_check_typedef (type);
6816
6817   for (i = 0; i < type->num_fields (); i += 1)
6818     {
6819       if (TYPE_FIELD_NAME (type, i) == NULL)
6820         continue;
6821       else if (ada_is_wrapper_field (type, i))
6822         {
6823           struct value *v =     /* Do not let indent join lines here.  */
6824             ada_index_struct_field_1 (index_p, arg,
6825                                       offset + TYPE_FIELD_BITPOS (type, i) / 8,
6826                                       type->field (i).type ());
6827
6828           if (v != NULL)
6829             return v;
6830         }
6831
6832       else if (ada_is_variant_part (type, i))
6833         {
6834           /* PNH: Do we ever get here?  See ada_search_struct_field,
6835              find_struct_field.  */
6836           error (_("Cannot assign this kind of variant record"));
6837         }
6838       else if (*index_p == 0)
6839         return ada_value_primitive_field (arg, offset, i, type);
6840       else
6841         *index_p -= 1;
6842     }
6843   return NULL;
6844 }
6845
6846 /* Return a string representation of type TYPE.  */
6847
6848 static std::string
6849 type_as_string (struct type *type)
6850 {
6851   string_file tmp_stream;
6852
6853   type_print (type, "", &tmp_stream, -1);
6854
6855   return std::move (tmp_stream.string ());
6856 }
6857
6858 /* Given a type TYPE, look up the type of the component of type named NAME.
6859    If DISPP is non-null, add its byte displacement from the beginning of a
6860    structure (pointed to by a value) of type TYPE to *DISPP (does not
6861    work for packed fields).
6862
6863    Matches any field whose name has NAME as a prefix, possibly
6864    followed by "___".
6865
6866    TYPE can be either a struct or union.  If REFOK, TYPE may also 
6867    be a (pointer or reference)+ to a struct or union, and the
6868    ultimate target type will be searched.
6869
6870    Looks recursively into variant clauses and parent types.
6871
6872    In the case of homonyms in the tagged types, please refer to the
6873    long explanation in find_struct_field's function documentation.
6874
6875    If NOERR is nonzero, return NULL if NAME is not suitably defined or
6876    TYPE is not a type of the right kind.  */
6877
6878 static struct type *
6879 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
6880                             int noerr)
6881 {
6882   int i;
6883   int parent_offset = -1;
6884
6885   if (name == NULL)
6886     goto BadName;
6887
6888   if (refok && type != NULL)
6889     while (1)
6890       {
6891         type = ada_check_typedef (type);
6892         if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
6893           break;
6894         type = TYPE_TARGET_TYPE (type);
6895       }
6896
6897   if (type == NULL
6898       || (type->code () != TYPE_CODE_STRUCT
6899           && type->code () != TYPE_CODE_UNION))
6900     {
6901       if (noerr)
6902         return NULL;
6903
6904       error (_("Type %s is not a structure or union type"),
6905              type != NULL ? type_as_string (type).c_str () : _("(null)"));
6906     }
6907
6908   type = to_static_fixed_type (type);
6909
6910   for (i = 0; i < type->num_fields (); i += 1)
6911     {
6912       const char *t_field_name = TYPE_FIELD_NAME (type, i);
6913       struct type *t;
6914
6915       if (t_field_name == NULL)
6916         continue;
6917
6918       else if (ada_is_parent_field (type, i))
6919         {
6920           /* This is a field pointing us to the parent type of a tagged
6921              type.  As hinted in this function's documentation, we give
6922              preference to fields in the current record first, so what
6923              we do here is just record the index of this field before
6924              we skip it.  If it turns out we couldn't find our field
6925              in the current record, then we'll get back to it and search
6926              inside it whether the field might exist in the parent.  */
6927
6928           parent_offset = i;
6929           continue;
6930         }
6931
6932       else if (field_name_match (t_field_name, name))
6933         return type->field (i).type ();
6934
6935       else if (ada_is_wrapper_field (type, i))
6936         {
6937           t = ada_lookup_struct_elt_type (type->field (i).type (), name,
6938                                           0, 1);
6939           if (t != NULL)
6940             return t;
6941         }
6942
6943       else if (ada_is_variant_part (type, i))
6944         {
6945           int j;
6946           struct type *field_type = ada_check_typedef (type->field (i).type ());
6947
6948           for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
6949             {
6950               /* FIXME pnh 2008/01/26: We check for a field that is
6951                  NOT wrapped in a struct, since the compiler sometimes
6952                  generates these for unchecked variant types.  Revisit
6953                  if the compiler changes this practice.  */
6954               const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
6955
6956               if (v_field_name != NULL 
6957                   && field_name_match (v_field_name, name))
6958                 t = field_type->field (j).type ();
6959               else
6960                 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
6961                                                 name, 0, 1);
6962
6963               if (t != NULL)
6964                 return t;
6965             }
6966         }
6967
6968     }
6969
6970     /* Field not found so far.  If this is a tagged type which
6971        has a parent, try finding that field in the parent now.  */
6972
6973     if (parent_offset != -1)
6974       {
6975         struct type *t;
6976
6977         t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
6978                                         name, 0, 1);
6979         if (t != NULL)
6980           return t;
6981       }
6982
6983 BadName:
6984   if (!noerr)
6985     {
6986       const char *name_str = name != NULL ? name : _("<null>");
6987
6988       error (_("Type %s has no component named %s"),
6989              type_as_string (type).c_str (), name_str);
6990     }
6991
6992   return NULL;
6993 }
6994
6995 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6996    within a value of type OUTER_TYPE, return true iff VAR_TYPE
6997    represents an unchecked union (that is, the variant part of a
6998    record that is named in an Unchecked_Union pragma).  */
6999
7000 static int
7001 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7002 {
7003   const char *discrim_name = ada_variant_discrim_name (var_type);
7004
7005   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7006 }
7007
7008
7009 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7010    within OUTER, determine which variant clause (field number in VAR_TYPE,
7011    numbering from 0) is applicable.  Returns -1 if none are.  */
7012
7013 int
7014 ada_which_variant_applies (struct type *var_type, struct value *outer)
7015 {
7016   int others_clause;
7017   int i;
7018   const char *discrim_name = ada_variant_discrim_name (var_type);
7019   struct value *discrim;
7020   LONGEST discrim_val;
7021
7022   /* Using plain value_from_contents_and_address here causes problems
7023      because we will end up trying to resolve a type that is currently
7024      being constructed.  */
7025   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7026   if (discrim == NULL)
7027     return -1;
7028   discrim_val = value_as_long (discrim);
7029
7030   others_clause = -1;
7031   for (i = 0; i < var_type->num_fields (); i += 1)
7032     {
7033       if (ada_is_others_clause (var_type, i))
7034         others_clause = i;
7035       else if (ada_in_variant (discrim_val, var_type, i))
7036         return i;
7037     }
7038
7039   return others_clause;
7040 }
7041 \f
7042
7043
7044                                 /* Dynamic-Sized Records */
7045
7046 /* Strategy: The type ostensibly attached to a value with dynamic size
7047    (i.e., a size that is not statically recorded in the debugging
7048    data) does not accurately reflect the size or layout of the value.
7049    Our strategy is to convert these values to values with accurate,
7050    conventional types that are constructed on the fly.  */
7051
7052 /* There is a subtle and tricky problem here.  In general, we cannot
7053    determine the size of dynamic records without its data.  However,
7054    the 'struct value' data structure, which GDB uses to represent
7055    quantities in the inferior process (the target), requires the size
7056    of the type at the time of its allocation in order to reserve space
7057    for GDB's internal copy of the data.  That's why the
7058    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7059    rather than struct value*s.
7060
7061    However, GDB's internal history variables ($1, $2, etc.) are
7062    struct value*s containing internal copies of the data that are not, in
7063    general, the same as the data at their corresponding addresses in
7064    the target.  Fortunately, the types we give to these values are all
7065    conventional, fixed-size types (as per the strategy described
7066    above), so that we don't usually have to perform the
7067    'to_fixed_xxx_type' conversions to look at their values.
7068    Unfortunately, there is one exception: if one of the internal
7069    history variables is an array whose elements are unconstrained
7070    records, then we will need to create distinct fixed types for each
7071    element selected.  */
7072
7073 /* The upshot of all of this is that many routines take a (type, host
7074    address, target address) triple as arguments to represent a value.
7075    The host address, if non-null, is supposed to contain an internal
7076    copy of the relevant data; otherwise, the program is to consult the
7077    target at the target address.  */
7078
7079 /* Assuming that VAL0 represents a pointer value, the result of
7080    dereferencing it.  Differs from value_ind in its treatment of
7081    dynamic-sized types.  */
7082
7083 struct value *
7084 ada_value_ind (struct value *val0)
7085 {
7086   struct value *val = value_ind (val0);
7087
7088   if (ada_is_tagged_type (value_type (val), 0))
7089     val = ada_tag_value_at_base_address (val);
7090
7091   return ada_to_fixed_value (val);
7092 }
7093
7094 /* The value resulting from dereferencing any "reference to"
7095    qualifiers on VAL0.  */
7096
7097 static struct value *
7098 ada_coerce_ref (struct value *val0)
7099 {
7100   if (value_type (val0)->code () == TYPE_CODE_REF)
7101     {
7102       struct value *val = val0;
7103
7104       val = coerce_ref (val);
7105
7106       if (ada_is_tagged_type (value_type (val), 0))
7107         val = ada_tag_value_at_base_address (val);
7108
7109       return ada_to_fixed_value (val);
7110     }
7111   else
7112     return val0;
7113 }
7114
7115 /* Return the bit alignment required for field #F of template type TYPE.  */
7116
7117 static unsigned int
7118 field_alignment (struct type *type, int f)
7119 {
7120   const char *name = TYPE_FIELD_NAME (type, f);
7121   int len;
7122   int align_offset;
7123
7124   /* The field name should never be null, unless the debugging information
7125      is somehow malformed.  In this case, we assume the field does not
7126      require any alignment.  */
7127   if (name == NULL)
7128     return 1;
7129
7130   len = strlen (name);
7131
7132   if (!isdigit (name[len - 1]))
7133     return 1;
7134
7135   if (isdigit (name[len - 2]))
7136     align_offset = len - 2;
7137   else
7138     align_offset = len - 1;
7139
7140   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7141     return TARGET_CHAR_BIT;
7142
7143   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7144 }
7145
7146 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7147
7148 static struct symbol *
7149 ada_find_any_type_symbol (const char *name)
7150 {
7151   struct symbol *sym;
7152
7153   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7154   if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7155     return sym;
7156
7157   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7158   return sym;
7159 }
7160
7161 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7162    solely for types defined by debug info, it will not search the GDB
7163    primitive types.  */
7164
7165 static struct type *
7166 ada_find_any_type (const char *name)
7167 {
7168   struct symbol *sym = ada_find_any_type_symbol (name);
7169
7170   if (sym != NULL)
7171     return SYMBOL_TYPE (sym);
7172
7173   return NULL;
7174 }
7175
7176 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7177    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
7178    symbol, in which case it is returned.  Otherwise, this looks for
7179    symbols whose name is that of NAME_SYM suffixed with  "___XR".
7180    Return symbol if found, and NULL otherwise.  */
7181
7182 static bool
7183 ada_is_renaming_symbol (struct symbol *name_sym)
7184 {
7185   const char *name = name_sym->linkage_name ();
7186   return strstr (name, "___XR") != NULL;
7187 }
7188
7189 /* Because of GNAT encoding conventions, several GDB symbols may match a
7190    given type name.  If the type denoted by TYPE0 is to be preferred to
7191    that of TYPE1 for purposes of type printing, return non-zero;
7192    otherwise return 0.  */
7193
7194 int
7195 ada_prefer_type (struct type *type0, struct type *type1)
7196 {
7197   if (type1 == NULL)
7198     return 1;
7199   else if (type0 == NULL)
7200     return 0;
7201   else if (type1->code () == TYPE_CODE_VOID)
7202     return 1;
7203   else if (type0->code () == TYPE_CODE_VOID)
7204     return 0;
7205   else if (type1->name () == NULL && type0->name () != NULL)
7206     return 1;
7207   else if (ada_is_constrained_packed_array_type (type0))
7208     return 1;
7209   else if (ada_is_array_descriptor_type (type0)
7210            && !ada_is_array_descriptor_type (type1))
7211     return 1;
7212   else
7213     {
7214       const char *type0_name = type0->name ();
7215       const char *type1_name = type1->name ();
7216
7217       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7218           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7219         return 1;
7220     }
7221   return 0;
7222 }
7223
7224 /* The name of TYPE, which is its TYPE_NAME.  Null if TYPE is
7225    null.  */
7226
7227 const char *
7228 ada_type_name (struct type *type)
7229 {
7230   if (type == NULL)
7231     return NULL;
7232   return type->name ();
7233 }
7234
7235 /* Search the list of "descriptive" types associated to TYPE for a type
7236    whose name is NAME.  */
7237
7238 static struct type *
7239 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7240 {
7241   struct type *result, *tmp;
7242
7243   if (ada_ignore_descriptive_types_p)
7244     return NULL;
7245
7246   /* If there no descriptive-type info, then there is no parallel type
7247      to be found.  */
7248   if (!HAVE_GNAT_AUX_INFO (type))
7249     return NULL;
7250
7251   result = TYPE_DESCRIPTIVE_TYPE (type);
7252   while (result != NULL)
7253     {
7254       const char *result_name = ada_type_name (result);
7255
7256       if (result_name == NULL)
7257         {
7258           warning (_("unexpected null name on descriptive type"));
7259           return NULL;
7260         }
7261
7262       /* If the names match, stop.  */
7263       if (strcmp (result_name, name) == 0)
7264         break;
7265
7266       /* Otherwise, look at the next item on the list, if any.  */
7267       if (HAVE_GNAT_AUX_INFO (result))
7268         tmp = TYPE_DESCRIPTIVE_TYPE (result);
7269       else
7270         tmp = NULL;
7271
7272       /* If not found either, try after having resolved the typedef.  */
7273       if (tmp != NULL)
7274         result = tmp;
7275       else
7276         {
7277           result = check_typedef (result);
7278           if (HAVE_GNAT_AUX_INFO (result))
7279             result = TYPE_DESCRIPTIVE_TYPE (result);
7280           else
7281             result = NULL;
7282         }
7283     }
7284
7285   /* If we didn't find a match, see whether this is a packed array.  With
7286      older compilers, the descriptive type information is either absent or
7287      irrelevant when it comes to packed arrays so the above lookup fails.
7288      Fall back to using a parallel lookup by name in this case.  */
7289   if (result == NULL && ada_is_constrained_packed_array_type (type))
7290     return ada_find_any_type (name);
7291
7292   return result;
7293 }
7294
7295 /* Find a parallel type to TYPE with the specified NAME, using the
7296    descriptive type taken from the debugging information, if available,
7297    and otherwise using the (slower) name-based method.  */
7298
7299 static struct type *
7300 ada_find_parallel_type_with_name (struct type *type, const char *name)
7301 {
7302   struct type *result = NULL;
7303
7304   if (HAVE_GNAT_AUX_INFO (type))
7305     result = find_parallel_type_by_descriptive_type (type, name);
7306   else
7307     result = ada_find_any_type (name);
7308
7309   return result;
7310 }
7311
7312 /* Same as above, but specify the name of the parallel type by appending
7313    SUFFIX to the name of TYPE.  */
7314
7315 struct type *
7316 ada_find_parallel_type (struct type *type, const char *suffix)
7317 {
7318   char *name;
7319   const char *type_name = ada_type_name (type);
7320   int len;
7321
7322   if (type_name == NULL)
7323     return NULL;
7324
7325   len = strlen (type_name);
7326
7327   name = (char *) alloca (len + strlen (suffix) + 1);
7328
7329   strcpy (name, type_name);
7330   strcpy (name + len, suffix);
7331
7332   return ada_find_parallel_type_with_name (type, name);
7333 }
7334
7335 /* If TYPE is a variable-size record type, return the corresponding template
7336    type describing its fields.  Otherwise, return NULL.  */
7337
7338 static struct type *
7339 dynamic_template_type (struct type *type)
7340 {
7341   type = ada_check_typedef (type);
7342
7343   if (type == NULL || type->code () != TYPE_CODE_STRUCT
7344       || ada_type_name (type) == NULL)
7345     return NULL;
7346   else
7347     {
7348       int len = strlen (ada_type_name (type));
7349
7350       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7351         return type;
7352       else
7353         return ada_find_parallel_type (type, "___XVE");
7354     }
7355 }
7356
7357 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7358    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
7359
7360 static int
7361 is_dynamic_field (struct type *templ_type, int field_num)
7362 {
7363   const char *name = TYPE_FIELD_NAME (templ_type, field_num);
7364
7365   return name != NULL
7366     && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7367     && strstr (name, "___XVL") != NULL;
7368 }
7369
7370 /* The index of the variant field of TYPE, or -1 if TYPE does not
7371    represent a variant record type.  */
7372
7373 static int
7374 variant_field_index (struct type *type)
7375 {
7376   int f;
7377
7378   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7379     return -1;
7380
7381   for (f = 0; f < type->num_fields (); f += 1)
7382     {
7383       if (ada_is_variant_part (type, f))
7384         return f;
7385     }
7386   return -1;
7387 }
7388
7389 /* A record type with no fields.  */
7390
7391 static struct type *
7392 empty_record (struct type *templ)
7393 {
7394   struct type *type = alloc_type_copy (templ);
7395
7396   type->set_code (TYPE_CODE_STRUCT);
7397   INIT_NONE_SPECIFIC (type);
7398   type->set_name ("<empty>");
7399   TYPE_LENGTH (type) = 0;
7400   return type;
7401 }
7402
7403 /* An ordinary record type (with fixed-length fields) that describes
7404    the value of type TYPE at VALADDR or ADDRESS (see comments at
7405    the beginning of this section) VAL according to GNAT conventions.
7406    DVAL0 should describe the (portion of a) record that contains any
7407    necessary discriminants.  It should be NULL if value_type (VAL) is
7408    an outer-level type (i.e., as opposed to a branch of a variant.)  A
7409    variant field (unless unchecked) is replaced by a particular branch
7410    of the variant.
7411
7412    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7413    length are not statically known are discarded.  As a consequence,
7414    VALADDR, ADDRESS and DVAL0 are ignored.
7415
7416    NOTE: Limitations: For now, we assume that dynamic fields and
7417    variants occupy whole numbers of bytes.  However, they need not be
7418    byte-aligned.  */
7419
7420 struct type *
7421 ada_template_to_fixed_record_type_1 (struct type *type,
7422                                      const gdb_byte *valaddr,
7423                                      CORE_ADDR address, struct value *dval0,
7424                                      int keep_dynamic_fields)
7425 {
7426   struct value *mark = value_mark ();
7427   struct value *dval;
7428   struct type *rtype;
7429   int nfields, bit_len;
7430   int variant_field;
7431   long off;
7432   int fld_bit_len;
7433   int f;
7434
7435   /* Compute the number of fields in this record type that are going
7436      to be processed: unless keep_dynamic_fields, this includes only
7437      fields whose position and length are static will be processed.  */
7438   if (keep_dynamic_fields)
7439     nfields = type->num_fields ();
7440   else
7441     {
7442       nfields = 0;
7443       while (nfields < type->num_fields ()
7444              && !ada_is_variant_part (type, nfields)
7445              && !is_dynamic_field (type, nfields))
7446         nfields++;
7447     }
7448
7449   rtype = alloc_type_copy (type);
7450   rtype->set_code (TYPE_CODE_STRUCT);
7451   INIT_NONE_SPECIFIC (rtype);
7452   rtype->set_num_fields (nfields);
7453   rtype->set_fields
7454    ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7455   rtype->set_name (ada_type_name (type));
7456   rtype->set_is_fixed_instance (true);
7457
7458   off = 0;
7459   bit_len = 0;
7460   variant_field = -1;
7461
7462   for (f = 0; f < nfields; f += 1)
7463     {
7464       off = align_up (off, field_alignment (type, f))
7465         + TYPE_FIELD_BITPOS (type, f);
7466       SET_FIELD_BITPOS (rtype->field (f), off);
7467       TYPE_FIELD_BITSIZE (rtype, f) = 0;
7468
7469       if (ada_is_variant_part (type, f))
7470         {
7471           variant_field = f;
7472           fld_bit_len = 0;
7473         }
7474       else if (is_dynamic_field (type, f))
7475         {
7476           const gdb_byte *field_valaddr = valaddr;
7477           CORE_ADDR field_address = address;
7478           struct type *field_type =
7479             TYPE_TARGET_TYPE (type->field (f).type ());
7480
7481           if (dval0 == NULL)
7482             {
7483               /* rtype's length is computed based on the run-time
7484                  value of discriminants.  If the discriminants are not
7485                  initialized, the type size may be completely bogus and
7486                  GDB may fail to allocate a value for it.  So check the
7487                  size first before creating the value.  */
7488               ada_ensure_varsize_limit (rtype);
7489               /* Using plain value_from_contents_and_address here
7490                  causes problems because we will end up trying to
7491                  resolve a type that is currently being
7492                  constructed.  */
7493               dval = value_from_contents_and_address_unresolved (rtype,
7494                                                                  valaddr,
7495                                                                  address);
7496               rtype = value_type (dval);
7497             }
7498           else
7499             dval = dval0;
7500
7501           /* If the type referenced by this field is an aligner type, we need
7502              to unwrap that aligner type, because its size might not be set.
7503              Keeping the aligner type would cause us to compute the wrong
7504              size for this field, impacting the offset of the all the fields
7505              that follow this one.  */
7506           if (ada_is_aligner_type (field_type))
7507             {
7508               long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7509
7510               field_valaddr = cond_offset_host (field_valaddr, field_offset);
7511               field_address = cond_offset_target (field_address, field_offset);
7512               field_type = ada_aligned_type (field_type);
7513             }
7514
7515           field_valaddr = cond_offset_host (field_valaddr,
7516                                             off / TARGET_CHAR_BIT);
7517           field_address = cond_offset_target (field_address,
7518                                               off / TARGET_CHAR_BIT);
7519
7520           /* Get the fixed type of the field.  Note that, in this case,
7521              we do not want to get the real type out of the tag: if
7522              the current field is the parent part of a tagged record,
7523              we will get the tag of the object.  Clearly wrong: the real
7524              type of the parent is not the real type of the child.  We
7525              would end up in an infinite loop.  */
7526           field_type = ada_get_base_type (field_type);
7527           field_type = ada_to_fixed_type (field_type, field_valaddr,
7528                                           field_address, dval, 0);
7529           /* If the field size is already larger than the maximum
7530              object size, then the record itself will necessarily
7531              be larger than the maximum object size.  We need to make
7532              this check now, because the size might be so ridiculously
7533              large (due to an uninitialized variable in the inferior)
7534              that it would cause an overflow when adding it to the
7535              record size.  */
7536           ada_ensure_varsize_limit (field_type);
7537
7538           rtype->field (f).set_type (field_type);
7539           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7540           /* The multiplication can potentially overflow.  But because
7541              the field length has been size-checked just above, and
7542              assuming that the maximum size is a reasonable value,
7543              an overflow should not happen in practice.  So rather than
7544              adding overflow recovery code to this already complex code,
7545              we just assume that it's not going to happen.  */
7546           fld_bit_len =
7547             TYPE_LENGTH (rtype->field (f).type ()) * TARGET_CHAR_BIT;
7548         }
7549       else
7550         {
7551           /* Note: If this field's type is a typedef, it is important
7552              to preserve the typedef layer.
7553
7554              Otherwise, we might be transforming a typedef to a fat
7555              pointer (encoding a pointer to an unconstrained array),
7556              into a basic fat pointer (encoding an unconstrained
7557              array).  As both types are implemented using the same
7558              structure, the typedef is the only clue which allows us
7559              to distinguish between the two options.  Stripping it
7560              would prevent us from printing this field appropriately.  */
7561           rtype->field (f).set_type (type->field (f).type ());
7562           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7563           if (TYPE_FIELD_BITSIZE (type, f) > 0)
7564             fld_bit_len =
7565               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7566           else
7567             {
7568               struct type *field_type = type->field (f).type ();
7569
7570               /* We need to be careful of typedefs when computing
7571                  the length of our field.  If this is a typedef,
7572                  get the length of the target type, not the length
7573                  of the typedef.  */
7574               if (field_type->code () == TYPE_CODE_TYPEDEF)
7575                 field_type = ada_typedef_target_type (field_type);
7576
7577               fld_bit_len =
7578                 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7579             }
7580         }
7581       if (off + fld_bit_len > bit_len)
7582         bit_len = off + fld_bit_len;
7583       off += fld_bit_len;
7584       TYPE_LENGTH (rtype) =
7585         align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7586     }
7587
7588   /* We handle the variant part, if any, at the end because of certain
7589      odd cases in which it is re-ordered so as NOT to be the last field of
7590      the record.  This can happen in the presence of representation
7591      clauses.  */
7592   if (variant_field >= 0)
7593     {
7594       struct type *branch_type;
7595
7596       off = TYPE_FIELD_BITPOS (rtype, variant_field);
7597
7598       if (dval0 == NULL)
7599         {
7600           /* Using plain value_from_contents_and_address here causes
7601              problems because we will end up trying to resolve a type
7602              that is currently being constructed.  */
7603           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
7604                                                              address);
7605           rtype = value_type (dval);
7606         }
7607       else
7608         dval = dval0;
7609
7610       branch_type =
7611         to_fixed_variant_branch_type
7612         (type->field (variant_field).type (),
7613          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7614          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7615       if (branch_type == NULL)
7616         {
7617           for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
7618             rtype->field (f - 1) = rtype->field (f);
7619           rtype->set_num_fields (rtype->num_fields () - 1);
7620         }
7621       else
7622         {
7623           rtype->field (variant_field).set_type (branch_type);
7624           TYPE_FIELD_NAME (rtype, variant_field) = "S";
7625           fld_bit_len =
7626             TYPE_LENGTH (rtype->field (variant_field).type ()) *
7627             TARGET_CHAR_BIT;
7628           if (off + fld_bit_len > bit_len)
7629             bit_len = off + fld_bit_len;
7630           TYPE_LENGTH (rtype) =
7631             align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7632         }
7633     }
7634
7635   /* According to exp_dbug.ads, the size of TYPE for variable-size records
7636      should contain the alignment of that record, which should be a strictly
7637      positive value.  If null or negative, then something is wrong, most
7638      probably in the debug info.  In that case, we don't round up the size
7639      of the resulting type.  If this record is not part of another structure,
7640      the current RTYPE length might be good enough for our purposes.  */
7641   if (TYPE_LENGTH (type) <= 0)
7642     {
7643       if (rtype->name ())
7644         warning (_("Invalid type size for `%s' detected: %s."),
7645                  rtype->name (), pulongest (TYPE_LENGTH (type)));
7646       else
7647         warning (_("Invalid type size for <unnamed> detected: %s."),
7648                  pulongest (TYPE_LENGTH (type)));
7649     }
7650   else
7651     {
7652       TYPE_LENGTH (rtype) = align_up (TYPE_LENGTH (rtype),
7653                                       TYPE_LENGTH (type));
7654     }
7655
7656   value_free_to_mark (mark);
7657   if (TYPE_LENGTH (rtype) > varsize_limit)
7658     error (_("record type with dynamic size is larger than varsize-limit"));
7659   return rtype;
7660 }
7661
7662 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7663    of 1.  */
7664
7665 static struct type *
7666 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
7667                                CORE_ADDR address, struct value *dval0)
7668 {
7669   return ada_template_to_fixed_record_type_1 (type, valaddr,
7670                                               address, dval0, 1);
7671 }
7672
7673 /* An ordinary record type in which ___XVL-convention fields and
7674    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7675    static approximations, containing all possible fields.  Uses
7676    no runtime values.  Useless for use in values, but that's OK,
7677    since the results are used only for type determinations.   Works on both
7678    structs and unions.  Representation note: to save space, we memorize
7679    the result of this function in the TYPE_TARGET_TYPE of the
7680    template type.  */
7681
7682 static struct type *
7683 template_to_static_fixed_type (struct type *type0)
7684 {
7685   struct type *type;
7686   int nfields;
7687   int f;
7688
7689   /* No need no do anything if the input type is already fixed.  */
7690   if (type0->is_fixed_instance ())
7691     return type0;
7692
7693   /* Likewise if we already have computed the static approximation.  */
7694   if (TYPE_TARGET_TYPE (type0) != NULL)
7695     return TYPE_TARGET_TYPE (type0);
7696
7697   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
7698   type = type0;
7699   nfields = type0->num_fields ();
7700
7701   /* Whether or not we cloned TYPE0, cache the result so that we don't do
7702      recompute all over next time.  */
7703   TYPE_TARGET_TYPE (type0) = type;
7704
7705   for (f = 0; f < nfields; f += 1)
7706     {
7707       struct type *field_type = type0->field (f).type ();
7708       struct type *new_type;
7709
7710       if (is_dynamic_field (type0, f))
7711         {
7712           field_type = ada_check_typedef (field_type);
7713           new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
7714         }
7715       else
7716         new_type = static_unwrap_type (field_type);
7717
7718       if (new_type != field_type)
7719         {
7720           /* Clone TYPE0 only the first time we get a new field type.  */
7721           if (type == type0)
7722             {
7723               TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
7724               type->set_code (type0->code ());
7725               INIT_NONE_SPECIFIC (type);
7726               type->set_num_fields (nfields);
7727
7728               field *fields =
7729                 ((struct field *)
7730                  TYPE_ALLOC (type, nfields * sizeof (struct field)));
7731               memcpy (fields, type0->fields (),
7732                       sizeof (struct field) * nfields);
7733               type->set_fields (fields);
7734
7735               type->set_name (ada_type_name (type0));
7736               type->set_is_fixed_instance (true);
7737               TYPE_LENGTH (type) = 0;
7738             }
7739           type->field (f).set_type (new_type);
7740           TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
7741         }
7742     }
7743
7744   return type;
7745 }
7746
7747 /* Given an object of type TYPE whose contents are at VALADDR and
7748    whose address in memory is ADDRESS, returns a revision of TYPE,
7749    which should be a non-dynamic-sized record, in which the variant
7750    part, if any, is replaced with the appropriate branch.  Looks
7751    for discriminant values in DVAL0, which can be NULL if the record
7752    contains the necessary discriminant values.  */
7753
7754 static struct type *
7755 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
7756                                    CORE_ADDR address, struct value *dval0)
7757 {
7758   struct value *mark = value_mark ();
7759   struct value *dval;
7760   struct type *rtype;
7761   struct type *branch_type;
7762   int nfields = type->num_fields ();
7763   int variant_field = variant_field_index (type);
7764
7765   if (variant_field == -1)
7766     return type;
7767
7768   if (dval0 == NULL)
7769     {
7770       dval = value_from_contents_and_address (type, valaddr, address);
7771       type = value_type (dval);
7772     }
7773   else
7774     dval = dval0;
7775
7776   rtype = alloc_type_copy (type);
7777   rtype->set_code (TYPE_CODE_STRUCT);
7778   INIT_NONE_SPECIFIC (rtype);
7779   rtype->set_num_fields (nfields);
7780
7781   field *fields =
7782     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7783   memcpy (fields, type->fields (), sizeof (struct field) * nfields);
7784   rtype->set_fields (fields);
7785
7786   rtype->set_name (ada_type_name (type));
7787   rtype->set_is_fixed_instance (true);
7788   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7789
7790   branch_type = to_fixed_variant_branch_type
7791     (type->field (variant_field).type (),
7792      cond_offset_host (valaddr,
7793                        TYPE_FIELD_BITPOS (type, variant_field)
7794                        / TARGET_CHAR_BIT),
7795      cond_offset_target (address,
7796                          TYPE_FIELD_BITPOS (type, variant_field)
7797                          / TARGET_CHAR_BIT), dval);
7798   if (branch_type == NULL)
7799     {
7800       int f;
7801
7802       for (f = variant_field + 1; f < nfields; f += 1)
7803         rtype->field (f - 1) = rtype->field (f);
7804       rtype->set_num_fields (rtype->num_fields () - 1);
7805     }
7806   else
7807     {
7808       rtype->field (variant_field).set_type (branch_type);
7809       TYPE_FIELD_NAME (rtype, variant_field) = "S";
7810       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
7811       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
7812     }
7813   TYPE_LENGTH (rtype) -= TYPE_LENGTH (type->field (variant_field).type ());
7814
7815   value_free_to_mark (mark);
7816   return rtype;
7817 }
7818
7819 /* An ordinary record type (with fixed-length fields) that describes
7820    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7821    beginning of this section].   Any necessary discriminants' values
7822    should be in DVAL, a record value; it may be NULL if the object
7823    at ADDR itself contains any necessary discriminant values.
7824    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7825    values from the record are needed.  Except in the case that DVAL,
7826    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7827    unchecked) is replaced by a particular branch of the variant.
7828
7829    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7830    is questionable and may be removed.  It can arise during the
7831    processing of an unconstrained-array-of-record type where all the
7832    variant branches have exactly the same size.  This is because in
7833    such cases, the compiler does not bother to use the XVS convention
7834    when encoding the record.  I am currently dubious of this
7835    shortcut and suspect the compiler should be altered.  FIXME.  */
7836
7837 static struct type *
7838 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
7839                       CORE_ADDR address, struct value *dval)
7840 {
7841   struct type *templ_type;
7842
7843   if (type0->is_fixed_instance ())
7844     return type0;
7845
7846   templ_type = dynamic_template_type (type0);
7847
7848   if (templ_type != NULL)
7849     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
7850   else if (variant_field_index (type0) >= 0)
7851     {
7852       if (dval == NULL && valaddr == NULL && address == 0)
7853         return type0;
7854       return to_record_with_fixed_variant_part (type0, valaddr, address,
7855                                                 dval);
7856     }
7857   else
7858     {
7859       type0->set_is_fixed_instance (true);
7860       return type0;
7861     }
7862
7863 }
7864
7865 /* An ordinary record type (with fixed-length fields) that describes
7866    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7867    union type.  Any necessary discriminants' values should be in DVAL,
7868    a record value.  That is, this routine selects the appropriate
7869    branch of the union at ADDR according to the discriminant value
7870    indicated in the union's type name.  Returns VAR_TYPE0 itself if
7871    it represents a variant subject to a pragma Unchecked_Union.  */
7872
7873 static struct type *
7874 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
7875                               CORE_ADDR address, struct value *dval)
7876 {
7877   int which;
7878   struct type *templ_type;
7879   struct type *var_type;
7880
7881   if (var_type0->code () == TYPE_CODE_PTR)
7882     var_type = TYPE_TARGET_TYPE (var_type0);
7883   else
7884     var_type = var_type0;
7885
7886   templ_type = ada_find_parallel_type (var_type, "___XVU");
7887
7888   if (templ_type != NULL)
7889     var_type = templ_type;
7890
7891   if (is_unchecked_variant (var_type, value_type (dval)))
7892       return var_type0;
7893   which = ada_which_variant_applies (var_type, dval);
7894
7895   if (which < 0)
7896     return empty_record (var_type);
7897   else if (is_dynamic_field (var_type, which))
7898     return to_fixed_record_type
7899       (TYPE_TARGET_TYPE (var_type->field (which).type ()),
7900        valaddr, address, dval);
7901   else if (variant_field_index (var_type->field (which).type ()) >= 0)
7902     return
7903       to_fixed_record_type
7904       (var_type->field (which).type (), valaddr, address, dval);
7905   else
7906     return var_type->field (which).type ();
7907 }
7908
7909 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
7910    ENCODING_TYPE, a type following the GNAT conventions for discrete
7911    type encodings, only carries redundant information.  */
7912
7913 static int
7914 ada_is_redundant_range_encoding (struct type *range_type,
7915                                  struct type *encoding_type)
7916 {
7917   const char *bounds_str;
7918   int n;
7919   LONGEST lo, hi;
7920
7921   gdb_assert (range_type->code () == TYPE_CODE_RANGE);
7922
7923   if (get_base_type (range_type)->code ()
7924       != get_base_type (encoding_type)->code ())
7925     {
7926       /* The compiler probably used a simple base type to describe
7927          the range type instead of the range's actual base type,
7928          expecting us to get the real base type from the encoding
7929          anyway.  In this situation, the encoding cannot be ignored
7930          as redundant.  */
7931       return 0;
7932     }
7933
7934   if (is_dynamic_type (range_type))
7935     return 0;
7936
7937   if (encoding_type->name () == NULL)
7938     return 0;
7939
7940   bounds_str = strstr (encoding_type->name (), "___XDLU_");
7941   if (bounds_str == NULL)
7942     return 0;
7943
7944   n = 8; /* Skip "___XDLU_".  */
7945   if (!ada_scan_number (bounds_str, n, &lo, &n))
7946     return 0;
7947   if (range_type->bounds ()->low.const_val () != lo)
7948     return 0;
7949
7950   n += 2; /* Skip the "__" separator between the two bounds.  */
7951   if (!ada_scan_number (bounds_str, n, &hi, &n))
7952     return 0;
7953   if (range_type->bounds ()->high.const_val () != hi)
7954     return 0;
7955
7956   return 1;
7957 }
7958
7959 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
7960    a type following the GNAT encoding for describing array type
7961    indices, only carries redundant information.  */
7962
7963 static int
7964 ada_is_redundant_index_type_desc (struct type *array_type,
7965                                   struct type *desc_type)
7966 {
7967   struct type *this_layer = check_typedef (array_type);
7968   int i;
7969
7970   for (i = 0; i < desc_type->num_fields (); i++)
7971     {
7972       if (!ada_is_redundant_range_encoding (this_layer->index_type (),
7973                                             desc_type->field (i).type ()))
7974         return 0;
7975       this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
7976     }
7977
7978   return 1;
7979 }
7980
7981 /* Assuming that TYPE0 is an array type describing the type of a value
7982    at ADDR, and that DVAL describes a record containing any
7983    discriminants used in TYPE0, returns a type for the value that
7984    contains no dynamic components (that is, no components whose sizes
7985    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
7986    true, gives an error message if the resulting type's size is over
7987    varsize_limit.  */
7988
7989 static struct type *
7990 to_fixed_array_type (struct type *type0, struct value *dval,
7991                      int ignore_too_big)
7992 {
7993   struct type *index_type_desc;
7994   struct type *result;
7995   int constrained_packed_array_p;
7996   static const char *xa_suffix = "___XA";
7997
7998   type0 = ada_check_typedef (type0);
7999   if (type0->is_fixed_instance ())
8000     return type0;
8001
8002   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8003   if (constrained_packed_array_p)
8004     {
8005       type0 = decode_constrained_packed_array_type (type0);
8006       if (type0 == nullptr)
8007         error (_("could not decode constrained packed array type"));
8008     }
8009
8010   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8011
8012   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8013      encoding suffixed with 'P' may still be generated.  If so,
8014      it should be used to find the XA type.  */
8015
8016   if (index_type_desc == NULL)
8017     {
8018       const char *type_name = ada_type_name (type0);
8019
8020       if (type_name != NULL)
8021         {
8022           const int len = strlen (type_name);
8023           char *name = (char *) alloca (len + strlen (xa_suffix));
8024
8025           if (type_name[len - 1] == 'P')
8026             {
8027               strcpy (name, type_name);
8028               strcpy (name + len - 1, xa_suffix);
8029               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8030             }
8031         }
8032     }
8033
8034   ada_fixup_array_indexes_type (index_type_desc);
8035   if (index_type_desc != NULL
8036       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8037     {
8038       /* Ignore this ___XA parallel type, as it does not bring any
8039          useful information.  This allows us to avoid creating fixed
8040          versions of the array's index types, which would be identical
8041          to the original ones.  This, in turn, can also help avoid
8042          the creation of fixed versions of the array itself.  */
8043       index_type_desc = NULL;
8044     }
8045
8046   if (index_type_desc == NULL)
8047     {
8048       struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8049
8050       /* NOTE: elt_type---the fixed version of elt_type0---should never
8051          depend on the contents of the array in properly constructed
8052          debugging data.  */
8053       /* Create a fixed version of the array element type.
8054          We're not providing the address of an element here,
8055          and thus the actual object value cannot be inspected to do
8056          the conversion.  This should not be a problem, since arrays of
8057          unconstrained objects are not allowed.  In particular, all
8058          the elements of an array of a tagged type should all be of
8059          the same type specified in the debugging info.  No need to
8060          consult the object tag.  */
8061       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8062
8063       /* Make sure we always create a new array type when dealing with
8064          packed array types, since we're going to fix-up the array
8065          type length and element bitsize a little further down.  */
8066       if (elt_type0 == elt_type && !constrained_packed_array_p)
8067         result = type0;
8068       else
8069         result = create_array_type (alloc_type_copy (type0),
8070                                     elt_type, type0->index_type ());
8071     }
8072   else
8073     {
8074       int i;
8075       struct type *elt_type0;
8076
8077       elt_type0 = type0;
8078       for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8079         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8080
8081       /* NOTE: result---the fixed version of elt_type0---should never
8082          depend on the contents of the array in properly constructed
8083          debugging data.  */
8084       /* Create a fixed version of the array element type.
8085          We're not providing the address of an element here,
8086          and thus the actual object value cannot be inspected to do
8087          the conversion.  This should not be a problem, since arrays of
8088          unconstrained objects are not allowed.  In particular, all
8089          the elements of an array of a tagged type should all be of
8090          the same type specified in the debugging info.  No need to
8091          consult the object tag.  */
8092       result =
8093         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8094
8095       elt_type0 = type0;
8096       for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8097         {
8098           struct type *range_type =
8099             to_fixed_range_type (index_type_desc->field (i).type (), dval);
8100
8101           result = create_array_type (alloc_type_copy (elt_type0),
8102                                       result, range_type);
8103           elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8104         }
8105       if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
8106         error (_("array type with dynamic size is larger than varsize-limit"));
8107     }
8108
8109   /* We want to preserve the type name.  This can be useful when
8110      trying to get the type name of a value that has already been
8111      printed (for instance, if the user did "print VAR; whatis $".  */
8112   result->set_name (type0->name ());
8113
8114   if (constrained_packed_array_p)
8115     {
8116       /* So far, the resulting type has been created as if the original
8117          type was a regular (non-packed) array type.  As a result, the
8118          bitsize of the array elements needs to be set again, and the array
8119          length needs to be recomputed based on that bitsize.  */
8120       int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8121       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8122
8123       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8124       TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8125       if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8126         TYPE_LENGTH (result)++;
8127     }
8128
8129   result->set_is_fixed_instance (true);
8130   return result;
8131 }
8132
8133
8134 /* A standard type (containing no dynamically sized components)
8135    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8136    DVAL describes a record containing any discriminants used in TYPE0,
8137    and may be NULL if there are none, or if the object of type TYPE at
8138    ADDRESS or in VALADDR contains these discriminants.
8139    
8140    If CHECK_TAG is not null, in the case of tagged types, this function
8141    attempts to locate the object's tag and use it to compute the actual
8142    type.  However, when ADDRESS is null, we cannot use it to determine the
8143    location of the tag, and therefore compute the tagged type's actual type.
8144    So we return the tagged type without consulting the tag.  */
8145    
8146 static struct type *
8147 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8148                    CORE_ADDR address, struct value *dval, int check_tag)
8149 {
8150   type = ada_check_typedef (type);
8151
8152   /* Only un-fixed types need to be handled here.  */
8153   if (!HAVE_GNAT_AUX_INFO (type))
8154     return type;
8155
8156   switch (type->code ())
8157     {
8158     default:
8159       return type;
8160     case TYPE_CODE_STRUCT:
8161       {
8162         struct type *static_type = to_static_fixed_type (type);
8163         struct type *fixed_record_type =
8164           to_fixed_record_type (type, valaddr, address, NULL);
8165
8166         /* If STATIC_TYPE is a tagged type and we know the object's address,
8167            then we can determine its tag, and compute the object's actual
8168            type from there.  Note that we have to use the fixed record
8169            type (the parent part of the record may have dynamic fields
8170            and the way the location of _tag is expressed may depend on
8171            them).  */
8172
8173         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8174           {
8175             struct value *tag =
8176               value_tag_from_contents_and_address
8177               (fixed_record_type,
8178                valaddr,
8179                address);
8180             struct type *real_type = type_from_tag (tag);
8181             struct value *obj =
8182               value_from_contents_and_address (fixed_record_type,
8183                                                valaddr,
8184                                                address);
8185             fixed_record_type = value_type (obj);
8186             if (real_type != NULL)
8187               return to_fixed_record_type
8188                 (real_type, NULL,
8189                  value_address (ada_tag_value_at_base_address (obj)), NULL);
8190           }
8191
8192         /* Check to see if there is a parallel ___XVZ variable.
8193            If there is, then it provides the actual size of our type.  */
8194         else if (ada_type_name (fixed_record_type) != NULL)
8195           {
8196             const char *name = ada_type_name (fixed_record_type);
8197             char *xvz_name
8198               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8199             bool xvz_found = false;
8200             LONGEST size;
8201
8202             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8203             try
8204               {
8205                 xvz_found = get_int_var_value (xvz_name, size);
8206               }
8207             catch (const gdb_exception_error &except)
8208               {
8209                 /* We found the variable, but somehow failed to read
8210                    its value.  Rethrow the same error, but with a little
8211                    bit more information, to help the user understand
8212                    what went wrong (Eg: the variable might have been
8213                    optimized out).  */
8214                 throw_error (except.error,
8215                              _("unable to read value of %s (%s)"),
8216                              xvz_name, except.what ());
8217               }
8218
8219             if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8220               {
8221                 fixed_record_type = copy_type (fixed_record_type);
8222                 TYPE_LENGTH (fixed_record_type) = size;
8223
8224                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
8225                    observed this when the debugging info is STABS, and
8226                    apparently it is something that is hard to fix.
8227
8228                    In practice, we don't need the actual type definition
8229                    at all, because the presence of the XVZ variable allows us
8230                    to assume that there must be a XVS type as well, which we
8231                    should be able to use later, when we need the actual type
8232                    definition.
8233
8234                    In the meantime, pretend that the "fixed" type we are
8235                    returning is NOT a stub, because this can cause trouble
8236                    when using this type to create new types targeting it.
8237                    Indeed, the associated creation routines often check
8238                    whether the target type is a stub and will try to replace
8239                    it, thus using a type with the wrong size.  This, in turn,
8240                    might cause the new type to have the wrong size too.
8241                    Consider the case of an array, for instance, where the size
8242                    of the array is computed from the number of elements in
8243                    our array multiplied by the size of its element.  */
8244                 fixed_record_type->set_is_stub (false);
8245               }
8246           }
8247         return fixed_record_type;
8248       }
8249     case TYPE_CODE_ARRAY:
8250       return to_fixed_array_type (type, dval, 1);
8251     case TYPE_CODE_UNION:
8252       if (dval == NULL)
8253         return type;
8254       else
8255         return to_fixed_variant_branch_type (type, valaddr, address, dval);
8256     }
8257 }
8258
8259 /* The same as ada_to_fixed_type_1, except that it preserves the type
8260    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8261
8262    The typedef layer needs be preserved in order to differentiate between
8263    arrays and array pointers when both types are implemented using the same
8264    fat pointer.  In the array pointer case, the pointer is encoded as
8265    a typedef of the pointer type.  For instance, considering:
8266
8267           type String_Access is access String;
8268           S1 : String_Access := null;
8269
8270    To the debugger, S1 is defined as a typedef of type String.  But
8271    to the user, it is a pointer.  So if the user tries to print S1,
8272    we should not dereference the array, but print the array address
8273    instead.
8274
8275    If we didn't preserve the typedef layer, we would lose the fact that
8276    the type is to be presented as a pointer (needs de-reference before
8277    being printed).  And we would also use the source-level type name.  */
8278
8279 struct type *
8280 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8281                    CORE_ADDR address, struct value *dval, int check_tag)
8282
8283 {
8284   struct type *fixed_type =
8285     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8286
8287   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8288       then preserve the typedef layer.
8289
8290       Implementation note: We can only check the main-type portion of
8291       the TYPE and FIXED_TYPE, because eliminating the typedef layer
8292       from TYPE now returns a type that has the same instance flags
8293       as TYPE.  For instance, if TYPE is a "typedef const", and its
8294       target type is a "struct", then the typedef elimination will return
8295       a "const" version of the target type.  See check_typedef for more
8296       details about how the typedef layer elimination is done.
8297
8298       brobecker/2010-11-19: It seems to me that the only case where it is
8299       useful to preserve the typedef layer is when dealing with fat pointers.
8300       Perhaps, we could add a check for that and preserve the typedef layer
8301       only in that situation.  But this seems unnecessary so far, probably
8302       because we call check_typedef/ada_check_typedef pretty much everywhere.
8303       */
8304   if (type->code () == TYPE_CODE_TYPEDEF
8305       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8306           == TYPE_MAIN_TYPE (fixed_type)))
8307     return type;
8308
8309   return fixed_type;
8310 }
8311
8312 /* A standard (static-sized) type corresponding as well as possible to
8313    TYPE0, but based on no runtime data.  */
8314
8315 static struct type *
8316 to_static_fixed_type (struct type *type0)
8317 {
8318   struct type *type;
8319
8320   if (type0 == NULL)
8321     return NULL;
8322
8323   if (type0->is_fixed_instance ())
8324     return type0;
8325
8326   type0 = ada_check_typedef (type0);
8327
8328   switch (type0->code ())
8329     {
8330     default:
8331       return type0;
8332     case TYPE_CODE_STRUCT:
8333       type = dynamic_template_type (type0);
8334       if (type != NULL)
8335         return template_to_static_fixed_type (type);
8336       else
8337         return template_to_static_fixed_type (type0);
8338     case TYPE_CODE_UNION:
8339       type = ada_find_parallel_type (type0, "___XVU");
8340       if (type != NULL)
8341         return template_to_static_fixed_type (type);
8342       else
8343         return template_to_static_fixed_type (type0);
8344     }
8345 }
8346
8347 /* A static approximation of TYPE with all type wrappers removed.  */
8348
8349 static struct type *
8350 static_unwrap_type (struct type *type)
8351 {
8352   if (ada_is_aligner_type (type))
8353     {
8354       struct type *type1 = ada_check_typedef (type)->field (0).type ();
8355       if (ada_type_name (type1) == NULL)
8356         type1->set_name (ada_type_name (type));
8357
8358       return static_unwrap_type (type1);
8359     }
8360   else
8361     {
8362       struct type *raw_real_type = ada_get_base_type (type);
8363
8364       if (raw_real_type == type)
8365         return type;
8366       else
8367         return to_static_fixed_type (raw_real_type);
8368     }
8369 }
8370
8371 /* In some cases, incomplete and private types require
8372    cross-references that are not resolved as records (for example,
8373       type Foo;
8374       type FooP is access Foo;
8375       V: FooP;
8376       type Foo is array ...;
8377    ).  In these cases, since there is no mechanism for producing
8378    cross-references to such types, we instead substitute for FooP a
8379    stub enumeration type that is nowhere resolved, and whose tag is
8380    the name of the actual type.  Call these types "non-record stubs".  */
8381
8382 /* A type equivalent to TYPE that is not a non-record stub, if one
8383    exists, otherwise TYPE.  */
8384
8385 struct type *
8386 ada_check_typedef (struct type *type)
8387 {
8388   if (type == NULL)
8389     return NULL;
8390
8391   /* If our type is an access to an unconstrained array, which is encoded
8392      as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8393      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8394      what allows us to distinguish between fat pointers that represent
8395      array types, and fat pointers that represent array access types
8396      (in both cases, the compiler implements them as fat pointers).  */
8397   if (ada_is_access_to_unconstrained_array (type))
8398     return type;
8399
8400   type = check_typedef (type);
8401   if (type == NULL || type->code () != TYPE_CODE_ENUM
8402       || !type->is_stub ()
8403       || type->name () == NULL)
8404     return type;
8405   else
8406     {
8407       const char *name = type->name ();
8408       struct type *type1 = ada_find_any_type (name);
8409
8410       if (type1 == NULL)
8411         return type;
8412
8413       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8414          stubs pointing to arrays, as we don't create symbols for array
8415          types, only for the typedef-to-array types).  If that's the case,
8416          strip the typedef layer.  */
8417       if (type1->code () == TYPE_CODE_TYPEDEF)
8418         type1 = ada_check_typedef (type1);
8419
8420       return type1;
8421     }
8422 }
8423
8424 /* A value representing the data at VALADDR/ADDRESS as described by
8425    type TYPE0, but with a standard (static-sized) type that correctly
8426    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
8427    type, then return VAL0 [this feature is simply to avoid redundant
8428    creation of struct values].  */
8429
8430 static struct value *
8431 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8432                            struct value *val0)
8433 {
8434   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8435
8436   if (type == type0 && val0 != NULL)
8437     return val0;
8438
8439   if (VALUE_LVAL (val0) != lval_memory)
8440     {
8441       /* Our value does not live in memory; it could be a convenience
8442          variable, for instance.  Create a not_lval value using val0's
8443          contents.  */
8444       return value_from_contents (type, value_contents (val0));
8445     }
8446
8447   return value_from_contents_and_address (type, 0, address);
8448 }
8449
8450 /* A value representing VAL, but with a standard (static-sized) type
8451    that correctly describes it.  Does not necessarily create a new
8452    value.  */
8453
8454 struct value *
8455 ada_to_fixed_value (struct value *val)
8456 {
8457   val = unwrap_value (val);
8458   val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8459   return val;
8460 }
8461 \f
8462
8463 /* Attributes */
8464
8465 /* Table mapping attribute numbers to names.
8466    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
8467
8468 static const char * const attribute_names[] = {
8469   "<?>",
8470
8471   "first",
8472   "last",
8473   "length",
8474   "image",
8475   "max",
8476   "min",
8477   "modulus",
8478   "pos",
8479   "size",
8480   "tag",
8481   "val",
8482   0
8483 };
8484
8485 static const char *
8486 ada_attribute_name (enum exp_opcode n)
8487 {
8488   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8489     return attribute_names[n - OP_ATR_FIRST + 1];
8490   else
8491     return attribute_names[0];
8492 }
8493
8494 /* Evaluate the 'POS attribute applied to ARG.  */
8495
8496 static LONGEST
8497 pos_atr (struct value *arg)
8498 {
8499   struct value *val = coerce_ref (arg);
8500   struct type *type = value_type (val);
8501
8502   if (!discrete_type_p (type))
8503     error (_("'POS only defined on discrete types"));
8504
8505   gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8506   if (!result.has_value ())
8507     error (_("enumeration value is invalid: can't find 'POS"));
8508
8509   return *result;
8510 }
8511
8512 struct value *
8513 ada_pos_atr (struct type *expect_type,
8514              struct expression *exp,
8515              enum noside noside, enum exp_opcode op,
8516              struct value *arg)
8517 {
8518   struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8519   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8520     return value_zero (type, not_lval);
8521   return value_from_longest (type, pos_atr (arg));
8522 }
8523
8524 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
8525
8526 static struct value *
8527 val_atr (struct type *type, LONGEST val)
8528 {
8529   gdb_assert (discrete_type_p (type));
8530   if (type->code () == TYPE_CODE_RANGE)
8531     type = TYPE_TARGET_TYPE (type);
8532   if (type->code () == TYPE_CODE_ENUM)
8533     {
8534       if (val < 0 || val >= type->num_fields ())
8535         error (_("argument to 'VAL out of range"));
8536       val = TYPE_FIELD_ENUMVAL (type, val);
8537     }
8538   return value_from_longest (type, val);
8539 }
8540
8541 struct value *
8542 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8543 {
8544   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8545     return value_zero (type, not_lval);
8546
8547   if (!discrete_type_p (type))
8548     error (_("'VAL only defined on discrete types"));
8549   if (!integer_type_p (value_type (arg)))
8550     error (_("'VAL requires integral argument"));
8551
8552   return val_atr (type, value_as_long (arg));
8553 }
8554 \f
8555
8556                                 /* Evaluation */
8557
8558 /* True if TYPE appears to be an Ada character type.
8559    [At the moment, this is true only for Character and Wide_Character;
8560    It is a heuristic test that could stand improvement].  */
8561
8562 bool
8563 ada_is_character_type (struct type *type)
8564 {
8565   const char *name;
8566
8567   /* If the type code says it's a character, then assume it really is,
8568      and don't check any further.  */
8569   if (type->code () == TYPE_CODE_CHAR)
8570     return true;
8571   
8572   /* Otherwise, assume it's a character type iff it is a discrete type
8573      with a known character type name.  */
8574   name = ada_type_name (type);
8575   return (name != NULL
8576           && (type->code () == TYPE_CODE_INT
8577               || type->code () == TYPE_CODE_RANGE)
8578           && (strcmp (name, "character") == 0
8579               || strcmp (name, "wide_character") == 0
8580               || strcmp (name, "wide_wide_character") == 0
8581               || strcmp (name, "unsigned char") == 0));
8582 }
8583
8584 /* True if TYPE appears to be an Ada string type.  */
8585
8586 bool
8587 ada_is_string_type (struct type *type)
8588 {
8589   type = ada_check_typedef (type);
8590   if (type != NULL
8591       && type->code () != TYPE_CODE_PTR
8592       && (ada_is_simple_array_type (type)
8593           || ada_is_array_descriptor_type (type))
8594       && ada_array_arity (type) == 1)
8595     {
8596       struct type *elttype = ada_array_element_type (type, 1);
8597
8598       return ada_is_character_type (elttype);
8599     }
8600   else
8601     return false;
8602 }
8603
8604 /* The compiler sometimes provides a parallel XVS type for a given
8605    PAD type.  Normally, it is safe to follow the PAD type directly,
8606    but older versions of the compiler have a bug that causes the offset
8607    of its "F" field to be wrong.  Following that field in that case
8608    would lead to incorrect results, but this can be worked around
8609    by ignoring the PAD type and using the associated XVS type instead.
8610
8611    Set to True if the debugger should trust the contents of PAD types.
8612    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
8613 static bool trust_pad_over_xvs = true;
8614
8615 /* True if TYPE is a struct type introduced by the compiler to force the
8616    alignment of a value.  Such types have a single field with a
8617    distinctive name.  */
8618
8619 int
8620 ada_is_aligner_type (struct type *type)
8621 {
8622   type = ada_check_typedef (type);
8623
8624   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
8625     return 0;
8626
8627   return (type->code () == TYPE_CODE_STRUCT
8628           && type->num_fields () == 1
8629           && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
8630 }
8631
8632 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8633    the parallel type.  */
8634
8635 struct type *
8636 ada_get_base_type (struct type *raw_type)
8637 {
8638   struct type *real_type_namer;
8639   struct type *raw_real_type;
8640
8641   if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
8642     return raw_type;
8643
8644   if (ada_is_aligner_type (raw_type))
8645     /* The encoding specifies that we should always use the aligner type.
8646        So, even if this aligner type has an associated XVS type, we should
8647        simply ignore it.
8648
8649        According to the compiler gurus, an XVS type parallel to an aligner
8650        type may exist because of a stabs limitation.  In stabs, aligner
8651        types are empty because the field has a variable-sized type, and
8652        thus cannot actually be used as an aligner type.  As a result,
8653        we need the associated parallel XVS type to decode the type.
8654        Since the policy in the compiler is to not change the internal
8655        representation based on the debugging info format, we sometimes
8656        end up having a redundant XVS type parallel to the aligner type.  */
8657     return raw_type;
8658
8659   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
8660   if (real_type_namer == NULL
8661       || real_type_namer->code () != TYPE_CODE_STRUCT
8662       || real_type_namer->num_fields () != 1)
8663     return raw_type;
8664
8665   if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
8666     {
8667       /* This is an older encoding form where the base type needs to be
8668          looked up by name.  We prefer the newer encoding because it is
8669          more efficient.  */
8670       raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
8671       if (raw_real_type == NULL)
8672         return raw_type;
8673       else
8674         return raw_real_type;
8675     }
8676
8677   /* The field in our XVS type is a reference to the base type.  */
8678   return TYPE_TARGET_TYPE (real_type_namer->field (0).type ());
8679 }
8680
8681 /* The type of value designated by TYPE, with all aligners removed.  */
8682
8683 struct type *
8684 ada_aligned_type (struct type *type)
8685 {
8686   if (ada_is_aligner_type (type))
8687     return ada_aligned_type (type->field (0).type ());
8688   else
8689     return ada_get_base_type (type);
8690 }
8691
8692
8693 /* The address of the aligned value in an object at address VALADDR
8694    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
8695
8696 const gdb_byte *
8697 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
8698 {
8699   if (ada_is_aligner_type (type))
8700     return ada_aligned_value_addr (type->field (0).type (),
8701                                    valaddr +
8702                                    TYPE_FIELD_BITPOS (type,
8703                                                       0) / TARGET_CHAR_BIT);
8704   else
8705     return valaddr;
8706 }
8707
8708
8709
8710 /* The printed representation of an enumeration literal with encoded
8711    name NAME.  The value is good to the next call of ada_enum_name.  */
8712 const char *
8713 ada_enum_name (const char *name)
8714 {
8715   static std::string storage;
8716   const char *tmp;
8717
8718   /* First, unqualify the enumeration name:
8719      1. Search for the last '.' character.  If we find one, then skip
8720      all the preceding characters, the unqualified name starts
8721      right after that dot.
8722      2. Otherwise, we may be debugging on a target where the compiler
8723      translates dots into "__".  Search forward for double underscores,
8724      but stop searching when we hit an overloading suffix, which is
8725      of the form "__" followed by digits.  */
8726
8727   tmp = strrchr (name, '.');
8728   if (tmp != NULL)
8729     name = tmp + 1;
8730   else
8731     {
8732       while ((tmp = strstr (name, "__")) != NULL)
8733         {
8734           if (isdigit (tmp[2]))
8735             break;
8736           else
8737             name = tmp + 2;
8738         }
8739     }
8740
8741   if (name[0] == 'Q')
8742     {
8743       int v;
8744
8745       if (name[1] == 'U' || name[1] == 'W')
8746         {
8747           if (sscanf (name + 2, "%x", &v) != 1)
8748             return name;
8749         }
8750       else if (((name[1] >= '0' && name[1] <= '9')
8751                 || (name[1] >= 'a' && name[1] <= 'z'))
8752                && name[2] == '\0')
8753         {
8754           storage = string_printf ("'%c'", name[1]);
8755           return storage.c_str ();
8756         }
8757       else
8758         return name;
8759
8760       if (isascii (v) && isprint (v))
8761         storage = string_printf ("'%c'", v);
8762       else if (name[1] == 'U')
8763         storage = string_printf ("[\"%02x\"]", v);
8764       else
8765         storage = string_printf ("[\"%04x\"]", v);
8766
8767       return storage.c_str ();
8768     }
8769   else
8770     {
8771       tmp = strstr (name, "__");
8772       if (tmp == NULL)
8773         tmp = strstr (name, "$");
8774       if (tmp != NULL)
8775         {
8776           storage = std::string (name, tmp - name);
8777           return storage.c_str ();
8778         }
8779
8780       return name;
8781     }
8782 }
8783
8784 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8785    value it wraps.  */
8786
8787 static struct value *
8788 unwrap_value (struct value *val)
8789 {
8790   struct type *type = ada_check_typedef (value_type (val));
8791
8792   if (ada_is_aligner_type (type))
8793     {
8794       struct value *v = ada_value_struct_elt (val, "F", 0);
8795       struct type *val_type = ada_check_typedef (value_type (v));
8796
8797       if (ada_type_name (val_type) == NULL)
8798         val_type->set_name (ada_type_name (type));
8799
8800       return unwrap_value (v);
8801     }
8802   else
8803     {
8804       struct type *raw_real_type =
8805         ada_check_typedef (ada_get_base_type (type));
8806
8807       /* If there is no parallel XVS or XVE type, then the value is
8808          already unwrapped.  Return it without further modification.  */
8809       if ((type == raw_real_type)
8810           && ada_find_parallel_type (type, "___XVE") == NULL)
8811         return val;
8812
8813       return
8814         coerce_unspec_val_to_type
8815         (val, ada_to_fixed_type (raw_real_type, 0,
8816                                  value_address (val),
8817                                  NULL, 1));
8818     }
8819 }
8820
8821 /* Given two array types T1 and T2, return nonzero iff both arrays
8822    contain the same number of elements.  */
8823
8824 static int
8825 ada_same_array_size_p (struct type *t1, struct type *t2)
8826 {
8827   LONGEST lo1, hi1, lo2, hi2;
8828
8829   /* Get the array bounds in order to verify that the size of
8830      the two arrays match.  */
8831   if (!get_array_bounds (t1, &lo1, &hi1)
8832       || !get_array_bounds (t2, &lo2, &hi2))
8833     error (_("unable to determine array bounds"));
8834
8835   /* To make things easier for size comparison, normalize a bit
8836      the case of empty arrays by making sure that the difference
8837      between upper bound and lower bound is always -1.  */
8838   if (lo1 > hi1)
8839     hi1 = lo1 - 1;
8840   if (lo2 > hi2)
8841     hi2 = lo2 - 1;
8842
8843   return (hi1 - lo1 == hi2 - lo2);
8844 }
8845
8846 /* Assuming that VAL is an array of integrals, and TYPE represents
8847    an array with the same number of elements, but with wider integral
8848    elements, return an array "casted" to TYPE.  In practice, this
8849    means that the returned array is built by casting each element
8850    of the original array into TYPE's (wider) element type.  */
8851
8852 static struct value *
8853 ada_promote_array_of_integrals (struct type *type, struct value *val)
8854 {
8855   struct type *elt_type = TYPE_TARGET_TYPE (type);
8856   LONGEST lo, hi;
8857   struct value *res;
8858   LONGEST i;
8859
8860   /* Verify that both val and type are arrays of scalars, and
8861      that the size of val's elements is smaller than the size
8862      of type's element.  */
8863   gdb_assert (type->code () == TYPE_CODE_ARRAY);
8864   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
8865   gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
8866   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
8867   gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
8868               > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
8869
8870   if (!get_array_bounds (type, &lo, &hi))
8871     error (_("unable to determine array bounds"));
8872
8873   res = allocate_value (type);
8874
8875   /* Promote each array element.  */
8876   for (i = 0; i < hi - lo + 1; i++)
8877     {
8878       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
8879
8880       memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
8881               value_contents_all (elt), TYPE_LENGTH (elt_type));
8882     }
8883
8884   return res;
8885 }
8886
8887 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8888    return the converted value.  */
8889
8890 static struct value *
8891 coerce_for_assign (struct type *type, struct value *val)
8892 {
8893   struct type *type2 = value_type (val);
8894
8895   if (type == type2)
8896     return val;
8897
8898   type2 = ada_check_typedef (type2);
8899   type = ada_check_typedef (type);
8900
8901   if (type2->code () == TYPE_CODE_PTR
8902       && type->code () == TYPE_CODE_ARRAY)
8903     {
8904       val = ada_value_ind (val);
8905       type2 = value_type (val);
8906     }
8907
8908   if (type2->code () == TYPE_CODE_ARRAY
8909       && type->code () == TYPE_CODE_ARRAY)
8910     {
8911       if (!ada_same_array_size_p (type, type2))
8912         error (_("cannot assign arrays of different length"));
8913
8914       if (is_integral_type (TYPE_TARGET_TYPE (type))
8915           && is_integral_type (TYPE_TARGET_TYPE (type2))
8916           && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8917                < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8918         {
8919           /* Allow implicit promotion of the array elements to
8920              a wider type.  */
8921           return ada_promote_array_of_integrals (type, val);
8922         }
8923
8924       if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8925           != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8926         error (_("Incompatible types in assignment"));
8927       deprecated_set_value_type (val, type);
8928     }
8929   return val;
8930 }
8931
8932 static struct value *
8933 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
8934 {
8935   struct value *val;
8936   struct type *type1, *type2;
8937   LONGEST v, v1, v2;
8938
8939   arg1 = coerce_ref (arg1);
8940   arg2 = coerce_ref (arg2);
8941   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
8942   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
8943
8944   if (type1->code () != TYPE_CODE_INT
8945       || type2->code () != TYPE_CODE_INT)
8946     return value_binop (arg1, arg2, op);
8947
8948   switch (op)
8949     {
8950     case BINOP_MOD:
8951     case BINOP_DIV:
8952     case BINOP_REM:
8953       break;
8954     default:
8955       return value_binop (arg1, arg2, op);
8956     }
8957
8958   v2 = value_as_long (arg2);
8959   if (v2 == 0)
8960     {
8961       const char *name;
8962       if (op == BINOP_MOD)
8963         name = "mod";
8964       else if (op == BINOP_DIV)
8965         name = "/";
8966       else
8967         {
8968           gdb_assert (op == BINOP_REM);
8969           name = "rem";
8970         }
8971
8972       error (_("second operand of %s must not be zero."), name);
8973     }
8974
8975   if (type1->is_unsigned () || op == BINOP_MOD)
8976     return value_binop (arg1, arg2, op);
8977
8978   v1 = value_as_long (arg1);
8979   switch (op)
8980     {
8981     case BINOP_DIV:
8982       v = v1 / v2;
8983       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
8984         v += v > 0 ? -1 : 1;
8985       break;
8986     case BINOP_REM:
8987       v = v1 % v2;
8988       if (v * v1 < 0)
8989         v -= v2;
8990       break;
8991     default:
8992       /* Should not reach this point.  */
8993       v = 0;
8994     }
8995
8996   val = allocate_value (type1);
8997   store_unsigned_integer (value_contents_raw (val),
8998                           TYPE_LENGTH (value_type (val)),
8999                           type_byte_order (type1), v);
9000   return val;
9001 }
9002
9003 static int
9004 ada_value_equal (struct value *arg1, struct value *arg2)
9005 {
9006   if (ada_is_direct_array_type (value_type (arg1))
9007       || ada_is_direct_array_type (value_type (arg2)))
9008     {
9009       struct type *arg1_type, *arg2_type;
9010
9011       /* Automatically dereference any array reference before
9012          we attempt to perform the comparison.  */
9013       arg1 = ada_coerce_ref (arg1);
9014       arg2 = ada_coerce_ref (arg2);
9015
9016       arg1 = ada_coerce_to_simple_array (arg1);
9017       arg2 = ada_coerce_to_simple_array (arg2);
9018
9019       arg1_type = ada_check_typedef (value_type (arg1));
9020       arg2_type = ada_check_typedef (value_type (arg2));
9021
9022       if (arg1_type->code () != TYPE_CODE_ARRAY
9023           || arg2_type->code () != TYPE_CODE_ARRAY)
9024         error (_("Attempt to compare array with non-array"));
9025       /* FIXME: The following works only for types whose
9026          representations use all bits (no padding or undefined bits)
9027          and do not have user-defined equality.  */
9028       return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9029               && memcmp (value_contents (arg1), value_contents (arg2),
9030                          TYPE_LENGTH (arg1_type)) == 0);
9031     }
9032   return value_equal (arg1, arg2);
9033 }
9034
9035 namespace expr
9036 {
9037
9038 bool
9039 check_objfile (const std::unique_ptr<ada_component> &comp,
9040                struct objfile *objfile)
9041 {
9042   return comp->uses_objfile (objfile);
9043 }
9044
9045 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9046    component of LHS (a simple array or a record).  Does not modify the
9047    inferior's memory, nor does it modify LHS (unless LHS ==
9048    CONTAINER).  */
9049
9050 static void
9051 assign_component (struct value *container, struct value *lhs, LONGEST index,
9052                   struct expression *exp, operation_up &arg)
9053 {
9054   scoped_value_mark mark;
9055
9056   struct value *elt;
9057   struct type *lhs_type = check_typedef (value_type (lhs));
9058
9059   if (lhs_type->code () == TYPE_CODE_ARRAY)
9060     {
9061       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9062       struct value *index_val = value_from_longest (index_type, index);
9063
9064       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9065     }
9066   else
9067     {
9068       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9069       elt = ada_to_fixed_value (elt);
9070     }
9071
9072   ada_aggregate_operation *ag_op
9073     = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9074   if (ag_op != nullptr)
9075     ag_op->assign_aggregate (container, elt, exp);
9076   else
9077     value_assign_to_component (container, elt,
9078                                arg->evaluate (nullptr, exp,
9079                                               EVAL_NORMAL));
9080 }
9081
9082 bool
9083 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9084 {
9085   for (const auto &item : m_components)
9086     if (item->uses_objfile (objfile))
9087       return true;
9088   return false;
9089 }
9090
9091 void
9092 ada_aggregate_component::dump (ui_file *stream, int depth)
9093 {
9094   fprintf_filtered (stream, _("%*sAggregate\n"), depth, "");
9095   for (const auto &item : m_components)
9096     item->dump (stream, depth + 1);
9097 }
9098
9099 void
9100 ada_aggregate_component::assign (struct value *container,
9101                                  struct value *lhs, struct expression *exp,
9102                                  std::vector<LONGEST> &indices,
9103                                  LONGEST low, LONGEST high)
9104 {
9105   for (auto &item : m_components)
9106     item->assign (container, lhs, exp, indices, low, high);
9107 }
9108
9109 /* See ada-exp.h.  */
9110
9111 value *
9112 ada_aggregate_operation::assign_aggregate (struct value *container,
9113                                            struct value *lhs,
9114                                            struct expression *exp)
9115 {
9116   struct type *lhs_type;
9117   LONGEST low_index, high_index;
9118
9119   container = ada_coerce_ref (container);
9120   if (ada_is_direct_array_type (value_type (container)))
9121     container = ada_coerce_to_simple_array (container);
9122   lhs = ada_coerce_ref (lhs);
9123   if (!deprecated_value_modifiable (lhs))
9124     error (_("Left operand of assignment is not a modifiable lvalue."));
9125
9126   lhs_type = check_typedef (value_type (lhs));
9127   if (ada_is_direct_array_type (lhs_type))
9128     {
9129       lhs = ada_coerce_to_simple_array (lhs);
9130       lhs_type = check_typedef (value_type (lhs));
9131       low_index = lhs_type->bounds ()->low.const_val ();
9132       high_index = lhs_type->bounds ()->high.const_val ();
9133     }
9134   else if (lhs_type->code () == TYPE_CODE_STRUCT)
9135     {
9136       low_index = 0;
9137       high_index = num_visible_fields (lhs_type) - 1;
9138     }
9139   else
9140     error (_("Left-hand side must be array or record."));
9141
9142   std::vector<LONGEST> indices (4);
9143   indices[0] = indices[1] = low_index - 1;
9144   indices[2] = indices[3] = high_index + 1;
9145
9146   std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9147                                    low_index, high_index);
9148
9149   return container;
9150 }
9151
9152 bool
9153 ada_positional_component::uses_objfile (struct objfile *objfile)
9154 {
9155   return m_op->uses_objfile (objfile);
9156 }
9157
9158 void
9159 ada_positional_component::dump (ui_file *stream, int depth)
9160 {
9161   fprintf_filtered (stream, _("%*sPositional, index = %d\n"),
9162                     depth, "", m_index);
9163   m_op->dump (stream, depth + 1);
9164 }
9165
9166 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9167    construct, given that the positions are relative to lower bound
9168    LOW, where HIGH is the upper bound.  Record the position in
9169    INDICES.  CONTAINER is as for assign_aggregate.  */
9170 void
9171 ada_positional_component::assign (struct value *container,
9172                                   struct value *lhs, struct expression *exp,
9173                                   std::vector<LONGEST> &indices,
9174                                   LONGEST low, LONGEST high)
9175 {
9176   LONGEST ind = m_index + low;
9177
9178   if (ind - 1 == high)
9179     warning (_("Extra components in aggregate ignored."));
9180   if (ind <= high)
9181     {
9182       add_component_interval (ind, ind, indices);
9183       assign_component (container, lhs, ind, exp, m_op);
9184     }
9185 }
9186
9187 bool
9188 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9189 {
9190   return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9191 }
9192
9193 void
9194 ada_discrete_range_association::dump (ui_file *stream, int depth)
9195 {
9196   fprintf_filtered (stream, _("%*sDiscrete range:\n"), depth, "");
9197   m_low->dump (stream, depth + 1);
9198   m_high->dump (stream, depth + 1);
9199 }
9200
9201 void
9202 ada_discrete_range_association::assign (struct value *container,
9203                                         struct value *lhs,
9204                                         struct expression *exp,
9205                                         std::vector<LONGEST> &indices,
9206                                         LONGEST low, LONGEST high,
9207                                         operation_up &op)
9208 {
9209   LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9210   LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9211
9212   if (lower <= upper && (lower < low || upper > high))
9213     error (_("Index in component association out of bounds."));
9214
9215   add_component_interval (lower, upper, indices);
9216   while (lower <= upper)
9217     {
9218       assign_component (container, lhs, lower, exp, op);
9219       lower += 1;
9220     }
9221 }
9222
9223 bool
9224 ada_name_association::uses_objfile (struct objfile *objfile)
9225 {
9226   return m_val->uses_objfile (objfile);
9227 }
9228
9229 void
9230 ada_name_association::dump (ui_file *stream, int depth)
9231 {
9232   fprintf_filtered (stream, _("%*sName:\n"), depth, "");
9233   m_val->dump (stream, depth + 1);
9234 }
9235
9236 void
9237 ada_name_association::assign (struct value *container,
9238                               struct value *lhs,
9239                               struct expression *exp,
9240                               std::vector<LONGEST> &indices,
9241                               LONGEST low, LONGEST high,
9242                               operation_up &op)
9243 {
9244   int index;
9245
9246   if (ada_is_direct_array_type (value_type (lhs)))
9247     index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9248                                                             EVAL_NORMAL)));
9249   else
9250     {
9251       ada_string_operation *strop
9252         = dynamic_cast<ada_string_operation *> (m_val.get ());
9253
9254       const char *name;
9255       if (strop != nullptr)
9256         name = strop->get_name ();
9257       else
9258         {
9259           ada_var_value_operation *vvo
9260             = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9261           if (vvo != nullptr)
9262             error (_("Invalid record component association."));
9263           name = vvo->get_symbol ()->natural_name ();
9264         }
9265
9266       index = 0;
9267       if (! find_struct_field (name, value_type (lhs), 0,
9268                                NULL, NULL, NULL, NULL, &index))
9269         error (_("Unknown component name: %s."), name);
9270     }
9271
9272   add_component_interval (index, index, indices);
9273   assign_component (container, lhs, index, exp, op);
9274 }
9275
9276 bool
9277 ada_choices_component::uses_objfile (struct objfile *objfile)
9278 {
9279   if (m_op->uses_objfile (objfile))
9280     return true;
9281   for (const auto &item : m_assocs)
9282     if (item->uses_objfile (objfile))
9283       return true;
9284   return false;
9285 }
9286
9287 void
9288 ada_choices_component::dump (ui_file *stream, int depth)
9289 {
9290   fprintf_filtered (stream, _("%*sChoices:\n"), depth, "");
9291   m_op->dump (stream, depth + 1);
9292   for (const auto &item : m_assocs)
9293     item->dump (stream, depth + 1);
9294 }
9295
9296 /* Assign into the components of LHS indexed by the OP_CHOICES
9297    construct at *POS, updating *POS past the construct, given that
9298    the allowable indices are LOW..HIGH.  Record the indices assigned
9299    to in INDICES.  CONTAINER is as for assign_aggregate.  */
9300 void
9301 ada_choices_component::assign (struct value *container,
9302                                struct value *lhs, struct expression *exp,
9303                                std::vector<LONGEST> &indices,
9304                                LONGEST low, LONGEST high)
9305 {
9306   for (auto &item : m_assocs)
9307     item->assign (container, lhs, exp, indices, low, high, m_op);
9308 }
9309
9310 bool
9311 ada_others_component::uses_objfile (struct objfile *objfile)
9312 {
9313   return m_op->uses_objfile (objfile);
9314 }
9315
9316 void
9317 ada_others_component::dump (ui_file *stream, int depth)
9318 {
9319   fprintf_filtered (stream, _("%*sOthers:\n"), depth, "");
9320   m_op->dump (stream, depth + 1);
9321 }
9322
9323 /* Assign the value of the expression in the OP_OTHERS construct in
9324    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9325    have not been previously assigned.  The index intervals already assigned
9326    are in INDICES.  CONTAINER is as for assign_aggregate.  */
9327 void
9328 ada_others_component::assign (struct value *container,
9329                               struct value *lhs, struct expression *exp,
9330                               std::vector<LONGEST> &indices,
9331                               LONGEST low, LONGEST high)
9332 {
9333   int num_indices = indices.size ();
9334   for (int i = 0; i < num_indices - 2; i += 2)
9335     {
9336       for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9337         assign_component (container, lhs, ind, exp, m_op);
9338     }
9339 }
9340
9341 struct value *
9342 ada_assign_operation::evaluate (struct type *expect_type,
9343                                 struct expression *exp,
9344                                 enum noside noside)
9345 {
9346   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9347
9348   ada_aggregate_operation *ag_op
9349     = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9350   if (ag_op != nullptr)
9351     {
9352       if (noside != EVAL_NORMAL)
9353         return arg1;
9354
9355       arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9356       return ada_value_assign (arg1, arg1);
9357     }
9358   /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9359      except if the lhs of our assignment is a convenience variable.
9360      In the case of assigning to a convenience variable, the lhs
9361      should be exactly the result of the evaluation of the rhs.  */
9362   struct type *type = value_type (arg1);
9363   if (VALUE_LVAL (arg1) == lval_internalvar)
9364     type = NULL;
9365   value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9366   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9367     return arg1;
9368   if (VALUE_LVAL (arg1) == lval_internalvar)
9369     {
9370       /* Nothing.  */
9371     }
9372   else
9373     arg2 = coerce_for_assign (value_type (arg1), arg2);
9374   return ada_value_assign (arg1, arg2);
9375 }
9376
9377 } /* namespace expr */
9378
9379 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9380    [ INDICES[0] .. INDICES[1] ],...  The resulting intervals do not
9381    overlap.  */
9382 static void
9383 add_component_interval (LONGEST low, LONGEST high, 
9384                         std::vector<LONGEST> &indices)
9385 {
9386   int i, j;
9387
9388   int size = indices.size ();
9389   for (i = 0; i < size; i += 2) {
9390     if (high >= indices[i] && low <= indices[i + 1])
9391       {
9392         int kh;
9393
9394         for (kh = i + 2; kh < size; kh += 2)
9395           if (high < indices[kh])
9396             break;
9397         if (low < indices[i])
9398           indices[i] = low;
9399         indices[i + 1] = indices[kh - 1];
9400         if (high > indices[i + 1])
9401           indices[i + 1] = high;
9402         memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9403         indices.resize (kh - i - 2);
9404         return;
9405       }
9406     else if (high < indices[i])
9407       break;
9408   }
9409         
9410   indices.resize (indices.size () + 2);
9411   for (j = indices.size () - 1; j >= i + 2; j -= 1)
9412     indices[j] = indices[j - 2];
9413   indices[i] = low;
9414   indices[i + 1] = high;
9415 }
9416
9417 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9418    is different.  */
9419
9420 static struct value *
9421 ada_value_cast (struct type *type, struct value *arg2)
9422 {
9423   if (type == ada_check_typedef (value_type (arg2)))
9424     return arg2;
9425
9426   return value_cast (type, arg2);
9427 }
9428
9429 /*  Evaluating Ada expressions, and printing their result.
9430     ------------------------------------------------------
9431
9432     1. Introduction:
9433     ----------------
9434
9435     We usually evaluate an Ada expression in order to print its value.
9436     We also evaluate an expression in order to print its type, which
9437     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9438     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
9439     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9440     the evaluation compared to the EVAL_NORMAL, but is otherwise very
9441     similar.
9442
9443     Evaluating expressions is a little more complicated for Ada entities
9444     than it is for entities in languages such as C.  The main reason for
9445     this is that Ada provides types whose definition might be dynamic.
9446     One example of such types is variant records.  Or another example
9447     would be an array whose bounds can only be known at run time.
9448
9449     The following description is a general guide as to what should be
9450     done (and what should NOT be done) in order to evaluate an expression
9451     involving such types, and when.  This does not cover how the semantic
9452     information is encoded by GNAT as this is covered separatly.  For the
9453     document used as the reference for the GNAT encoding, see exp_dbug.ads
9454     in the GNAT sources.
9455
9456     Ideally, we should embed each part of this description next to its
9457     associated code.  Unfortunately, the amount of code is so vast right
9458     now that it's hard to see whether the code handling a particular
9459     situation might be duplicated or not.  One day, when the code is
9460     cleaned up, this guide might become redundant with the comments
9461     inserted in the code, and we might want to remove it.
9462
9463     2. ``Fixing'' an Entity, the Simple Case:
9464     -----------------------------------------
9465
9466     When evaluating Ada expressions, the tricky issue is that they may
9467     reference entities whose type contents and size are not statically
9468     known.  Consider for instance a variant record:
9469
9470        type Rec (Empty : Boolean := True) is record
9471           case Empty is
9472              when True => null;
9473              when False => Value : Integer;
9474           end case;
9475        end record;
9476        Yes : Rec := (Empty => False, Value => 1);
9477        No  : Rec := (empty => True);
9478
9479     The size and contents of that record depends on the value of the
9480     descriminant (Rec.Empty).  At this point, neither the debugging
9481     information nor the associated type structure in GDB are able to
9482     express such dynamic types.  So what the debugger does is to create
9483     "fixed" versions of the type that applies to the specific object.
9484     We also informally refer to this operation as "fixing" an object,
9485     which means creating its associated fixed type.
9486
9487     Example: when printing the value of variable "Yes" above, its fixed
9488     type would look like this:
9489
9490        type Rec is record
9491           Empty : Boolean;
9492           Value : Integer;
9493        end record;
9494
9495     On the other hand, if we printed the value of "No", its fixed type
9496     would become:
9497
9498        type Rec is record
9499           Empty : Boolean;
9500        end record;
9501
9502     Things become a little more complicated when trying to fix an entity
9503     with a dynamic type that directly contains another dynamic type,
9504     such as an array of variant records, for instance.  There are
9505     two possible cases: Arrays, and records.
9506
9507     3. ``Fixing'' Arrays:
9508     ---------------------
9509
9510     The type structure in GDB describes an array in terms of its bounds,
9511     and the type of its elements.  By design, all elements in the array
9512     have the same type and we cannot represent an array of variant elements
9513     using the current type structure in GDB.  When fixing an array,
9514     we cannot fix the array element, as we would potentially need one
9515     fixed type per element of the array.  As a result, the best we can do
9516     when fixing an array is to produce an array whose bounds and size
9517     are correct (allowing us to read it from memory), but without having
9518     touched its element type.  Fixing each element will be done later,
9519     when (if) necessary.
9520
9521     Arrays are a little simpler to handle than records, because the same
9522     amount of memory is allocated for each element of the array, even if
9523     the amount of space actually used by each element differs from element
9524     to element.  Consider for instance the following array of type Rec:
9525
9526        type Rec_Array is array (1 .. 2) of Rec;
9527
9528     The actual amount of memory occupied by each element might be different
9529     from element to element, depending on the value of their discriminant.
9530     But the amount of space reserved for each element in the array remains
9531     fixed regardless.  So we simply need to compute that size using
9532     the debugging information available, from which we can then determine
9533     the array size (we multiply the number of elements of the array by
9534     the size of each element).
9535
9536     The simplest case is when we have an array of a constrained element
9537     type. For instance, consider the following type declarations:
9538
9539         type Bounded_String (Max_Size : Integer) is
9540            Length : Integer;
9541            Buffer : String (1 .. Max_Size);
9542         end record;
9543         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9544
9545     In this case, the compiler describes the array as an array of
9546     variable-size elements (identified by its XVS suffix) for which
9547     the size can be read in the parallel XVZ variable.
9548
9549     In the case of an array of an unconstrained element type, the compiler
9550     wraps the array element inside a private PAD type.  This type should not
9551     be shown to the user, and must be "unwrap"'ed before printing.  Note
9552     that we also use the adjective "aligner" in our code to designate
9553     these wrapper types.
9554
9555     In some cases, the size allocated for each element is statically
9556     known.  In that case, the PAD type already has the correct size,
9557     and the array element should remain unfixed.
9558
9559     But there are cases when this size is not statically known.
9560     For instance, assuming that "Five" is an integer variable:
9561
9562         type Dynamic is array (1 .. Five) of Integer;
9563         type Wrapper (Has_Length : Boolean := False) is record
9564            Data : Dynamic;
9565            case Has_Length is
9566               when True => Length : Integer;
9567               when False => null;
9568            end case;
9569         end record;
9570         type Wrapper_Array is array (1 .. 2) of Wrapper;
9571
9572         Hello : Wrapper_Array := (others => (Has_Length => True,
9573                                              Data => (others => 17),
9574                                              Length => 1));
9575
9576
9577     The debugging info would describe variable Hello as being an
9578     array of a PAD type.  The size of that PAD type is not statically
9579     known, but can be determined using a parallel XVZ variable.
9580     In that case, a copy of the PAD type with the correct size should
9581     be used for the fixed array.
9582
9583     3. ``Fixing'' record type objects:
9584     ----------------------------------
9585
9586     Things are slightly different from arrays in the case of dynamic
9587     record types.  In this case, in order to compute the associated
9588     fixed type, we need to determine the size and offset of each of
9589     its components.  This, in turn, requires us to compute the fixed
9590     type of each of these components.
9591
9592     Consider for instance the example:
9593
9594         type Bounded_String (Max_Size : Natural) is record
9595            Str : String (1 .. Max_Size);
9596            Length : Natural;
9597         end record;
9598         My_String : Bounded_String (Max_Size => 10);
9599
9600     In that case, the position of field "Length" depends on the size
9601     of field Str, which itself depends on the value of the Max_Size
9602     discriminant.  In order to fix the type of variable My_String,
9603     we need to fix the type of field Str.  Therefore, fixing a variant
9604     record requires us to fix each of its components.
9605
9606     However, if a component does not have a dynamic size, the component
9607     should not be fixed.  In particular, fields that use a PAD type
9608     should not fixed.  Here is an example where this might happen
9609     (assuming type Rec above):
9610
9611        type Container (Big : Boolean) is record
9612           First : Rec;
9613           After : Integer;
9614           case Big is
9615              when True => Another : Integer;
9616              when False => null;
9617           end case;
9618        end record;
9619        My_Container : Container := (Big => False,
9620                                     First => (Empty => True),
9621                                     After => 42);
9622
9623     In that example, the compiler creates a PAD type for component First,
9624     whose size is constant, and then positions the component After just
9625     right after it.  The offset of component After is therefore constant
9626     in this case.
9627
9628     The debugger computes the position of each field based on an algorithm
9629     that uses, among other things, the actual position and size of the field
9630     preceding it.  Let's now imagine that the user is trying to print
9631     the value of My_Container.  If the type fixing was recursive, we would
9632     end up computing the offset of field After based on the size of the
9633     fixed version of field First.  And since in our example First has
9634     only one actual field, the size of the fixed type is actually smaller
9635     than the amount of space allocated to that field, and thus we would
9636     compute the wrong offset of field After.
9637
9638     To make things more complicated, we need to watch out for dynamic
9639     components of variant records (identified by the ___XVL suffix in
9640     the component name).  Even if the target type is a PAD type, the size
9641     of that type might not be statically known.  So the PAD type needs
9642     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
9643     we might end up with the wrong size for our component.  This can be
9644     observed with the following type declarations:
9645
9646         type Octal is new Integer range 0 .. 7;
9647         type Octal_Array is array (Positive range <>) of Octal;
9648         pragma Pack (Octal_Array);
9649
9650         type Octal_Buffer (Size : Positive) is record
9651            Buffer : Octal_Array (1 .. Size);
9652            Length : Integer;
9653         end record;
9654
9655     In that case, Buffer is a PAD type whose size is unset and needs
9656     to be computed by fixing the unwrapped type.
9657
9658     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9659     ----------------------------------------------------------
9660
9661     Lastly, when should the sub-elements of an entity that remained unfixed
9662     thus far, be actually fixed?
9663
9664     The answer is: Only when referencing that element.  For instance
9665     when selecting one component of a record, this specific component
9666     should be fixed at that point in time.  Or when printing the value
9667     of a record, each component should be fixed before its value gets
9668     printed.  Similarly for arrays, the element of the array should be
9669     fixed when printing each element of the array, or when extracting
9670     one element out of that array.  On the other hand, fixing should
9671     not be performed on the elements when taking a slice of an array!
9672
9673     Note that one of the side effects of miscomputing the offset and
9674     size of each field is that we end up also miscomputing the size
9675     of the containing type.  This can have adverse results when computing
9676     the value of an entity.  GDB fetches the value of an entity based
9677     on the size of its type, and thus a wrong size causes GDB to fetch
9678     the wrong amount of memory.  In the case where the computed size is
9679     too small, GDB fetches too little data to print the value of our
9680     entity.  Results in this case are unpredictable, as we usually read
9681     past the buffer containing the data =:-o.  */
9682
9683 /* A helper function for TERNOP_IN_RANGE.  */
9684
9685 static value *
9686 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
9687                       enum noside noside,
9688                       value *arg1, value *arg2, value *arg3)
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   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9710   return value_neg (arg1);
9711 }
9712
9713 /* A helper function for UNOP_IN_RANGE.  */
9714
9715 value *
9716 ada_unop_in_range (struct type *expect_type,
9717                    struct expression *exp,
9718                    enum noside noside, enum exp_opcode op,
9719                    struct value *arg1, struct type *type)
9720 {
9721   struct value *arg2, *arg3;
9722   switch (type->code ())
9723     {
9724     default:
9725       lim_warning (_("Membership test incompletely implemented; "
9726                      "always returns true"));
9727       type = language_bool_type (exp->language_defn, exp->gdbarch);
9728       return value_from_longest (type, (LONGEST) 1);
9729
9730     case TYPE_CODE_RANGE:
9731       arg2 = value_from_longest (type,
9732                                  type->bounds ()->low.const_val ());
9733       arg3 = value_from_longest (type,
9734                                  type->bounds ()->high.const_val ());
9735       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9736       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9737       type = language_bool_type (exp->language_defn, exp->gdbarch);
9738       return
9739         value_from_longest (type,
9740                             (value_less (arg1, arg3)
9741                              || value_equal (arg1, arg3))
9742                             && (value_less (arg2, arg1)
9743                                 || value_equal (arg2, arg1)));
9744     }
9745 }
9746
9747 /* A helper function for OP_ATR_TAG.  */
9748
9749 value *
9750 ada_atr_tag (struct type *expect_type,
9751              struct expression *exp,
9752              enum noside noside, enum exp_opcode op,
9753              struct value *arg1)
9754 {
9755   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9756     return value_zero (ada_tag_type (arg1), not_lval);
9757
9758   return ada_value_tag (arg1);
9759 }
9760
9761 /* A helper function for OP_ATR_SIZE.  */
9762
9763 value *
9764 ada_atr_size (struct type *expect_type,
9765               struct expression *exp,
9766               enum noside noside, enum exp_opcode op,
9767               struct value *arg1)
9768 {
9769   struct type *type = value_type (arg1);
9770
9771   /* If the argument is a reference, then dereference its type, since
9772      the user is really asking for the size of the actual object,
9773      not the size of the pointer.  */
9774   if (type->code () == TYPE_CODE_REF)
9775     type = TYPE_TARGET_TYPE (type);
9776
9777   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9778     return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
9779   else
9780     return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
9781                                TARGET_CHAR_BIT * TYPE_LENGTH (type));
9782 }
9783
9784 /* A helper function for UNOP_ABS.  */
9785
9786 value *
9787 ada_abs (struct type *expect_type,
9788          struct expression *exp,
9789          enum noside noside, enum exp_opcode op,
9790          struct value *arg1)
9791 {
9792   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9793   if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
9794     return value_neg (arg1);
9795   else
9796     return arg1;
9797 }
9798
9799 /* A helper function for BINOP_MUL.  */
9800
9801 value *
9802 ada_mult_binop (struct type *expect_type,
9803                 struct expression *exp,
9804                 enum noside noside, enum exp_opcode op,
9805                 struct value *arg1, struct value *arg2)
9806 {
9807   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9808     {
9809       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9810       return value_zero (value_type (arg1), not_lval);
9811     }
9812   else
9813     {
9814       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9815       return ada_value_binop (arg1, arg2, op);
9816     }
9817 }
9818
9819 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL.  */
9820
9821 value *
9822 ada_equal_binop (struct type *expect_type,
9823                  struct expression *exp,
9824                  enum noside noside, enum exp_opcode op,
9825                  struct value *arg1, struct value *arg2)
9826 {
9827   int tem;
9828   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9829     tem = 0;
9830   else
9831     {
9832       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9833       tem = ada_value_equal (arg1, arg2);
9834     }
9835   if (op == BINOP_NOTEQUAL)
9836     tem = !tem;
9837   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
9838   return value_from_longest (type, (LONGEST) tem);
9839 }
9840
9841 /* A helper function for TERNOP_SLICE.  */
9842
9843 value *
9844 ada_ternop_slice (struct expression *exp,
9845                   enum noside noside,
9846                   struct value *array, struct value *low_bound_val,
9847                   struct value *high_bound_val)
9848 {
9849   LONGEST low_bound;
9850   LONGEST high_bound;
9851
9852   low_bound_val = coerce_ref (low_bound_val);
9853   high_bound_val = coerce_ref (high_bound_val);
9854   low_bound = value_as_long (low_bound_val);
9855   high_bound = value_as_long (high_bound_val);
9856
9857   /* If this is a reference to an aligner type, then remove all
9858      the aligners.  */
9859   if (value_type (array)->code () == TYPE_CODE_REF
9860       && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
9861     TYPE_TARGET_TYPE (value_type (array)) =
9862       ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
9863
9864   if (ada_is_any_packed_array_type (value_type (array)))
9865     error (_("cannot slice a packed array"));
9866
9867   /* If this is a reference to an array or an array lvalue,
9868      convert to a pointer.  */
9869   if (value_type (array)->code () == TYPE_CODE_REF
9870       || (value_type (array)->code () == TYPE_CODE_ARRAY
9871           && VALUE_LVAL (array) == lval_memory))
9872     array = value_addr (array);
9873
9874   if (noside == EVAL_AVOID_SIDE_EFFECTS
9875       && ada_is_array_descriptor_type (ada_check_typedef
9876                                        (value_type (array))))
9877     return empty_array (ada_type_of_array (array, 0), low_bound,
9878                         high_bound);
9879
9880   array = ada_coerce_to_simple_array_ptr (array);
9881
9882   /* If we have more than one level of pointer indirection,
9883      dereference the value until we get only one level.  */
9884   while (value_type (array)->code () == TYPE_CODE_PTR
9885          && (TYPE_TARGET_TYPE (value_type (array))->code ()
9886              == TYPE_CODE_PTR))
9887     array = value_ind (array);
9888
9889   /* Make sure we really do have an array type before going further,
9890      to avoid a SEGV when trying to get the index type or the target
9891      type later down the road if the debug info generated by
9892      the compiler is incorrect or incomplete.  */
9893   if (!ada_is_simple_array_type (value_type (array)))
9894     error (_("cannot take slice of non-array"));
9895
9896   if (ada_check_typedef (value_type (array))->code ()
9897       == TYPE_CODE_PTR)
9898     {
9899       struct type *type0 = ada_check_typedef (value_type (array));
9900
9901       if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
9902         return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
9903       else
9904         {
9905           struct type *arr_type0 =
9906             to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
9907
9908           return ada_value_slice_from_ptr (array, arr_type0,
9909                                            longest_to_int (low_bound),
9910                                            longest_to_int (high_bound));
9911         }
9912     }
9913   else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9914     return array;
9915   else if (high_bound < low_bound)
9916     return empty_array (value_type (array), low_bound, high_bound);
9917   else
9918     return ada_value_slice (array, longest_to_int (low_bound),
9919                             longest_to_int (high_bound));
9920 }
9921
9922 /* A helper function for BINOP_IN_BOUNDS.  */
9923
9924 value *
9925 ada_binop_in_bounds (struct expression *exp, enum noside noside,
9926                      struct value *arg1, struct value *arg2, int n)
9927 {
9928   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9929     {
9930       struct type *type = language_bool_type (exp->language_defn,
9931                                               exp->gdbarch);
9932       return value_zero (type, not_lval);
9933     }
9934
9935   struct type *type = ada_index_type (value_type (arg2), n, "range");
9936   if (!type)
9937     type = value_type (arg1);
9938
9939   value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
9940   arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
9941
9942   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9943   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9944   type = language_bool_type (exp->language_defn, exp->gdbarch);
9945   return value_from_longest (type,
9946                              (value_less (arg1, arg3)
9947                               || value_equal (arg1, arg3))
9948                              && (value_less (arg2, arg1)
9949                                  || value_equal (arg2, arg1)));
9950 }
9951
9952 /* A helper function for some attribute operations.  */
9953
9954 static value *
9955 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
9956               struct value *arg1, struct type *type_arg, int tem)
9957 {
9958   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9959     {
9960       if (type_arg == NULL)
9961         type_arg = value_type (arg1);
9962
9963       if (ada_is_constrained_packed_array_type (type_arg))
9964         type_arg = decode_constrained_packed_array_type (type_arg);
9965
9966       if (!discrete_type_p (type_arg))
9967         {
9968           switch (op)
9969             {
9970             default:          /* Should never happen.  */
9971               error (_("unexpected attribute encountered"));
9972             case OP_ATR_FIRST:
9973             case OP_ATR_LAST:
9974               type_arg = ada_index_type (type_arg, tem,
9975                                          ada_attribute_name (op));
9976               break;
9977             case OP_ATR_LENGTH:
9978               type_arg = builtin_type (exp->gdbarch)->builtin_int;
9979               break;
9980             }
9981         }
9982
9983       return value_zero (type_arg, not_lval);
9984     }
9985   else if (type_arg == NULL)
9986     {
9987       arg1 = ada_coerce_ref (arg1);
9988
9989       if (ada_is_constrained_packed_array_type (value_type (arg1)))
9990         arg1 = ada_coerce_to_simple_array (arg1);
9991
9992       struct type *type;
9993       if (op == OP_ATR_LENGTH)
9994         type = builtin_type (exp->gdbarch)->builtin_int;
9995       else
9996         {
9997           type = ada_index_type (value_type (arg1), tem,
9998                                  ada_attribute_name (op));
9999           if (type == NULL)
10000             type = builtin_type (exp->gdbarch)->builtin_int;
10001         }
10002
10003       switch (op)
10004         {
10005         default:          /* Should never happen.  */
10006           error (_("unexpected attribute encountered"));
10007         case OP_ATR_FIRST:
10008           return value_from_longest
10009             (type, ada_array_bound (arg1, tem, 0));
10010         case OP_ATR_LAST:
10011           return value_from_longest
10012             (type, ada_array_bound (arg1, tem, 1));
10013         case OP_ATR_LENGTH:
10014           return value_from_longest
10015             (type, ada_array_length (arg1, tem));
10016         }
10017     }
10018   else if (discrete_type_p (type_arg))
10019     {
10020       struct type *range_type;
10021       const char *name = ada_type_name (type_arg);
10022
10023       range_type = NULL;
10024       if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10025         range_type = to_fixed_range_type (type_arg, NULL);
10026       if (range_type == NULL)
10027         range_type = type_arg;
10028       switch (op)
10029         {
10030         default:
10031           error (_("unexpected attribute encountered"));
10032         case OP_ATR_FIRST:
10033           return value_from_longest 
10034             (range_type, ada_discrete_type_low_bound (range_type));
10035         case OP_ATR_LAST:
10036           return value_from_longest
10037             (range_type, ada_discrete_type_high_bound (range_type));
10038         case OP_ATR_LENGTH:
10039           error (_("the 'length attribute applies only to array types"));
10040         }
10041     }
10042   else if (type_arg->code () == TYPE_CODE_FLT)
10043     error (_("unimplemented type attribute"));
10044   else
10045     {
10046       LONGEST low, high;
10047
10048       if (ada_is_constrained_packed_array_type (type_arg))
10049         type_arg = decode_constrained_packed_array_type (type_arg);
10050
10051       struct type *type;
10052       if (op == OP_ATR_LENGTH)
10053         type = builtin_type (exp->gdbarch)->builtin_int;
10054       else
10055         {
10056           type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10057           if (type == NULL)
10058             type = builtin_type (exp->gdbarch)->builtin_int;
10059         }
10060
10061       switch (op)
10062         {
10063         default:
10064           error (_("unexpected attribute encountered"));
10065         case OP_ATR_FIRST:
10066           low = ada_array_bound_from_type (type_arg, tem, 0);
10067           return value_from_longest (type, low);
10068         case OP_ATR_LAST:
10069           high = ada_array_bound_from_type (type_arg, tem, 1);
10070           return value_from_longest (type, high);
10071         case OP_ATR_LENGTH:
10072           low = ada_array_bound_from_type (type_arg, tem, 0);
10073           high = ada_array_bound_from_type (type_arg, tem, 1);
10074           return value_from_longest (type, high - low + 1);
10075         }
10076     }
10077 }
10078
10079 /* A helper function for OP_ATR_MIN and OP_ATR_MAX.  */
10080
10081 struct value *
10082 ada_binop_minmax (struct type *expect_type,
10083                   struct expression *exp,
10084                   enum noside noside, enum exp_opcode op,
10085                   struct value *arg1, struct value *arg2)
10086 {
10087   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10088     return value_zero (value_type (arg1), not_lval);
10089   else
10090     {
10091       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10092       return value_binop (arg1, arg2, op);
10093     }
10094 }
10095
10096 /* A helper function for BINOP_EXP.  */
10097
10098 struct value *
10099 ada_binop_exp (struct type *expect_type,
10100                struct expression *exp,
10101                enum noside noside, enum exp_opcode op,
10102                struct value *arg1, struct value *arg2)
10103 {
10104   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10105     return value_zero (value_type (arg1), not_lval);
10106   else
10107     {
10108       /* For integer exponentiation operations,
10109          only promote the first argument.  */
10110       if (is_integral_type (value_type (arg2)))
10111         unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10112       else
10113         binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10114
10115       return value_binop (arg1, arg2, op);
10116     }
10117 }
10118
10119 namespace expr
10120 {
10121
10122 value *
10123 ada_wrapped_operation::evaluate (struct type *expect_type,
10124                                  struct expression *exp,
10125                                  enum noside noside)
10126 {
10127   value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10128   if (noside == EVAL_NORMAL)
10129     result = unwrap_value (result);
10130
10131   /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10132      then we need to perform the conversion manually, because
10133      evaluate_subexp_standard doesn't do it.  This conversion is
10134      necessary in Ada because the different kinds of float/fixed
10135      types in Ada have different representations.
10136
10137      Similarly, we need to perform the conversion from OP_LONG
10138      ourselves.  */
10139   if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10140     result = ada_value_cast (expect_type, result);
10141
10142   return result;
10143 }
10144
10145 value *
10146 ada_string_operation::evaluate (struct type *expect_type,
10147                                 struct expression *exp,
10148                                 enum noside noside)
10149 {
10150   value *result = string_operation::evaluate (expect_type, exp, noside);
10151   /* The result type will have code OP_STRING, bashed there from 
10152      OP_ARRAY.  Bash it back.  */
10153   if (value_type (result)->code () == TYPE_CODE_STRING)
10154     value_type (result)->set_code (TYPE_CODE_ARRAY);
10155   return result;
10156 }
10157
10158 value *
10159 ada_qual_operation::evaluate (struct type *expect_type,
10160                               struct expression *exp,
10161                               enum noside noside)
10162 {
10163   struct type *type = std::get<1> (m_storage);
10164   return std::get<0> (m_storage)->evaluate (type, exp, noside);
10165 }
10166
10167 value *
10168 ada_ternop_range_operation::evaluate (struct type *expect_type,
10169                                       struct expression *exp,
10170                                       enum noside noside)
10171 {
10172   value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10173   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10174   value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10175   return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10176 }
10177
10178 value *
10179 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10180                                       struct expression *exp,
10181                                       enum noside noside)
10182 {
10183   value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10184   value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10185
10186   auto do_op = [=] (LONGEST x, LONGEST y)
10187     {
10188       if (std::get<0> (m_storage) == BINOP_ADD)
10189         return x + y;
10190       return x - y;
10191     };
10192
10193   if (value_type (arg1)->code () == TYPE_CODE_PTR)
10194     return (value_from_longest
10195             (value_type (arg1),
10196              do_op (value_as_long (arg1), value_as_long (arg2))));
10197   if (value_type (arg2)->code () == TYPE_CODE_PTR)
10198     return (value_from_longest
10199             (value_type (arg2),
10200              do_op (value_as_long (arg1), value_as_long (arg2))));
10201   /* Preserve the original type for use by the range case below.
10202      We cannot cast the result to a reference type, so if ARG1 is
10203      a reference type, find its underlying type.  */
10204   struct type *type = value_type (arg1);
10205   while (type->code () == TYPE_CODE_REF)
10206     type = TYPE_TARGET_TYPE (type);
10207   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10208   arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10209   /* We need to special-case the result with a range.
10210      This is done for the benefit of "ptype".  gdb's Ada support
10211      historically used the LHS to set the result type here, so
10212      preserve this behavior.  */
10213   if (type->code () == TYPE_CODE_RANGE)
10214     arg1 = value_cast (type, arg1);
10215   return arg1;
10216 }
10217
10218 value *
10219 ada_unop_atr_operation::evaluate (struct type *expect_type,
10220                                   struct expression *exp,
10221                                   enum noside noside)
10222 {
10223   struct type *type_arg = nullptr;
10224   value *val = nullptr;
10225
10226   if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10227     {
10228       value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10229                                                       EVAL_AVOID_SIDE_EFFECTS);
10230       type_arg = value_type (tem);
10231     }
10232   else
10233     val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10234
10235   return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10236                        val, type_arg, std::get<2> (m_storage));
10237 }
10238
10239 value *
10240 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10241                                                  struct expression *exp,
10242                                                  enum noside noside)
10243 {
10244   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10245     return value_zero (expect_type, not_lval);
10246
10247   const bound_minimal_symbol &b = std::get<0> (m_storage);
10248   value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10249
10250   val = ada_value_cast (expect_type, val);
10251
10252   /* Follow the Ada language semantics that do not allow taking
10253      an address of the result of a cast (view conversion in Ada).  */
10254   if (VALUE_LVAL (val) == lval_memory)
10255     {
10256       if (value_lazy (val))
10257         value_fetch_lazy (val);
10258       VALUE_LVAL (val) = not_lval;
10259     }
10260   return val;
10261 }
10262
10263 value *
10264 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10265                                             struct expression *exp,
10266                                             enum noside noside)
10267 {
10268   value *val = evaluate_var_value (noside,
10269                                    std::get<0> (m_storage).block,
10270                                    std::get<0> (m_storage).symbol);
10271
10272   val = ada_value_cast (expect_type, val);
10273
10274   /* Follow the Ada language semantics that do not allow taking
10275      an address of the result of a cast (view conversion in Ada).  */
10276   if (VALUE_LVAL (val) == lval_memory)
10277     {
10278       if (value_lazy (val))
10279         value_fetch_lazy (val);
10280       VALUE_LVAL (val) = not_lval;
10281     }
10282   return val;
10283 }
10284
10285 value *
10286 ada_var_value_operation::evaluate (struct type *expect_type,
10287                                    struct expression *exp,
10288                                    enum noside noside)
10289 {
10290   symbol *sym = std::get<0> (m_storage).symbol;
10291
10292   if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
10293     /* Only encountered when an unresolved symbol occurs in a
10294        context other than a function call, in which case, it is
10295        invalid.  */
10296     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10297            sym->print_name ());
10298
10299   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10300     {
10301       struct type *type = static_unwrap_type (SYMBOL_TYPE (sym));
10302       /* Check to see if this is a tagged type.  We also need to handle
10303          the case where the type is a reference to a tagged type, but
10304          we have to be careful to exclude pointers to tagged types.
10305          The latter should be shown as usual (as a pointer), whereas
10306          a reference should mostly be transparent to the user.  */
10307       if (ada_is_tagged_type (type, 0)
10308           || (type->code () == TYPE_CODE_REF
10309               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10310         {
10311           /* Tagged types are a little special in the fact that the real
10312              type is dynamic and can only be determined by inspecting the
10313              object's tag.  This means that we need to get the object's
10314              value first (EVAL_NORMAL) and then extract the actual object
10315              type from its tag.
10316
10317              Note that we cannot skip the final step where we extract
10318              the object type from its tag, because the EVAL_NORMAL phase
10319              results in dynamic components being resolved into fixed ones.
10320              This can cause problems when trying to print the type
10321              description of tagged types whose parent has a dynamic size:
10322              We use the type name of the "_parent" component in order
10323              to print the name of the ancestor type in the type description.
10324              If that component had a dynamic size, the resolution into
10325              a fixed type would result in the loss of that type name,
10326              thus preventing us from printing the name of the ancestor
10327              type in the type description.  */
10328           value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10329
10330           if (type->code () != TYPE_CODE_REF)
10331             {
10332               struct type *actual_type;
10333
10334               actual_type = type_from_tag (ada_value_tag (arg1));
10335               if (actual_type == NULL)
10336                 /* If, for some reason, we were unable to determine
10337                    the actual type from the tag, then use the static
10338                    approximation that we just computed as a fallback.
10339                    This can happen if the debugging information is
10340                    incomplete, for instance.  */
10341                 actual_type = type;
10342               return value_zero (actual_type, not_lval);
10343             }
10344           else
10345             {
10346               /* In the case of a ref, ada_coerce_ref takes care
10347                  of determining the actual type.  But the evaluation
10348                  should return a ref as it should be valid to ask
10349                  for its address; so rebuild a ref after coerce.  */
10350               arg1 = ada_coerce_ref (arg1);
10351               return value_ref (arg1, TYPE_CODE_REF);
10352             }
10353         }
10354
10355       /* Records and unions for which GNAT encodings have been
10356          generated need to be statically fixed as well.
10357          Otherwise, non-static fixing produces a type where
10358          all dynamic properties are removed, which prevents "ptype"
10359          from being able to completely describe the type.
10360          For instance, a case statement in a variant record would be
10361          replaced by the relevant components based on the actual
10362          value of the discriminants.  */
10363       if ((type->code () == TYPE_CODE_STRUCT
10364            && dynamic_template_type (type) != NULL)
10365           || (type->code () == TYPE_CODE_UNION
10366               && ada_find_parallel_type (type, "___XVU") != NULL))
10367         return value_zero (to_static_fixed_type (type), not_lval);
10368     }
10369
10370   value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10371   return ada_to_fixed_value (arg1);
10372 }
10373
10374 bool
10375 ada_var_value_operation::resolve (struct expression *exp,
10376                                   bool deprocedure_p,
10377                                   bool parse_completion,
10378                                   innermost_block_tracker *tracker,
10379                                   struct type *context_type)
10380 {
10381   symbol *sym = std::get<0> (m_storage).symbol;
10382   if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
10383     {
10384       block_symbol resolved
10385         = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10386                                 context_type, parse_completion,
10387                                 deprocedure_p, tracker);
10388       std::get<0> (m_storage) = resolved;
10389     }
10390
10391   if (deprocedure_p
10392       && (SYMBOL_TYPE (std::get<0> (m_storage).symbol)->code ()
10393           == TYPE_CODE_FUNC))
10394     return true;
10395
10396   return false;
10397 }
10398
10399 value *
10400 ada_atr_val_operation::evaluate (struct type *expect_type,
10401                                  struct expression *exp,
10402                                  enum noside noside)
10403 {
10404   value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10405   return ada_val_atr (noside, std::get<0> (m_storage), arg);
10406 }
10407
10408 value *
10409 ada_unop_ind_operation::evaluate (struct type *expect_type,
10410                                   struct expression *exp,
10411                                   enum noside noside)
10412 {
10413   value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10414
10415   struct type *type = ada_check_typedef (value_type (arg1));
10416   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10417     {
10418       if (ada_is_array_descriptor_type (type))
10419         /* GDB allows dereferencing GNAT array descriptors.  */
10420         {
10421           struct type *arrType = ada_type_of_array (arg1, 0);
10422
10423           if (arrType == NULL)
10424             error (_("Attempt to dereference null array pointer."));
10425           return value_at_lazy (arrType, 0);
10426         }
10427       else if (type->code () == TYPE_CODE_PTR
10428                || type->code () == TYPE_CODE_REF
10429                /* In C you can dereference an array to get the 1st elt.  */
10430                || type->code () == TYPE_CODE_ARRAY)
10431         {
10432           /* As mentioned in the OP_VAR_VALUE case, tagged types can
10433              only be determined by inspecting the object's tag.
10434              This means that we need to evaluate completely the
10435              expression in order to get its type.  */
10436
10437           if ((type->code () == TYPE_CODE_REF
10438                || type->code () == TYPE_CODE_PTR)
10439               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
10440             {
10441               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
10442                                                         EVAL_NORMAL);
10443               type = value_type (ada_value_ind (arg1));
10444             }
10445           else
10446             {
10447               type = to_static_fixed_type
10448                 (ada_aligned_type
10449                  (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10450             }
10451           ada_ensure_varsize_limit (type);
10452           return value_zero (type, lval_memory);
10453         }
10454       else if (type->code () == TYPE_CODE_INT)
10455         {
10456           /* GDB allows dereferencing an int.  */
10457           if (expect_type == NULL)
10458             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10459                                lval_memory);
10460           else
10461             {
10462               expect_type =
10463                 to_static_fixed_type (ada_aligned_type (expect_type));
10464               return value_zero (expect_type, lval_memory);
10465             }
10466         }
10467       else
10468         error (_("Attempt to take contents of a non-pointer value."));
10469     }
10470   arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
10471   type = ada_check_typedef (value_type (arg1));
10472
10473   if (type->code () == TYPE_CODE_INT)
10474     /* GDB allows dereferencing an int.  If we were given
10475        the expect_type, then use that as the target type.
10476        Otherwise, assume that the target type is an int.  */
10477     {
10478       if (expect_type != NULL)
10479         return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10480                                           arg1));
10481       else
10482         return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10483                               (CORE_ADDR) value_as_address (arg1));
10484     }
10485
10486   struct type *target_type = (to_static_fixed_type
10487                               (ada_aligned_type
10488                                (ada_check_typedef (TYPE_TARGET_TYPE (type)))));
10489   ada_ensure_varsize_limit (target_type);
10490
10491   if (ada_is_array_descriptor_type (type))
10492     /* GDB allows dereferencing GNAT array descriptors.  */
10493     return ada_coerce_to_simple_array (arg1);
10494   else
10495     return ada_value_ind (arg1);
10496 }
10497
10498 value *
10499 ada_structop_operation::evaluate (struct type *expect_type,
10500                                   struct expression *exp,
10501                                   enum noside noside)
10502 {
10503   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10504   const char *str = std::get<1> (m_storage).c_str ();
10505   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10506     {
10507       struct type *type;
10508       struct type *type1 = value_type (arg1);
10509
10510       if (ada_is_tagged_type (type1, 1))
10511         {
10512           type = ada_lookup_struct_elt_type (type1, str, 1, 1);
10513
10514           /* If the field is not found, check if it exists in the
10515              extension of this object's type. This means that we
10516              need to evaluate completely the expression.  */
10517
10518           if (type == NULL)
10519             {
10520               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
10521                                                         EVAL_NORMAL);
10522               arg1 = ada_value_struct_elt (arg1, str, 0);
10523               arg1 = unwrap_value (arg1);
10524               type = value_type (ada_to_fixed_value (arg1));
10525             }
10526         }
10527       else
10528         type = ada_lookup_struct_elt_type (type1, str, 1, 0);
10529
10530       return value_zero (ada_aligned_type (type), lval_memory);
10531     }
10532   else
10533     {
10534       arg1 = ada_value_struct_elt (arg1, str, 0);
10535       arg1 = unwrap_value (arg1);
10536       return ada_to_fixed_value (arg1);
10537     }
10538 }
10539
10540 value *
10541 ada_funcall_operation::evaluate (struct type *expect_type,
10542                                  struct expression *exp,
10543                                  enum noside noside)
10544 {
10545   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
10546   int nargs = args_up.size ();
10547   std::vector<value *> argvec (nargs);
10548   operation_up &callee_op = std::get<0> (m_storage);
10549
10550   ada_var_value_operation *avv
10551     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
10552   if (avv != nullptr
10553       && SYMBOL_DOMAIN (avv->get_symbol ()) == UNDEF_DOMAIN)
10554     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10555            avv->get_symbol ()->print_name ());
10556
10557   value *callee = callee_op->evaluate (nullptr, exp, noside);
10558   for (int i = 0; i < args_up.size (); ++i)
10559     argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
10560
10561   if (ada_is_constrained_packed_array_type
10562       (desc_base_type (value_type (callee))))
10563     callee = ada_coerce_to_simple_array (callee);
10564   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
10565            && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
10566     /* This is a packed array that has already been fixed, and
10567        therefore already coerced to a simple array.  Nothing further
10568        to do.  */
10569     ;
10570   else if (value_type (callee)->code () == TYPE_CODE_REF)
10571     {
10572       /* Make sure we dereference references so that all the code below
10573          feels like it's really handling the referenced value.  Wrapping
10574          types (for alignment) may be there, so make sure we strip them as
10575          well.  */
10576       callee = ada_to_fixed_value (coerce_ref (callee));
10577     }
10578   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
10579            && VALUE_LVAL (callee) == lval_memory)
10580     callee = value_addr (callee);
10581
10582   struct type *type = ada_check_typedef (value_type (callee));
10583
10584   /* Ada allows us to implicitly dereference arrays when subscripting
10585      them.  So, if this is an array typedef (encoding use for array
10586      access types encoded as fat pointers), strip it now.  */
10587   if (type->code () == TYPE_CODE_TYPEDEF)
10588     type = ada_typedef_target_type (type);
10589
10590   if (type->code () == TYPE_CODE_PTR)
10591     {
10592       switch (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ())
10593         {
10594         case TYPE_CODE_FUNC:
10595           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10596           break;
10597         case TYPE_CODE_ARRAY:
10598           break;
10599         case TYPE_CODE_STRUCT:
10600           if (noside != EVAL_AVOID_SIDE_EFFECTS)
10601             callee = ada_value_ind (callee);
10602           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10603           break;
10604         default:
10605           error (_("cannot subscript or call something of type `%s'"),
10606                  ada_type_name (value_type (callee)));
10607           break;
10608         }
10609     }
10610
10611   switch (type->code ())
10612     {
10613     case TYPE_CODE_FUNC:
10614       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10615         {
10616           if (TYPE_TARGET_TYPE (type) == NULL)
10617             error_call_unknown_return_type (NULL);
10618           return allocate_value (TYPE_TARGET_TYPE (type));
10619         }
10620       return call_function_by_hand (callee, NULL, argvec);
10621     case TYPE_CODE_INTERNAL_FUNCTION:
10622       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10623         /* We don't know anything about what the internal
10624            function might return, but we have to return
10625            something.  */
10626         return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10627                            not_lval);
10628       else
10629         return call_internal_function (exp->gdbarch, exp->language_defn,
10630                                        callee, nargs,
10631                                        argvec.data ());
10632
10633     case TYPE_CODE_STRUCT:
10634       {
10635         int arity;
10636
10637         arity = ada_array_arity (type);
10638         type = ada_array_element_type (type, nargs);
10639         if (type == NULL)
10640           error (_("cannot subscript or call a record"));
10641         if (arity != nargs)
10642           error (_("wrong number of subscripts; expecting %d"), arity);
10643         if (noside == EVAL_AVOID_SIDE_EFFECTS)
10644           return value_zero (ada_aligned_type (type), lval_memory);
10645         return
10646           unwrap_value (ada_value_subscript
10647                         (callee, nargs, argvec.data ()));
10648       }
10649     case TYPE_CODE_ARRAY:
10650       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10651         {
10652           type = ada_array_element_type (type, nargs);
10653           if (type == NULL)
10654             error (_("element type of array unknown"));
10655           else
10656             return value_zero (ada_aligned_type (type), lval_memory);
10657         }
10658       return
10659         unwrap_value (ada_value_subscript
10660                       (ada_coerce_to_simple_array (callee),
10661                        nargs, argvec.data ()));
10662     case TYPE_CODE_PTR:     /* Pointer to array */
10663       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10664         {
10665           type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10666           type = ada_array_element_type (type, nargs);
10667           if (type == NULL)
10668             error (_("element type of array unknown"));
10669           else
10670             return value_zero (ada_aligned_type (type), lval_memory);
10671         }
10672       return
10673         unwrap_value (ada_value_ptr_subscript (callee, nargs,
10674                                                argvec.data ()));
10675
10676     default:
10677       error (_("Attempt to index or call something other than an "
10678                "array or function"));
10679     }
10680 }
10681
10682 bool
10683 ada_funcall_operation::resolve (struct expression *exp,
10684                                 bool deprocedure_p,
10685                                 bool parse_completion,
10686                                 innermost_block_tracker *tracker,
10687                                 struct type *context_type)
10688 {
10689   operation_up &callee_op = std::get<0> (m_storage);
10690
10691   ada_var_value_operation *avv
10692     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
10693   if (avv == nullptr)
10694     return false;
10695
10696   symbol *sym = avv->get_symbol ();
10697   if (SYMBOL_DOMAIN (sym) != UNDEF_DOMAIN)
10698     return false;
10699
10700   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
10701   int nargs = args_up.size ();
10702   std::vector<value *> argvec (nargs);
10703
10704   for (int i = 0; i < args_up.size (); ++i)
10705     argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
10706
10707   const block *block = avv->get_block ();
10708   block_symbol resolved
10709     = ada_resolve_funcall (sym, block,
10710                            context_type, parse_completion,
10711                            nargs, argvec.data (),
10712                            tracker);
10713
10714   std::get<0> (m_storage)
10715     = make_operation<ada_var_value_operation> (resolved);
10716   return false;
10717 }
10718
10719 bool
10720 ada_ternop_slice_operation::resolve (struct expression *exp,
10721                                      bool deprocedure_p,
10722                                      bool parse_completion,
10723                                      innermost_block_tracker *tracker,
10724                                      struct type *context_type)
10725 {
10726   /* Historically this check was done during resolution, so we
10727      continue that here.  */
10728   value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
10729                                                 EVAL_AVOID_SIDE_EFFECTS);
10730   if (ada_is_any_packed_array_type (value_type (v)))
10731     error (_("cannot slice a packed array"));
10732   return false;
10733 }
10734
10735 }
10736
10737 \f
10738
10739 /* Return non-zero iff TYPE represents a System.Address type.  */
10740
10741 int
10742 ada_is_system_address_type (struct type *type)
10743 {
10744   return (type->name () && strcmp (type->name (), "system__address") == 0);
10745 }
10746
10747 \f
10748
10749                                 /* Range types */
10750
10751 /* Scan STR beginning at position K for a discriminant name, and
10752    return the value of that discriminant field of DVAL in *PX.  If
10753    PNEW_K is not null, put the position of the character beyond the
10754    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
10755    not alter *PX and *PNEW_K if unsuccessful.  */
10756
10757 static int
10758 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
10759                     int *pnew_k)
10760 {
10761   static std::string storage;
10762   const char *pstart, *pend, *bound;
10763   struct value *bound_val;
10764
10765   if (dval == NULL || str == NULL || str[k] == '\0')
10766     return 0;
10767
10768   pstart = str + k;
10769   pend = strstr (pstart, "__");
10770   if (pend == NULL)
10771     {
10772       bound = pstart;
10773       k += strlen (bound);
10774     }
10775   else
10776     {
10777       int len = pend - pstart;
10778
10779       /* Strip __ and beyond.  */
10780       storage = std::string (pstart, len);
10781       bound = storage.c_str ();
10782       k = pend - str;
10783     }
10784
10785   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
10786   if (bound_val == NULL)
10787     return 0;
10788
10789   *px = value_as_long (bound_val);
10790   if (pnew_k != NULL)
10791     *pnew_k = k;
10792   return 1;
10793 }
10794
10795 /* Value of variable named NAME.  Only exact matches are considered.
10796    If no such variable found, then if ERR_MSG is null, returns 0, and
10797    otherwise causes an error with message ERR_MSG.  */
10798
10799 static struct value *
10800 get_var_value (const char *name, const char *err_msg)
10801 {
10802   std::string quoted_name = add_angle_brackets (name);
10803
10804   lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
10805
10806   std::vector<struct block_symbol> syms
10807     = ada_lookup_symbol_list_worker (lookup_name,
10808                                      get_selected_block (0),
10809                                      VAR_DOMAIN, 1);
10810
10811   if (syms.size () != 1)
10812     {
10813       if (err_msg == NULL)
10814         return 0;
10815       else
10816         error (("%s"), err_msg);
10817     }
10818
10819   return value_of_variable (syms[0].symbol, syms[0].block);
10820 }
10821
10822 /* Value of integer variable named NAME in the current environment.
10823    If no such variable is found, returns false.  Otherwise, sets VALUE
10824    to the variable's value and returns true.  */
10825
10826 bool
10827 get_int_var_value (const char *name, LONGEST &value)
10828 {
10829   struct value *var_val = get_var_value (name, 0);
10830
10831   if (var_val == 0)
10832     return false;
10833
10834   value = value_as_long (var_val);
10835   return true;
10836 }
10837
10838
10839 /* Return a range type whose base type is that of the range type named
10840    NAME in the current environment, and whose bounds are calculated
10841    from NAME according to the GNAT range encoding conventions.
10842    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
10843    corresponding range type from debug information; fall back to using it
10844    if symbol lookup fails.  If a new type must be created, allocate it
10845    like ORIG_TYPE was.  The bounds information, in general, is encoded
10846    in NAME, the base type given in the named range type.  */
10847
10848 static struct type *
10849 to_fixed_range_type (struct type *raw_type, struct value *dval)
10850 {
10851   const char *name;
10852   struct type *base_type;
10853   const char *subtype_info;
10854
10855   gdb_assert (raw_type != NULL);
10856   gdb_assert (raw_type->name () != NULL);
10857
10858   if (raw_type->code () == TYPE_CODE_RANGE)
10859     base_type = TYPE_TARGET_TYPE (raw_type);
10860   else
10861     base_type = raw_type;
10862
10863   name = raw_type->name ();
10864   subtype_info = strstr (name, "___XD");
10865   if (subtype_info == NULL)
10866     {
10867       LONGEST L = ada_discrete_type_low_bound (raw_type);
10868       LONGEST U = ada_discrete_type_high_bound (raw_type);
10869
10870       if (L < INT_MIN || U > INT_MAX)
10871         return raw_type;
10872       else
10873         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
10874                                          L, U);
10875     }
10876   else
10877     {
10878       int prefix_len = subtype_info - name;
10879       LONGEST L, U;
10880       struct type *type;
10881       const char *bounds_str;
10882       int n;
10883
10884       subtype_info += 5;
10885       bounds_str = strchr (subtype_info, '_');
10886       n = 1;
10887
10888       if (*subtype_info == 'L')
10889         {
10890           if (!ada_scan_number (bounds_str, n, &L, &n)
10891               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
10892             return raw_type;
10893           if (bounds_str[n] == '_')
10894             n += 2;
10895           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
10896             n += 1;
10897           subtype_info += 1;
10898         }
10899       else
10900         {
10901           std::string name_buf = std::string (name, prefix_len) + "___L";
10902           if (!get_int_var_value (name_buf.c_str (), L))
10903             {
10904               lim_warning (_("Unknown lower bound, using 1."));
10905               L = 1;
10906             }
10907         }
10908
10909       if (*subtype_info == 'U')
10910         {
10911           if (!ada_scan_number (bounds_str, n, &U, &n)
10912               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
10913             return raw_type;
10914         }
10915       else
10916         {
10917           std::string name_buf = std::string (name, prefix_len) + "___U";
10918           if (!get_int_var_value (name_buf.c_str (), U))
10919             {
10920               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
10921               U = L;
10922             }
10923         }
10924
10925       type = create_static_range_type (alloc_type_copy (raw_type),
10926                                        base_type, L, U);
10927       /* create_static_range_type alters the resulting type's length
10928          to match the size of the base_type, which is not what we want.
10929          Set it back to the original range type's length.  */
10930       TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
10931       type->set_name (name);
10932       return type;
10933     }
10934 }
10935
10936 /* True iff NAME is the name of a range type.  */
10937
10938 int
10939 ada_is_range_type_name (const char *name)
10940 {
10941   return (name != NULL && strstr (name, "___XD"));
10942 }
10943 \f
10944
10945                                 /* Modular types */
10946
10947 /* True iff TYPE is an Ada modular type.  */
10948
10949 int
10950 ada_is_modular_type (struct type *type)
10951 {
10952   struct type *subranged_type = get_base_type (type);
10953
10954   return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
10955           && subranged_type->code () == TYPE_CODE_INT
10956           && subranged_type->is_unsigned ());
10957 }
10958
10959 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
10960
10961 ULONGEST
10962 ada_modulus (struct type *type)
10963 {
10964   const dynamic_prop &high = type->bounds ()->high;
10965
10966   if (high.kind () == PROP_CONST)
10967     return (ULONGEST) high.const_val () + 1;
10968
10969   /* If TYPE is unresolved, the high bound might be a location list.  Return
10970      0, for lack of a better value to return.  */
10971   return 0;
10972 }
10973 \f
10974
10975 /* Ada exception catchpoint support:
10976    ---------------------------------
10977
10978    We support 3 kinds of exception catchpoints:
10979      . catchpoints on Ada exceptions
10980      . catchpoints on unhandled Ada exceptions
10981      . catchpoints on failed assertions
10982
10983    Exceptions raised during failed assertions, or unhandled exceptions
10984    could perfectly be caught with the general catchpoint on Ada exceptions.
10985    However, we can easily differentiate these two special cases, and having
10986    the option to distinguish these two cases from the rest can be useful
10987    to zero-in on certain situations.
10988
10989    Exception catchpoints are a specialized form of breakpoint,
10990    since they rely on inserting breakpoints inside known routines
10991    of the GNAT runtime.  The implementation therefore uses a standard
10992    breakpoint structure of the BP_BREAKPOINT type, but with its own set
10993    of breakpoint_ops.
10994
10995    Support in the runtime for exception catchpoints have been changed
10996    a few times already, and these changes affect the implementation
10997    of these catchpoints.  In order to be able to support several
10998    variants of the runtime, we use a sniffer that will determine
10999    the runtime variant used by the program being debugged.  */
11000
11001 /* Ada's standard exceptions.
11002
11003    The Ada 83 standard also defined Numeric_Error.  But there so many
11004    situations where it was unclear from the Ada 83 Reference Manual
11005    (RM) whether Constraint_Error or Numeric_Error should be raised,
11006    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11007    Interpretation saying that anytime the RM says that Numeric_Error
11008    should be raised, the implementation may raise Constraint_Error.
11009    Ada 95 went one step further and pretty much removed Numeric_Error
11010    from the list of standard exceptions (it made it a renaming of
11011    Constraint_Error, to help preserve compatibility when compiling
11012    an Ada83 compiler). As such, we do not include Numeric_Error from
11013    this list of standard exceptions.  */
11014
11015 static const char * const standard_exc[] = {
11016   "constraint_error",
11017   "program_error",
11018   "storage_error",
11019   "tasking_error"
11020 };
11021
11022 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11023
11024 /* A structure that describes how to support exception catchpoints
11025    for a given executable.  */
11026
11027 struct exception_support_info
11028 {
11029    /* The name of the symbol to break on in order to insert
11030       a catchpoint on exceptions.  */
11031    const char *catch_exception_sym;
11032
11033    /* The name of the symbol to break on in order to insert
11034       a catchpoint on unhandled exceptions.  */
11035    const char *catch_exception_unhandled_sym;
11036
11037    /* The name of the symbol to break on in order to insert
11038       a catchpoint on failed assertions.  */
11039    const char *catch_assert_sym;
11040
11041    /* The name of the symbol to break on in order to insert
11042       a catchpoint on exception handling.  */
11043    const char *catch_handlers_sym;
11044
11045    /* Assuming that the inferior just triggered an unhandled exception
11046       catchpoint, this function is responsible for returning the address
11047       in inferior memory where the name of that exception is stored.
11048       Return zero if the address could not be computed.  */
11049    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11050 };
11051
11052 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11053 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11054
11055 /* The following exception support info structure describes how to
11056    implement exception catchpoints with the latest version of the
11057    Ada runtime (as of 2019-08-??).  */
11058
11059 static const struct exception_support_info default_exception_support_info =
11060 {
11061   "__gnat_debug_raise_exception", /* catch_exception_sym */
11062   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11063   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11064   "__gnat_begin_handler_v1", /* catch_handlers_sym */
11065   ada_unhandled_exception_name_addr
11066 };
11067
11068 /* The following exception support info structure describes how to
11069    implement exception catchpoints with an earlier version of the
11070    Ada runtime (as of 2007-03-06) using v0 of the EH ABI.  */
11071
11072 static const struct exception_support_info exception_support_info_v0 =
11073 {
11074   "__gnat_debug_raise_exception", /* catch_exception_sym */
11075   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11076   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11077   "__gnat_begin_handler", /* catch_handlers_sym */
11078   ada_unhandled_exception_name_addr
11079 };
11080
11081 /* The following exception support info structure describes how to
11082    implement exception catchpoints with a slightly older version
11083    of the Ada runtime.  */
11084
11085 static const struct exception_support_info exception_support_info_fallback =
11086 {
11087   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11088   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11089   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
11090   "__gnat_begin_handler", /* catch_handlers_sym */
11091   ada_unhandled_exception_name_addr_from_raise
11092 };
11093
11094 /* Return nonzero if we can detect the exception support routines
11095    described in EINFO.
11096
11097    This function errors out if an abnormal situation is detected
11098    (for instance, if we find the exception support routines, but
11099    that support is found to be incomplete).  */
11100
11101 static int
11102 ada_has_this_exception_support (const struct exception_support_info *einfo)
11103 {
11104   struct symbol *sym;
11105
11106   /* The symbol we're looking up is provided by a unit in the GNAT runtime
11107      that should be compiled with debugging information.  As a result, we
11108      expect to find that symbol in the symtabs.  */
11109
11110   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11111   if (sym == NULL)
11112     {
11113       /* Perhaps we did not find our symbol because the Ada runtime was
11114          compiled without debugging info, or simply stripped of it.
11115          It happens on some GNU/Linux distributions for instance, where
11116          users have to install a separate debug package in order to get
11117          the runtime's debugging info.  In that situation, let the user
11118          know why we cannot insert an Ada exception catchpoint.
11119
11120          Note: Just for the purpose of inserting our Ada exception
11121          catchpoint, we could rely purely on the associated minimal symbol.
11122          But we would be operating in degraded mode anyway, since we are
11123          still lacking the debugging info needed later on to extract
11124          the name of the exception being raised (this name is printed in
11125          the catchpoint message, and is also used when trying to catch
11126          a specific exception).  We do not handle this case for now.  */
11127       struct bound_minimal_symbol msym
11128         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11129
11130       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11131         error (_("Your Ada runtime appears to be missing some debugging "
11132                  "information.\nCannot insert Ada exception catchpoint "
11133                  "in this configuration."));
11134
11135       return 0;
11136     }
11137
11138   /* Make sure that the symbol we found corresponds to a function.  */
11139
11140   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11141     {
11142       error (_("Symbol \"%s\" is not a function (class = %d)"),
11143              sym->linkage_name (), SYMBOL_CLASS (sym));
11144       return 0;
11145     }
11146
11147   sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11148   if (sym == NULL)
11149     {
11150       struct bound_minimal_symbol msym
11151         = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11152
11153       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11154         error (_("Your Ada runtime appears to be missing some debugging "
11155                  "information.\nCannot insert Ada exception catchpoint "
11156                  "in this configuration."));
11157
11158       return 0;
11159     }
11160
11161   /* Make sure that the symbol we found corresponds to a function.  */
11162
11163   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11164     {
11165       error (_("Symbol \"%s\" is not a function (class = %d)"),
11166              sym->linkage_name (), SYMBOL_CLASS (sym));
11167       return 0;
11168     }
11169
11170   return 1;
11171 }
11172
11173 /* Inspect the Ada runtime and determine which exception info structure
11174    should be used to provide support for exception catchpoints.
11175
11176    This function will always set the per-inferior exception_info,
11177    or raise an error.  */
11178
11179 static void
11180 ada_exception_support_info_sniffer (void)
11181 {
11182   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11183
11184   /* If the exception info is already known, then no need to recompute it.  */
11185   if (data->exception_info != NULL)
11186     return;
11187
11188   /* Check the latest (default) exception support info.  */
11189   if (ada_has_this_exception_support (&default_exception_support_info))
11190     {
11191       data->exception_info = &default_exception_support_info;
11192       return;
11193     }
11194
11195   /* Try the v0 exception suport info.  */
11196   if (ada_has_this_exception_support (&exception_support_info_v0))
11197     {
11198       data->exception_info = &exception_support_info_v0;
11199       return;
11200     }
11201
11202   /* Try our fallback exception suport info.  */
11203   if (ada_has_this_exception_support (&exception_support_info_fallback))
11204     {
11205       data->exception_info = &exception_support_info_fallback;
11206       return;
11207     }
11208
11209   /* Sometimes, it is normal for us to not be able to find the routine
11210      we are looking for.  This happens when the program is linked with
11211      the shared version of the GNAT runtime, and the program has not been
11212      started yet.  Inform the user of these two possible causes if
11213      applicable.  */
11214
11215   if (ada_update_initial_language (language_unknown) != language_ada)
11216     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
11217
11218   /* If the symbol does not exist, then check that the program is
11219      already started, to make sure that shared libraries have been
11220      loaded.  If it is not started, this may mean that the symbol is
11221      in a shared library.  */
11222
11223   if (inferior_ptid.pid () == 0)
11224     error (_("Unable to insert catchpoint. Try to start the program first."));
11225
11226   /* At this point, we know that we are debugging an Ada program and
11227      that the inferior has been started, but we still are not able to
11228      find the run-time symbols.  That can mean that we are in
11229      configurable run time mode, or that a-except as been optimized
11230      out by the linker...  In any case, at this point it is not worth
11231      supporting this feature.  */
11232
11233   error (_("Cannot insert Ada exception catchpoints in this configuration."));
11234 }
11235
11236 /* True iff FRAME is very likely to be that of a function that is
11237    part of the runtime system.  This is all very heuristic, but is
11238    intended to be used as advice as to what frames are uninteresting
11239    to most users.  */
11240
11241 static int
11242 is_known_support_routine (struct frame_info *frame)
11243 {
11244   enum language func_lang;
11245   int i;
11246   const char *fullname;
11247
11248   /* If this code does not have any debugging information (no symtab),
11249      This cannot be any user code.  */
11250
11251   symtab_and_line sal = find_frame_sal (frame);
11252   if (sal.symtab == NULL)
11253     return 1;
11254
11255   /* If there is a symtab, but the associated source file cannot be
11256      located, then assume this is not user code:  Selecting a frame
11257      for which we cannot display the code would not be very helpful
11258      for the user.  This should also take care of case such as VxWorks
11259      where the kernel has some debugging info provided for a few units.  */
11260
11261   fullname = symtab_to_fullname (sal.symtab);
11262   if (access (fullname, R_OK) != 0)
11263     return 1;
11264
11265   /* Check the unit filename against the Ada runtime file naming.
11266      We also check the name of the objfile against the name of some
11267      known system libraries that sometimes come with debugging info
11268      too.  */
11269
11270   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11271     {
11272       re_comp (known_runtime_file_name_patterns[i]);
11273       if (re_exec (lbasename (sal.symtab->filename)))
11274         return 1;
11275       if (SYMTAB_OBJFILE (sal.symtab) != NULL
11276           && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
11277         return 1;
11278     }
11279
11280   /* Check whether the function is a GNAT-generated entity.  */
11281
11282   gdb::unique_xmalloc_ptr<char> func_name
11283     = find_frame_funname (frame, &func_lang, NULL);
11284   if (func_name == NULL)
11285     return 1;
11286
11287   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11288     {
11289       re_comp (known_auxiliary_function_name_patterns[i]);
11290       if (re_exec (func_name.get ()))
11291         return 1;
11292     }
11293
11294   return 0;
11295 }
11296
11297 /* Find the first frame that contains debugging information and that is not
11298    part of the Ada run-time, starting from FI and moving upward.  */
11299
11300 void
11301 ada_find_printable_frame (struct frame_info *fi)
11302 {
11303   for (; fi != NULL; fi = get_prev_frame (fi))
11304     {
11305       if (!is_known_support_routine (fi))
11306         {
11307           select_frame (fi);
11308           break;
11309         }
11310     }
11311
11312 }
11313
11314 /* Assuming that the inferior just triggered an unhandled exception
11315    catchpoint, return the address in inferior memory where the name
11316    of the exception is stored.
11317    
11318    Return zero if the address could not be computed.  */
11319
11320 static CORE_ADDR
11321 ada_unhandled_exception_name_addr (void)
11322 {
11323   return parse_and_eval_address ("e.full_name");
11324 }
11325
11326 /* Same as ada_unhandled_exception_name_addr, except that this function
11327    should be used when the inferior uses an older version of the runtime,
11328    where the exception name needs to be extracted from a specific frame
11329    several frames up in the callstack.  */
11330
11331 static CORE_ADDR
11332 ada_unhandled_exception_name_addr_from_raise (void)
11333 {
11334   int frame_level;
11335   struct frame_info *fi;
11336   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11337
11338   /* To determine the name of this exception, we need to select
11339      the frame corresponding to RAISE_SYM_NAME.  This frame is
11340      at least 3 levels up, so we simply skip the first 3 frames
11341      without checking the name of their associated function.  */
11342   fi = get_current_frame ();
11343   for (frame_level = 0; frame_level < 3; frame_level += 1)
11344     if (fi != NULL)
11345       fi = get_prev_frame (fi); 
11346
11347   while (fi != NULL)
11348     {
11349       enum language func_lang;
11350
11351       gdb::unique_xmalloc_ptr<char> func_name
11352         = find_frame_funname (fi, &func_lang, NULL);
11353       if (func_name != NULL)
11354         {
11355           if (strcmp (func_name.get (),
11356                       data->exception_info->catch_exception_sym) == 0)
11357             break; /* We found the frame we were looking for...  */
11358         }
11359       fi = get_prev_frame (fi);
11360     }
11361
11362   if (fi == NULL)
11363     return 0;
11364
11365   select_frame (fi);
11366   return parse_and_eval_address ("id.full_name");
11367 }
11368
11369 /* Assuming the inferior just triggered an Ada exception catchpoint
11370    (of any type), return the address in inferior memory where the name
11371    of the exception is stored, if applicable.
11372
11373    Assumes the selected frame is the current frame.
11374
11375    Return zero if the address could not be computed, or if not relevant.  */
11376
11377 static CORE_ADDR
11378 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
11379                            struct breakpoint *b)
11380 {
11381   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11382
11383   switch (ex)
11384     {
11385       case ada_catch_exception:
11386         return (parse_and_eval_address ("e.full_name"));
11387         break;
11388
11389       case ada_catch_exception_unhandled:
11390         return data->exception_info->unhandled_exception_name_addr ();
11391         break;
11392
11393       case ada_catch_handlers:
11394         return 0;  /* The runtimes does not provide access to the exception
11395                       name.  */
11396         break;
11397
11398       case ada_catch_assert:
11399         return 0;  /* Exception name is not relevant in this case.  */
11400         break;
11401
11402       default:
11403         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11404         break;
11405     }
11406
11407   return 0; /* Should never be reached.  */
11408 }
11409
11410 /* Assuming the inferior is stopped at an exception catchpoint,
11411    return the message which was associated to the exception, if
11412    available.  Return NULL if the message could not be retrieved.
11413
11414    Note: The exception message can be associated to an exception
11415    either through the use of the Raise_Exception function, or
11416    more simply (Ada 2005 and later), via:
11417
11418        raise Exception_Name with "exception message";
11419
11420    */
11421
11422 static gdb::unique_xmalloc_ptr<char>
11423 ada_exception_message_1 (void)
11424 {
11425   struct value *e_msg_val;
11426   int e_msg_len;
11427
11428   /* For runtimes that support this feature, the exception message
11429      is passed as an unbounded string argument called "message".  */
11430   e_msg_val = parse_and_eval ("message");
11431   if (e_msg_val == NULL)
11432     return NULL; /* Exception message not supported.  */
11433
11434   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
11435   gdb_assert (e_msg_val != NULL);
11436   e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
11437
11438   /* If the message string is empty, then treat it as if there was
11439      no exception message.  */
11440   if (e_msg_len <= 0)
11441     return NULL;
11442
11443   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
11444   read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
11445                e_msg_len);
11446   e_msg.get ()[e_msg_len] = '\0';
11447
11448   return e_msg;
11449 }
11450
11451 /* Same as ada_exception_message_1, except that all exceptions are
11452    contained here (returning NULL instead).  */
11453
11454 static gdb::unique_xmalloc_ptr<char>
11455 ada_exception_message (void)
11456 {
11457   gdb::unique_xmalloc_ptr<char> e_msg;
11458
11459   try
11460     {
11461       e_msg = ada_exception_message_1 ();
11462     }
11463   catch (const gdb_exception_error &e)
11464     {
11465       e_msg.reset (nullptr);
11466     }
11467
11468   return e_msg;
11469 }
11470
11471 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11472    any error that ada_exception_name_addr_1 might cause to be thrown.
11473    When an error is intercepted, a warning with the error message is printed,
11474    and zero is returned.  */
11475
11476 static CORE_ADDR
11477 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
11478                          struct breakpoint *b)
11479 {
11480   CORE_ADDR result = 0;
11481
11482   try
11483     {
11484       result = ada_exception_name_addr_1 (ex, b);
11485     }
11486
11487   catch (const gdb_exception_error &e)
11488     {
11489       warning (_("failed to get exception name: %s"), e.what ());
11490       return 0;
11491     }
11492
11493   return result;
11494 }
11495
11496 static std::string ada_exception_catchpoint_cond_string
11497   (const char *excep_string,
11498    enum ada_exception_catchpoint_kind ex);
11499
11500 /* Ada catchpoints.
11501
11502    In the case of catchpoints on Ada exceptions, the catchpoint will
11503    stop the target on every exception the program throws.  When a user
11504    specifies the name of a specific exception, we translate this
11505    request into a condition expression (in text form), and then parse
11506    it into an expression stored in each of the catchpoint's locations.
11507    We then use this condition to check whether the exception that was
11508    raised is the one the user is interested in.  If not, then the
11509    target is resumed again.  We store the name of the requested
11510    exception, in order to be able to re-set the condition expression
11511    when symbols change.  */
11512
11513 /* An instance of this type is used to represent an Ada catchpoint
11514    breakpoint location.  */
11515
11516 class ada_catchpoint_location : public bp_location
11517 {
11518 public:
11519   ada_catchpoint_location (breakpoint *owner)
11520     : bp_location (owner, bp_loc_software_breakpoint)
11521   {}
11522
11523   /* The condition that checks whether the exception that was raised
11524      is the specific exception the user specified on catchpoint
11525      creation.  */
11526   expression_up excep_cond_expr;
11527 };
11528
11529 /* An instance of this type is used to represent an Ada catchpoint.  */
11530
11531 struct ada_catchpoint : public breakpoint
11532 {
11533   explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind)
11534     : m_kind (kind)
11535   {
11536   }
11537
11538   /* The name of the specific exception the user specified.  */
11539   std::string excep_string;
11540
11541   /* What kind of catchpoint this is.  */
11542   enum ada_exception_catchpoint_kind m_kind;
11543 };
11544
11545 /* Parse the exception condition string in the context of each of the
11546    catchpoint's locations, and store them for later evaluation.  */
11547
11548 static void
11549 create_excep_cond_exprs (struct ada_catchpoint *c,
11550                          enum ada_exception_catchpoint_kind ex)
11551 {
11552   struct bp_location *bl;
11553
11554   /* Nothing to do if there's no specific exception to catch.  */
11555   if (c->excep_string.empty ())
11556     return;
11557
11558   /* Same if there are no locations... */
11559   if (c->loc == NULL)
11560     return;
11561
11562   /* Compute the condition expression in text form, from the specific
11563      expection we want to catch.  */
11564   std::string cond_string
11565     = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
11566
11567   /* Iterate over all the catchpoint's locations, and parse an
11568      expression for each.  */
11569   for (bl = c->loc; bl != NULL; bl = bl->next)
11570     {
11571       struct ada_catchpoint_location *ada_loc
11572         = (struct ada_catchpoint_location *) bl;
11573       expression_up exp;
11574
11575       if (!bl->shlib_disabled)
11576         {
11577           const char *s;
11578
11579           s = cond_string.c_str ();
11580           try
11581             {
11582               exp = parse_exp_1 (&s, bl->address,
11583                                  block_for_pc (bl->address),
11584                                  0);
11585             }
11586           catch (const gdb_exception_error &e)
11587             {
11588               warning (_("failed to reevaluate internal exception condition "
11589                          "for catchpoint %d: %s"),
11590                        c->number, e.what ());
11591             }
11592         }
11593
11594       ada_loc->excep_cond_expr = std::move (exp);
11595     }
11596 }
11597
11598 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11599    structure for all exception catchpoint kinds.  */
11600
11601 static struct bp_location *
11602 allocate_location_exception (struct breakpoint *self)
11603 {
11604   return new ada_catchpoint_location (self);
11605 }
11606
11607 /* Implement the RE_SET method in the breakpoint_ops structure for all
11608    exception catchpoint kinds.  */
11609
11610 static void
11611 re_set_exception (struct breakpoint *b)
11612 {
11613   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11614
11615   /* Call the base class's method.  This updates the catchpoint's
11616      locations.  */
11617   bkpt_breakpoint_ops.re_set (b);
11618
11619   /* Reparse the exception conditional expressions.  One for each
11620      location.  */
11621   create_excep_cond_exprs (c, c->m_kind);
11622 }
11623
11624 /* Returns true if we should stop for this breakpoint hit.  If the
11625    user specified a specific exception, we only want to cause a stop
11626    if the program thrown that exception.  */
11627
11628 static int
11629 should_stop_exception (const struct bp_location *bl)
11630 {
11631   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11632   const struct ada_catchpoint_location *ada_loc
11633     = (const struct ada_catchpoint_location *) bl;
11634   int stop;
11635
11636   struct internalvar *var = lookup_internalvar ("_ada_exception");
11637   if (c->m_kind == ada_catch_assert)
11638     clear_internalvar (var);
11639   else
11640     {
11641       try
11642         {
11643           const char *expr;
11644
11645           if (c->m_kind == ada_catch_handlers)
11646             expr = ("GNAT_GCC_exception_Access(gcc_exception)"
11647                     ".all.occurrence.id");
11648           else
11649             expr = "e";
11650
11651           struct value *exc = parse_and_eval (expr);
11652           set_internalvar (var, exc);
11653         }
11654       catch (const gdb_exception_error &ex)
11655         {
11656           clear_internalvar (var);
11657         }
11658     }
11659
11660   /* With no specific exception, should always stop.  */
11661   if (c->excep_string.empty ())
11662     return 1;
11663
11664   if (ada_loc->excep_cond_expr == NULL)
11665     {
11666       /* We will have a NULL expression if back when we were creating
11667          the expressions, this location's had failed to parse.  */
11668       return 1;
11669     }
11670
11671   stop = 1;
11672   try
11673     {
11674       struct value *mark;
11675
11676       mark = value_mark ();
11677       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
11678       value_free_to_mark (mark);
11679     }
11680   catch (const gdb_exception &ex)
11681     {
11682       exception_fprintf (gdb_stderr, ex,
11683                          _("Error in testing exception condition:\n"));
11684     }
11685
11686   return stop;
11687 }
11688
11689 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
11690    for all exception catchpoint kinds.  */
11691
11692 static void
11693 check_status_exception (bpstat bs)
11694 {
11695   bs->stop = should_stop_exception (bs->bp_location_at.get ());
11696 }
11697
11698 /* Implement the PRINT_IT method in the breakpoint_ops structure
11699    for all exception catchpoint kinds.  */
11700
11701 static enum print_stop_action
11702 print_it_exception (bpstat bs)
11703 {
11704   struct ui_out *uiout = current_uiout;
11705   struct breakpoint *b = bs->breakpoint_at;
11706
11707   annotate_catchpoint (b->number);
11708
11709   if (uiout->is_mi_like_p ())
11710     {
11711       uiout->field_string ("reason",
11712                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11713       uiout->field_string ("disp", bpdisp_text (b->disposition));
11714     }
11715
11716   uiout->text (b->disposition == disp_del
11717                ? "\nTemporary catchpoint " : "\nCatchpoint ");
11718   uiout->field_signed ("bkptno", b->number);
11719   uiout->text (", ");
11720
11721   /* ada_exception_name_addr relies on the selected frame being the
11722      current frame.  Need to do this here because this function may be
11723      called more than once when printing a stop, and below, we'll
11724      select the first frame past the Ada run-time (see
11725      ada_find_printable_frame).  */
11726   select_frame (get_current_frame ());
11727
11728   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11729   switch (c->m_kind)
11730     {
11731       case ada_catch_exception:
11732       case ada_catch_exception_unhandled:
11733       case ada_catch_handlers:
11734         {
11735           const CORE_ADDR addr = ada_exception_name_addr (c->m_kind, b);
11736           char exception_name[256];
11737
11738           if (addr != 0)
11739             {
11740               read_memory (addr, (gdb_byte *) exception_name,
11741                            sizeof (exception_name) - 1);
11742               exception_name [sizeof (exception_name) - 1] = '\0';
11743             }
11744           else
11745             {
11746               /* For some reason, we were unable to read the exception
11747                  name.  This could happen if the Runtime was compiled
11748                  without debugging info, for instance.  In that case,
11749                  just replace the exception name by the generic string
11750                  "exception" - it will read as "an exception" in the
11751                  notification we are about to print.  */
11752               memcpy (exception_name, "exception", sizeof ("exception"));
11753             }
11754           /* In the case of unhandled exception breakpoints, we print
11755              the exception name as "unhandled EXCEPTION_NAME", to make
11756              it clearer to the user which kind of catchpoint just got
11757              hit.  We used ui_out_text to make sure that this extra
11758              info does not pollute the exception name in the MI case.  */
11759           if (c->m_kind == ada_catch_exception_unhandled)
11760             uiout->text ("unhandled ");
11761           uiout->field_string ("exception-name", exception_name);
11762         }
11763         break;
11764       case ada_catch_assert:
11765         /* In this case, the name of the exception is not really
11766            important.  Just print "failed assertion" to make it clearer
11767            that his program just hit an assertion-failure catchpoint.
11768            We used ui_out_text because this info does not belong in
11769            the MI output.  */
11770         uiout->text ("failed assertion");
11771         break;
11772     }
11773
11774   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
11775   if (exception_message != NULL)
11776     {
11777       uiout->text (" (");
11778       uiout->field_string ("exception-message", exception_message.get ());
11779       uiout->text (")");
11780     }
11781
11782   uiout->text (" at ");
11783   ada_find_printable_frame (get_current_frame ());
11784
11785   return PRINT_SRC_AND_LOC;
11786 }
11787
11788 /* Implement the PRINT_ONE method in the breakpoint_ops structure
11789    for all exception catchpoint kinds.  */
11790
11791 static void
11792 print_one_exception (struct breakpoint *b, struct bp_location **last_loc)
11793
11794   struct ui_out *uiout = current_uiout;
11795   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11796   struct value_print_options opts;
11797
11798   get_user_print_options (&opts);
11799
11800   if (opts.addressprint)
11801     uiout->field_skip ("addr");
11802
11803   annotate_field (5);
11804   switch (c->m_kind)
11805     {
11806       case ada_catch_exception:
11807         if (!c->excep_string.empty ())
11808           {
11809             std::string msg = string_printf (_("`%s' Ada exception"),
11810                                              c->excep_string.c_str ());
11811
11812             uiout->field_string ("what", msg);
11813           }
11814         else
11815           uiout->field_string ("what", "all Ada exceptions");
11816         
11817         break;
11818
11819       case ada_catch_exception_unhandled:
11820         uiout->field_string ("what", "unhandled Ada exceptions");
11821         break;
11822       
11823       case ada_catch_handlers:
11824         if (!c->excep_string.empty ())
11825           {
11826             uiout->field_fmt ("what",
11827                               _("`%s' Ada exception handlers"),
11828                               c->excep_string.c_str ());
11829           }
11830         else
11831           uiout->field_string ("what", "all Ada exceptions handlers");
11832         break;
11833
11834       case ada_catch_assert:
11835         uiout->field_string ("what", "failed Ada assertions");
11836         break;
11837
11838       default:
11839         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11840         break;
11841     }
11842 }
11843
11844 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
11845    for all exception catchpoint kinds.  */
11846
11847 static void
11848 print_mention_exception (struct breakpoint *b)
11849 {
11850   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11851   struct ui_out *uiout = current_uiout;
11852
11853   uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
11854                                                  : _("Catchpoint "));
11855   uiout->field_signed ("bkptno", b->number);
11856   uiout->text (": ");
11857
11858   switch (c->m_kind)
11859     {
11860       case ada_catch_exception:
11861         if (!c->excep_string.empty ())
11862           {
11863             std::string info = string_printf (_("`%s' Ada exception"),
11864                                               c->excep_string.c_str ());
11865             uiout->text (info.c_str ());
11866           }
11867         else
11868           uiout->text (_("all Ada exceptions"));
11869         break;
11870
11871       case ada_catch_exception_unhandled:
11872         uiout->text (_("unhandled Ada exceptions"));
11873         break;
11874
11875       case ada_catch_handlers:
11876         if (!c->excep_string.empty ())
11877           {
11878             std::string info
11879               = string_printf (_("`%s' Ada exception handlers"),
11880                                c->excep_string.c_str ());
11881             uiout->text (info.c_str ());
11882           }
11883         else
11884           uiout->text (_("all Ada exceptions handlers"));
11885         break;
11886
11887       case ada_catch_assert:
11888         uiout->text (_("failed Ada assertions"));
11889         break;
11890
11891       default:
11892         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11893         break;
11894     }
11895 }
11896
11897 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
11898    for all exception catchpoint kinds.  */
11899
11900 static void
11901 print_recreate_exception (struct breakpoint *b, struct ui_file *fp)
11902 {
11903   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11904
11905   switch (c->m_kind)
11906     {
11907       case ada_catch_exception:
11908         fprintf_filtered (fp, "catch exception");
11909         if (!c->excep_string.empty ())
11910           fprintf_filtered (fp, " %s", c->excep_string.c_str ());
11911         break;
11912
11913       case ada_catch_exception_unhandled:
11914         fprintf_filtered (fp, "catch exception unhandled");
11915         break;
11916
11917       case ada_catch_handlers:
11918         fprintf_filtered (fp, "catch handlers");
11919         break;
11920
11921       case ada_catch_assert:
11922         fprintf_filtered (fp, "catch assert");
11923         break;
11924
11925       default:
11926         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11927     }
11928   print_recreate_thread (b, fp);
11929 }
11930
11931 /* Virtual tables for various breakpoint types.  */
11932 static struct breakpoint_ops catch_exception_breakpoint_ops;
11933 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
11934 static struct breakpoint_ops catch_assert_breakpoint_ops;
11935 static struct breakpoint_ops catch_handlers_breakpoint_ops;
11936
11937 /* See ada-lang.h.  */
11938
11939 bool
11940 is_ada_exception_catchpoint (breakpoint *bp)
11941 {
11942   return (bp->ops == &catch_exception_breakpoint_ops
11943           || bp->ops == &catch_exception_unhandled_breakpoint_ops
11944           || bp->ops == &catch_assert_breakpoint_ops
11945           || bp->ops == &catch_handlers_breakpoint_ops);
11946 }
11947
11948 /* Split the arguments specified in a "catch exception" command.  
11949    Set EX to the appropriate catchpoint type.
11950    Set EXCEP_STRING to the name of the specific exception if
11951    specified by the user.
11952    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
11953    "catch handlers" command.  False otherwise.
11954    If a condition is found at the end of the arguments, the condition
11955    expression is stored in COND_STRING (memory must be deallocated
11956    after use).  Otherwise COND_STRING is set to NULL.  */
11957
11958 static void
11959 catch_ada_exception_command_split (const char *args,
11960                                    bool is_catch_handlers_cmd,
11961                                    enum ada_exception_catchpoint_kind *ex,
11962                                    std::string *excep_string,
11963                                    std::string *cond_string)
11964 {
11965   std::string exception_name;
11966
11967   exception_name = extract_arg (&args);
11968   if (exception_name == "if")
11969     {
11970       /* This is not an exception name; this is the start of a condition
11971          expression for a catchpoint on all exceptions.  So, "un-get"
11972          this token, and set exception_name to NULL.  */
11973       exception_name.clear ();
11974       args -= 2;
11975     }
11976
11977   /* Check to see if we have a condition.  */
11978
11979   args = skip_spaces (args);
11980   if (startswith (args, "if")
11981       && (isspace (args[2]) || args[2] == '\0'))
11982     {
11983       args += 2;
11984       args = skip_spaces (args);
11985
11986       if (args[0] == '\0')
11987         error (_("Condition missing after `if' keyword"));
11988       *cond_string = args;
11989
11990       args += strlen (args);
11991     }
11992
11993   /* Check that we do not have any more arguments.  Anything else
11994      is unexpected.  */
11995
11996   if (args[0] != '\0')
11997     error (_("Junk at end of expression"));
11998
11999   if (is_catch_handlers_cmd)
12000     {
12001       /* Catch handling of exceptions.  */
12002       *ex = ada_catch_handlers;
12003       *excep_string = exception_name;
12004     }
12005   else if (exception_name.empty ())
12006     {
12007       /* Catch all exceptions.  */
12008       *ex = ada_catch_exception;
12009       excep_string->clear ();
12010     }
12011   else if (exception_name == "unhandled")
12012     {
12013       /* Catch unhandled exceptions.  */
12014       *ex = ada_catch_exception_unhandled;
12015       excep_string->clear ();
12016     }
12017   else
12018     {
12019       /* Catch a specific exception.  */
12020       *ex = ada_catch_exception;
12021       *excep_string = exception_name;
12022     }
12023 }
12024
12025 /* Return the name of the symbol on which we should break in order to
12026    implement a catchpoint of the EX kind.  */
12027
12028 static const char *
12029 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12030 {
12031   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12032
12033   gdb_assert (data->exception_info != NULL);
12034
12035   switch (ex)
12036     {
12037       case ada_catch_exception:
12038         return (data->exception_info->catch_exception_sym);
12039         break;
12040       case ada_catch_exception_unhandled:
12041         return (data->exception_info->catch_exception_unhandled_sym);
12042         break;
12043       case ada_catch_assert:
12044         return (data->exception_info->catch_assert_sym);
12045         break;
12046       case ada_catch_handlers:
12047         return (data->exception_info->catch_handlers_sym);
12048         break;
12049       default:
12050         internal_error (__FILE__, __LINE__,
12051                         _("unexpected catchpoint kind (%d)"), ex);
12052     }
12053 }
12054
12055 /* Return the breakpoint ops "virtual table" used for catchpoints
12056    of the EX kind.  */
12057
12058 static const struct breakpoint_ops *
12059 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
12060 {
12061   switch (ex)
12062     {
12063       case ada_catch_exception:
12064         return (&catch_exception_breakpoint_ops);
12065         break;
12066       case ada_catch_exception_unhandled:
12067         return (&catch_exception_unhandled_breakpoint_ops);
12068         break;
12069       case ada_catch_assert:
12070         return (&catch_assert_breakpoint_ops);
12071         break;
12072       case ada_catch_handlers:
12073         return (&catch_handlers_breakpoint_ops);
12074         break;
12075       default:
12076         internal_error (__FILE__, __LINE__,
12077                         _("unexpected catchpoint kind (%d)"), ex);
12078     }
12079 }
12080
12081 /* Return the condition that will be used to match the current exception
12082    being raised with the exception that the user wants to catch.  This
12083    assumes that this condition is used when the inferior just triggered
12084    an exception catchpoint.
12085    EX: the type of catchpoints used for catching Ada exceptions.  */
12086
12087 static std::string
12088 ada_exception_catchpoint_cond_string (const char *excep_string,
12089                                       enum ada_exception_catchpoint_kind ex)
12090 {
12091   int i;
12092   bool is_standard_exc = false;
12093   std::string result;
12094
12095   if (ex == ada_catch_handlers)
12096     {
12097       /* For exception handlers catchpoints, the condition string does
12098          not use the same parameter as for the other exceptions.  */
12099       result = ("long_integer (GNAT_GCC_exception_Access"
12100                 "(gcc_exception).all.occurrence.id)");
12101     }
12102   else
12103     result = "long_integer (e)";
12104
12105   /* The standard exceptions are a special case.  They are defined in
12106      runtime units that have been compiled without debugging info; if
12107      EXCEP_STRING is the not-fully-qualified name of a standard
12108      exception (e.g. "constraint_error") then, during the evaluation
12109      of the condition expression, the symbol lookup on this name would
12110      *not* return this standard exception.  The catchpoint condition
12111      may then be set only on user-defined exceptions which have the
12112      same not-fully-qualified name (e.g. my_package.constraint_error).
12113
12114      To avoid this unexcepted behavior, these standard exceptions are
12115      systematically prefixed by "standard".  This means that "catch
12116      exception constraint_error" is rewritten into "catch exception
12117      standard.constraint_error".
12118
12119      If an exception named constraint_error is defined in another package of
12120      the inferior program, then the only way to specify this exception as a
12121      breakpoint condition is to use its fully-qualified named:
12122      e.g. my_package.constraint_error.  */
12123
12124   for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12125     {
12126       if (strcmp (standard_exc [i], excep_string) == 0)
12127         {
12128           is_standard_exc = true;
12129           break;
12130         }
12131     }
12132
12133   result += " = ";
12134
12135   if (is_standard_exc)
12136     string_appendf (result, "long_integer (&standard.%s)", excep_string);
12137   else
12138     string_appendf (result, "long_integer (&%s)", excep_string);
12139
12140   return result;
12141 }
12142
12143 /* Return the symtab_and_line that should be used to insert an exception
12144    catchpoint of the TYPE kind.
12145
12146    ADDR_STRING returns the name of the function where the real
12147    breakpoint that implements the catchpoints is set, depending on the
12148    type of catchpoint we need to create.  */
12149
12150 static struct symtab_and_line
12151 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12152                    std::string *addr_string, const struct breakpoint_ops **ops)
12153 {
12154   const char *sym_name;
12155   struct symbol *sym;
12156
12157   /* First, find out which exception support info to use.  */
12158   ada_exception_support_info_sniffer ();
12159
12160   /* Then lookup the function on which we will break in order to catch
12161      the Ada exceptions requested by the user.  */
12162   sym_name = ada_exception_sym_name (ex);
12163   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12164
12165   if (sym == NULL)
12166     error (_("Catchpoint symbol not found: %s"), sym_name);
12167
12168   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12169     error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12170
12171   /* Set ADDR_STRING.  */
12172   *addr_string = sym_name;
12173
12174   /* Set OPS.  */
12175   *ops = ada_exception_breakpoint_ops (ex);
12176
12177   return find_function_start_sal (sym, 1);
12178 }
12179
12180 /* Create an Ada exception catchpoint.
12181
12182    EX_KIND is the kind of exception catchpoint to be created.
12183
12184    If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12185    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
12186    of the exception to which this catchpoint applies.
12187
12188    COND_STRING, if not empty, is the catchpoint condition.
12189
12190    TEMPFLAG, if nonzero, means that the underlying breakpoint
12191    should be temporary.
12192
12193    FROM_TTY is the usual argument passed to all commands implementations.  */
12194
12195 void
12196 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12197                                  enum ada_exception_catchpoint_kind ex_kind,
12198                                  const std::string &excep_string,
12199                                  const std::string &cond_string,
12200                                  int tempflag,
12201                                  int disabled,
12202                                  int from_tty)
12203 {
12204   std::string addr_string;
12205   const struct breakpoint_ops *ops = NULL;
12206   struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
12207
12208   std::unique_ptr<ada_catchpoint> c (new ada_catchpoint (ex_kind));
12209   init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
12210                                  ops, tempflag, disabled, from_tty);
12211   c->excep_string = excep_string;
12212   create_excep_cond_exprs (c.get (), ex_kind);
12213   if (!cond_string.empty ())
12214     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12215   install_breakpoint (0, std::move (c), 1);
12216 }
12217
12218 /* Implement the "catch exception" command.  */
12219
12220 static void
12221 catch_ada_exception_command (const char *arg_entry, int from_tty,
12222                              struct cmd_list_element *command)
12223 {
12224   const char *arg = arg_entry;
12225   struct gdbarch *gdbarch = get_current_arch ();
12226   int tempflag;
12227   enum ada_exception_catchpoint_kind ex_kind;
12228   std::string excep_string;
12229   std::string cond_string;
12230
12231   tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12232
12233   if (!arg)
12234     arg = "";
12235   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12236                                      &cond_string);
12237   create_ada_exception_catchpoint (gdbarch, ex_kind,
12238                                    excep_string, cond_string,
12239                                    tempflag, 1 /* enabled */,
12240                                    from_tty);
12241 }
12242
12243 /* Implement the "catch handlers" command.  */
12244
12245 static void
12246 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12247                             struct cmd_list_element *command)
12248 {
12249   const char *arg = arg_entry;
12250   struct gdbarch *gdbarch = get_current_arch ();
12251   int tempflag;
12252   enum ada_exception_catchpoint_kind ex_kind;
12253   std::string excep_string;
12254   std::string cond_string;
12255
12256   tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12257
12258   if (!arg)
12259     arg = "";
12260   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12261                                      &cond_string);
12262   create_ada_exception_catchpoint (gdbarch, ex_kind,
12263                                    excep_string, cond_string,
12264                                    tempflag, 1 /* enabled */,
12265                                    from_tty);
12266 }
12267
12268 /* Completion function for the Ada "catch" commands.  */
12269
12270 static void
12271 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12272                      const char *text, const char *word)
12273 {
12274   std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12275
12276   for (const ada_exc_info &info : exceptions)
12277     {
12278       if (startswith (info.name, word))
12279         tracker.add_completion (make_unique_xstrdup (info.name));
12280     }
12281 }
12282
12283 /* Split the arguments specified in a "catch assert" command.
12284
12285    ARGS contains the command's arguments (or the empty string if
12286    no arguments were passed).
12287
12288    If ARGS contains a condition, set COND_STRING to that condition
12289    (the memory needs to be deallocated after use).  */
12290
12291 static void
12292 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12293 {
12294   args = skip_spaces (args);
12295
12296   /* Check whether a condition was provided.  */
12297   if (startswith (args, "if")
12298       && (isspace (args[2]) || args[2] == '\0'))
12299     {
12300       args += 2;
12301       args = skip_spaces (args);
12302       if (args[0] == '\0')
12303         error (_("condition missing after `if' keyword"));
12304       cond_string.assign (args);
12305     }
12306
12307   /* Otherwise, there should be no other argument at the end of
12308      the command.  */
12309   else if (args[0] != '\0')
12310     error (_("Junk at end of arguments."));
12311 }
12312
12313 /* Implement the "catch assert" command.  */
12314
12315 static void
12316 catch_assert_command (const char *arg_entry, int from_tty,
12317                       struct cmd_list_element *command)
12318 {
12319   const char *arg = arg_entry;
12320   struct gdbarch *gdbarch = get_current_arch ();
12321   int tempflag;
12322   std::string cond_string;
12323
12324   tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12325
12326   if (!arg)
12327     arg = "";
12328   catch_ada_assert_command_split (arg, cond_string);
12329   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12330                                    "", cond_string,
12331                                    tempflag, 1 /* enabled */,
12332                                    from_tty);
12333 }
12334
12335 /* Return non-zero if the symbol SYM is an Ada exception object.  */
12336
12337 static int
12338 ada_is_exception_sym (struct symbol *sym)
12339 {
12340   const char *type_name = SYMBOL_TYPE (sym)->name ();
12341
12342   return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12343           && SYMBOL_CLASS (sym) != LOC_BLOCK
12344           && SYMBOL_CLASS (sym) != LOC_CONST
12345           && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12346           && type_name != NULL && strcmp (type_name, "exception") == 0);
12347 }
12348
12349 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12350    Ada exception object.  This matches all exceptions except the ones
12351    defined by the Ada language.  */
12352
12353 static int
12354 ada_is_non_standard_exception_sym (struct symbol *sym)
12355 {
12356   int i;
12357
12358   if (!ada_is_exception_sym (sym))
12359     return 0;
12360
12361   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12362     if (strcmp (sym->linkage_name (), standard_exc[i]) == 0)
12363       return 0;  /* A standard exception.  */
12364
12365   /* Numeric_Error is also a standard exception, so exclude it.
12366      See the STANDARD_EXC description for more details as to why
12367      this exception is not listed in that array.  */
12368   if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12369     return 0;
12370
12371   return 1;
12372 }
12373
12374 /* A helper function for std::sort, comparing two struct ada_exc_info
12375    objects.
12376
12377    The comparison is determined first by exception name, and then
12378    by exception address.  */
12379
12380 bool
12381 ada_exc_info::operator< (const ada_exc_info &other) const
12382 {
12383   int result;
12384
12385   result = strcmp (name, other.name);
12386   if (result < 0)
12387     return true;
12388   if (result == 0 && addr < other.addr)
12389     return true;
12390   return false;
12391 }
12392
12393 bool
12394 ada_exc_info::operator== (const ada_exc_info &other) const
12395 {
12396   return addr == other.addr && strcmp (name, other.name) == 0;
12397 }
12398
12399 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12400    routine, but keeping the first SKIP elements untouched.
12401
12402    All duplicates are also removed.  */
12403
12404 static void
12405 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
12406                                       int skip)
12407 {
12408   std::sort (exceptions->begin () + skip, exceptions->end ());
12409   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
12410                      exceptions->end ());
12411 }
12412
12413 /* Add all exceptions defined by the Ada standard whose name match
12414    a regular expression.
12415
12416    If PREG is not NULL, then this regexp_t object is used to
12417    perform the symbol name matching.  Otherwise, no name-based
12418    filtering is performed.
12419
12420    EXCEPTIONS is a vector of exceptions to which matching exceptions
12421    gets pushed.  */
12422
12423 static void
12424 ada_add_standard_exceptions (compiled_regex *preg,
12425                              std::vector<ada_exc_info> *exceptions)
12426 {
12427   int i;
12428
12429   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12430     {
12431       if (preg == NULL
12432           || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
12433         {
12434           struct bound_minimal_symbol msymbol
12435             = ada_lookup_simple_minsym (standard_exc[i]);
12436
12437           if (msymbol.minsym != NULL)
12438             {
12439               struct ada_exc_info info
12440                 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
12441
12442               exceptions->push_back (info);
12443             }
12444         }
12445     }
12446 }
12447
12448 /* Add all Ada exceptions defined locally and accessible from the given
12449    FRAME.
12450
12451    If PREG is not NULL, then this regexp_t object is used to
12452    perform the symbol name matching.  Otherwise, no name-based
12453    filtering is performed.
12454
12455    EXCEPTIONS is a vector of exceptions to which matching exceptions
12456    gets pushed.  */
12457
12458 static void
12459 ada_add_exceptions_from_frame (compiled_regex *preg,
12460                                struct frame_info *frame,
12461                                std::vector<ada_exc_info> *exceptions)
12462 {
12463   const struct block *block = get_frame_block (frame, 0);
12464
12465   while (block != 0)
12466     {
12467       struct block_iterator iter;
12468       struct symbol *sym;
12469
12470       ALL_BLOCK_SYMBOLS (block, iter, sym)
12471         {
12472           switch (SYMBOL_CLASS (sym))
12473             {
12474             case LOC_TYPEDEF:
12475             case LOC_BLOCK:
12476             case LOC_CONST:
12477               break;
12478             default:
12479               if (ada_is_exception_sym (sym))
12480                 {
12481                   struct ada_exc_info info = {sym->print_name (),
12482                                               SYMBOL_VALUE_ADDRESS (sym)};
12483
12484                   exceptions->push_back (info);
12485                 }
12486             }
12487         }
12488       if (BLOCK_FUNCTION (block) != NULL)
12489         break;
12490       block = BLOCK_SUPERBLOCK (block);
12491     }
12492 }
12493
12494 /* Return true if NAME matches PREG or if PREG is NULL.  */
12495
12496 static bool
12497 name_matches_regex (const char *name, compiled_regex *preg)
12498 {
12499   return (preg == NULL
12500           || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
12501 }
12502
12503 /* Add all exceptions defined globally whose name name match
12504    a regular expression, excluding standard exceptions.
12505
12506    The reason we exclude standard exceptions is that they need
12507    to be handled separately: Standard exceptions are defined inside
12508    a runtime unit which is normally not compiled with debugging info,
12509    and thus usually do not show up in our symbol search.  However,
12510    if the unit was in fact built with debugging info, we need to
12511    exclude them because they would duplicate the entry we found
12512    during the special loop that specifically searches for those
12513    standard exceptions.
12514
12515    If PREG is not NULL, then this regexp_t object is used to
12516    perform the symbol name matching.  Otherwise, no name-based
12517    filtering is performed.
12518
12519    EXCEPTIONS is a vector of exceptions to which matching exceptions
12520    gets pushed.  */
12521
12522 static void
12523 ada_add_global_exceptions (compiled_regex *preg,
12524                            std::vector<ada_exc_info> *exceptions)
12525 {
12526   /* In Ada, the symbol "search name" is a linkage name, whereas the
12527      regular expression used to do the matching refers to the natural
12528      name.  So match against the decoded name.  */
12529   expand_symtabs_matching (NULL,
12530                            lookup_name_info::match_any (),
12531                            [&] (const char *search_name)
12532                            {
12533                              std::string decoded = ada_decode (search_name);
12534                              return name_matches_regex (decoded.c_str (), preg);
12535                            },
12536                            NULL,
12537                            SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
12538                            VARIABLES_DOMAIN);
12539
12540   for (objfile *objfile : current_program_space->objfiles ())
12541     {
12542       for (compunit_symtab *s : objfile->compunits ())
12543         {
12544           const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
12545           int i;
12546
12547           for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
12548             {
12549               const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
12550               struct block_iterator iter;
12551               struct symbol *sym;
12552
12553               ALL_BLOCK_SYMBOLS (b, iter, sym)
12554                 if (ada_is_non_standard_exception_sym (sym)
12555                     && name_matches_regex (sym->natural_name (), preg))
12556                   {
12557                     struct ada_exc_info info
12558                       = {sym->print_name (), SYMBOL_VALUE_ADDRESS (sym)};
12559
12560                     exceptions->push_back (info);
12561                   }
12562             }
12563         }
12564     }
12565 }
12566
12567 /* Implements ada_exceptions_list with the regular expression passed
12568    as a regex_t, rather than a string.
12569
12570    If not NULL, PREG is used to filter out exceptions whose names
12571    do not match.  Otherwise, all exceptions are listed.  */
12572
12573 static std::vector<ada_exc_info>
12574 ada_exceptions_list_1 (compiled_regex *preg)
12575 {
12576   std::vector<ada_exc_info> result;
12577   int prev_len;
12578
12579   /* First, list the known standard exceptions.  These exceptions
12580      need to be handled separately, as they are usually defined in
12581      runtime units that have been compiled without debugging info.  */
12582
12583   ada_add_standard_exceptions (preg, &result);
12584
12585   /* Next, find all exceptions whose scope is local and accessible
12586      from the currently selected frame.  */
12587
12588   if (has_stack_frames ())
12589     {
12590       prev_len = result.size ();
12591       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
12592                                      &result);
12593       if (result.size () > prev_len)
12594         sort_remove_dups_ada_exceptions_list (&result, prev_len);
12595     }
12596
12597   /* Add all exceptions whose scope is global.  */
12598
12599   prev_len = result.size ();
12600   ada_add_global_exceptions (preg, &result);
12601   if (result.size () > prev_len)
12602     sort_remove_dups_ada_exceptions_list (&result, prev_len);
12603
12604   return result;
12605 }
12606
12607 /* Return a vector of ada_exc_info.
12608
12609    If REGEXP is NULL, all exceptions are included in the result.
12610    Otherwise, it should contain a valid regular expression,
12611    and only the exceptions whose names match that regular expression
12612    are included in the result.
12613
12614    The exceptions are sorted in the following order:
12615      - Standard exceptions (defined by the Ada language), in
12616        alphabetical order;
12617      - Exceptions only visible from the current frame, in
12618        alphabetical order;
12619      - Exceptions whose scope is global, in alphabetical order.  */
12620
12621 std::vector<ada_exc_info>
12622 ada_exceptions_list (const char *regexp)
12623 {
12624   if (regexp == NULL)
12625     return ada_exceptions_list_1 (NULL);
12626
12627   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
12628   return ada_exceptions_list_1 (&reg);
12629 }
12630
12631 /* Implement the "info exceptions" command.  */
12632
12633 static void
12634 info_exceptions_command (const char *regexp, int from_tty)
12635 {
12636   struct gdbarch *gdbarch = get_current_arch ();
12637
12638   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
12639
12640   if (regexp != NULL)
12641     printf_filtered
12642       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
12643   else
12644     printf_filtered (_("All defined Ada exceptions:\n"));
12645
12646   for (const ada_exc_info &info : exceptions)
12647     printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
12648 }
12649
12650 \f
12651                                 /* Language vector */
12652
12653 /* symbol_name_matcher_ftype adapter for wild_match.  */
12654
12655 static bool
12656 do_wild_match (const char *symbol_search_name,
12657                const lookup_name_info &lookup_name,
12658                completion_match_result *comp_match_res)
12659 {
12660   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
12661 }
12662
12663 /* symbol_name_matcher_ftype adapter for full_match.  */
12664
12665 static bool
12666 do_full_match (const char *symbol_search_name,
12667                const lookup_name_info &lookup_name,
12668                completion_match_result *comp_match_res)
12669 {
12670   const char *lname = lookup_name.ada ().lookup_name ().c_str ();
12671
12672   /* If both symbols start with "_ada_", just let the loop below
12673      handle the comparison.  However, if only the symbol name starts
12674      with "_ada_", skip the prefix and let the match proceed as
12675      usual.  */
12676   if (startswith (symbol_search_name, "_ada_")
12677       && !startswith (lname, "_ada"))
12678     symbol_search_name += 5;
12679
12680   int uscore_count = 0;
12681   while (*lname != '\0')
12682     {
12683       if (*symbol_search_name != *lname)
12684         {
12685           if (*symbol_search_name == 'B' && uscore_count == 2
12686               && symbol_search_name[1] == '_')
12687             {
12688               symbol_search_name += 2;
12689               while (isdigit (*symbol_search_name))
12690                 ++symbol_search_name;
12691               if (symbol_search_name[0] == '_'
12692                   && symbol_search_name[1] == '_')
12693                 {
12694                   symbol_search_name += 2;
12695                   continue;
12696                 }
12697             }
12698           return false;
12699         }
12700
12701       if (*symbol_search_name == '_')
12702         ++uscore_count;
12703       else
12704         uscore_count = 0;
12705
12706       ++symbol_search_name;
12707       ++lname;
12708     }
12709
12710   return is_name_suffix (symbol_search_name);
12711 }
12712
12713 /* symbol_name_matcher_ftype for exact (verbatim) matches.  */
12714
12715 static bool
12716 do_exact_match (const char *symbol_search_name,
12717                 const lookup_name_info &lookup_name,
12718                 completion_match_result *comp_match_res)
12719 {
12720   return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
12721 }
12722
12723 /* Build the Ada lookup name for LOOKUP_NAME.  */
12724
12725 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
12726 {
12727   gdb::string_view user_name = lookup_name.name ();
12728
12729   if (!user_name.empty () && user_name[0] == '<')
12730     {
12731       if (user_name.back () == '>')
12732         m_encoded_name
12733           = gdb::to_string (user_name.substr (1, user_name.size () - 2));
12734       else
12735         m_encoded_name
12736           = gdb::to_string (user_name.substr (1, user_name.size () - 1));
12737       m_encoded_p = true;
12738       m_verbatim_p = true;
12739       m_wild_match_p = false;
12740       m_standard_p = false;
12741     }
12742   else
12743     {
12744       m_verbatim_p = false;
12745
12746       m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
12747
12748       if (!m_encoded_p)
12749         {
12750           const char *folded = ada_fold_name (user_name);
12751           m_encoded_name = ada_encode_1 (folded, false);
12752           if (m_encoded_name.empty ())
12753             m_encoded_name = gdb::to_string (user_name);
12754         }
12755       else
12756         m_encoded_name = gdb::to_string (user_name);
12757
12758       /* Handle the 'package Standard' special case.  See description
12759          of m_standard_p.  */
12760       if (startswith (m_encoded_name.c_str (), "standard__"))
12761         {
12762           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
12763           m_standard_p = true;
12764         }
12765       else
12766         m_standard_p = false;
12767
12768       /* If the name contains a ".", then the user is entering a fully
12769          qualified entity name, and the match must not be done in wild
12770          mode.  Similarly, if the user wants to complete what looks
12771          like an encoded name, the match must not be done in wild
12772          mode.  Also, in the standard__ special case always do
12773          non-wild matching.  */
12774       m_wild_match_p
12775         = (lookup_name.match_type () != symbol_name_match_type::FULL
12776            && !m_encoded_p
12777            && !m_standard_p
12778            && user_name.find ('.') == std::string::npos);
12779     }
12780 }
12781
12782 /* symbol_name_matcher_ftype method for Ada.  This only handles
12783    completion mode.  */
12784
12785 static bool
12786 ada_symbol_name_matches (const char *symbol_search_name,
12787                          const lookup_name_info &lookup_name,
12788                          completion_match_result *comp_match_res)
12789 {
12790   return lookup_name.ada ().matches (symbol_search_name,
12791                                      lookup_name.match_type (),
12792                                      comp_match_res);
12793 }
12794
12795 /* A name matcher that matches the symbol name exactly, with
12796    strcmp.  */
12797
12798 static bool
12799 literal_symbol_name_matcher (const char *symbol_search_name,
12800                              const lookup_name_info &lookup_name,
12801                              completion_match_result *comp_match_res)
12802 {
12803   gdb::string_view name_view = lookup_name.name ();
12804
12805   if (lookup_name.completion_mode ()
12806       ? (strncmp (symbol_search_name, name_view.data (),
12807                   name_view.size ()) == 0)
12808       : symbol_search_name == name_view)
12809     {
12810       if (comp_match_res != NULL)
12811         comp_match_res->set_match (symbol_search_name);
12812       return true;
12813     }
12814   else
12815     return false;
12816 }
12817
12818 /* Implement the "get_symbol_name_matcher" language_defn method for
12819    Ada.  */
12820
12821 static symbol_name_matcher_ftype *
12822 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
12823 {
12824   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
12825     return literal_symbol_name_matcher;
12826
12827   if (lookup_name.completion_mode ())
12828     return ada_symbol_name_matches;
12829   else
12830     {
12831       if (lookup_name.ada ().wild_match_p ())
12832         return do_wild_match;
12833       else if (lookup_name.ada ().verbatim_p ())
12834         return do_exact_match;
12835       else
12836         return do_full_match;
12837     }
12838 }
12839
12840 /* Class representing the Ada language.  */
12841
12842 class ada_language : public language_defn
12843 {
12844 public:
12845   ada_language ()
12846     : language_defn (language_ada)
12847   { /* Nothing.  */ }
12848
12849   /* See language.h.  */
12850
12851   const char *name () const override
12852   { return "ada"; }
12853
12854   /* See language.h.  */
12855
12856   const char *natural_name () const override
12857   { return "Ada"; }
12858
12859   /* See language.h.  */
12860
12861   const std::vector<const char *> &filename_extensions () const override
12862   {
12863     static const std::vector<const char *> extensions
12864       = { ".adb", ".ads", ".a", ".ada", ".dg" };
12865     return extensions;
12866   }
12867
12868   /* Print an array element index using the Ada syntax.  */
12869
12870   void print_array_index (struct type *index_type,
12871                           LONGEST index,
12872                           struct ui_file *stream,
12873                           const value_print_options *options) const override
12874   {
12875     struct value *index_value = val_atr (index_type, index);
12876
12877     value_print (index_value, stream, options);
12878     fprintf_filtered (stream, " => ");
12879   }
12880
12881   /* Implement the "read_var_value" language_defn method for Ada.  */
12882
12883   struct value *read_var_value (struct symbol *var,
12884                                 const struct block *var_block,
12885                                 struct frame_info *frame) const override
12886   {
12887     /* The only case where default_read_var_value is not sufficient
12888        is when VAR is a renaming...  */
12889     if (frame != nullptr)
12890       {
12891         const struct block *frame_block = get_frame_block (frame, NULL);
12892         if (frame_block != nullptr && ada_is_renaming_symbol (var))
12893           return ada_read_renaming_var_value (var, frame_block);
12894       }
12895
12896     /* This is a typical case where we expect the default_read_var_value
12897        function to work.  */
12898     return language_defn::read_var_value (var, var_block, frame);
12899   }
12900
12901   /* See language.h.  */
12902   void language_arch_info (struct gdbarch *gdbarch,
12903                            struct language_arch_info *lai) const override
12904   {
12905     const struct builtin_type *builtin = builtin_type (gdbarch);
12906
12907     /* Helper function to allow shorter lines below.  */
12908     auto add = [&] (struct type *t)
12909     {
12910       lai->add_primitive_type (t);
12911     };
12912
12913     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12914                             0, "integer"));
12915     add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
12916                             0, "long_integer"));
12917     add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
12918                             0, "short_integer"));
12919     struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
12920                                                   0, "character");
12921     lai->set_string_char_type (char_type);
12922     add (char_type);
12923     add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
12924                           "float", gdbarch_float_format (gdbarch)));
12925     add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
12926                           "long_float", gdbarch_double_format (gdbarch)));
12927     add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
12928                             0, "long_long_integer"));
12929     add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
12930                           "long_long_float",
12931                           gdbarch_long_double_format (gdbarch)));
12932     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12933                             0, "natural"));
12934     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
12935                             0, "positive"));
12936     add (builtin->builtin_void);
12937
12938     struct type *system_addr_ptr
12939       = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
12940                                         "void"));
12941     system_addr_ptr->set_name ("system__address");
12942     add (system_addr_ptr);
12943
12944     /* Create the equivalent of the System.Storage_Elements.Storage_Offset
12945        type.  This is a signed integral type whose size is the same as
12946        the size of addresses.  */
12947     unsigned int addr_length = TYPE_LENGTH (system_addr_ptr);
12948     add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
12949                             "storage_offset"));
12950
12951     lai->set_bool_type (builtin->builtin_bool);
12952   }
12953
12954   /* See language.h.  */
12955
12956   bool iterate_over_symbols
12957         (const struct block *block, const lookup_name_info &name,
12958          domain_enum domain,
12959          gdb::function_view<symbol_found_callback_ftype> callback) const override
12960   {
12961     std::vector<struct block_symbol> results
12962       = ada_lookup_symbol_list_worker (name, block, domain, 0);
12963     for (block_symbol &sym : results)
12964       {
12965         if (!callback (&sym))
12966           return false;
12967       }
12968
12969     return true;
12970   }
12971
12972   /* See language.h.  */
12973   bool sniff_from_mangled_name (const char *mangled,
12974                                 char **out) const override
12975   {
12976     std::string demangled = ada_decode (mangled);
12977
12978     *out = NULL;
12979
12980     if (demangled != mangled && demangled[0] != '<')
12981       {
12982         /* Set the gsymbol language to Ada, but still return 0.
12983            Two reasons for that:
12984
12985            1. For Ada, we prefer computing the symbol's decoded name
12986            on the fly rather than pre-compute it, in order to save
12987            memory (Ada projects are typically very large).
12988
12989            2. There are some areas in the definition of the GNAT
12990            encoding where, with a bit of bad luck, we might be able
12991            to decode a non-Ada symbol, generating an incorrect
12992            demangled name (Eg: names ending with "TB" for instance
12993            are identified as task bodies and so stripped from
12994            the decoded name returned).
12995
12996            Returning true, here, but not setting *DEMANGLED, helps us get
12997            a little bit of the best of both worlds.  Because we're last,
12998            we should not affect any of the other languages that were
12999            able to demangle the symbol before us; we get to correctly
13000            tag Ada symbols as such; and even if we incorrectly tagged a
13001            non-Ada symbol, which should be rare, any routing through the
13002            Ada language should be transparent (Ada tries to behave much
13003            like C/C++ with non-Ada symbols).  */
13004         return true;
13005       }
13006
13007     return false;
13008   }
13009
13010   /* See language.h.  */
13011
13012   char *demangle_symbol (const char *mangled, int options) const override
13013   {
13014     return ada_la_decode (mangled, options);
13015   }
13016
13017   /* See language.h.  */
13018
13019   void print_type (struct type *type, const char *varstring,
13020                    struct ui_file *stream, int show, int level,
13021                    const struct type_print_options *flags) const override
13022   {
13023     ada_print_type (type, varstring, stream, show, level, flags);
13024   }
13025
13026   /* See language.h.  */
13027
13028   const char *word_break_characters (void) const override
13029   {
13030     return ada_completer_word_break_characters;
13031   }
13032
13033   /* See language.h.  */
13034
13035   void collect_symbol_completion_matches (completion_tracker &tracker,
13036                                           complete_symbol_mode mode,
13037                                           symbol_name_match_type name_match_type,
13038                                           const char *text, const char *word,
13039                                           enum type_code code) const override
13040   {
13041     struct symbol *sym;
13042     const struct block *b, *surrounding_static_block = 0;
13043     struct block_iterator iter;
13044
13045     gdb_assert (code == TYPE_CODE_UNDEF);
13046
13047     lookup_name_info lookup_name (text, name_match_type, true);
13048
13049     /* First, look at the partial symtab symbols.  */
13050     expand_symtabs_matching (NULL,
13051                              lookup_name,
13052                              NULL,
13053                              NULL,
13054                              SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13055                              ALL_DOMAIN);
13056
13057     /* At this point scan through the misc symbol vectors and add each
13058        symbol you find to the list.  Eventually we want to ignore
13059        anything that isn't a text symbol (everything else will be
13060        handled by the psymtab code above).  */
13061
13062     for (objfile *objfile : current_program_space->objfiles ())
13063       {
13064         for (minimal_symbol *msymbol : objfile->msymbols ())
13065           {
13066             QUIT;
13067
13068             if (completion_skip_symbol (mode, msymbol))
13069               continue;
13070
13071             language symbol_language = msymbol->language ();
13072
13073             /* Ada minimal symbols won't have their language set to Ada.  If
13074                we let completion_list_add_name compare using the
13075                default/C-like matcher, then when completing e.g., symbols in a
13076                package named "pck", we'd match internal Ada symbols like
13077                "pckS", which are invalid in an Ada expression, unless you wrap
13078                them in '<' '>' to request a verbatim match.
13079
13080                Unfortunately, some Ada encoded names successfully demangle as
13081                C++ symbols (using an old mangling scheme), such as "name__2Xn"
13082                -> "Xn::name(void)" and thus some Ada minimal symbols end up
13083                with the wrong language set.  Paper over that issue here.  */
13084             if (symbol_language == language_auto
13085                 || symbol_language == language_cplus)
13086               symbol_language = language_ada;
13087
13088             completion_list_add_name (tracker,
13089                                       symbol_language,
13090                                       msymbol->linkage_name (),
13091                                       lookup_name, text, word);
13092           }
13093       }
13094
13095     /* Search upwards from currently selected frame (so that we can
13096        complete on local vars.  */
13097
13098     for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
13099       {
13100         if (!BLOCK_SUPERBLOCK (b))
13101           surrounding_static_block = b;   /* For elmin of dups */
13102
13103         ALL_BLOCK_SYMBOLS (b, iter, sym)
13104           {
13105             if (completion_skip_symbol (mode, sym))
13106               continue;
13107
13108             completion_list_add_name (tracker,
13109                                       sym->language (),
13110                                       sym->linkage_name (),
13111                                       lookup_name, text, word);
13112           }
13113       }
13114
13115     /* Go through the symtabs and check the externs and statics for
13116        symbols which match.  */
13117
13118     for (objfile *objfile : current_program_space->objfiles ())
13119       {
13120         for (compunit_symtab *s : objfile->compunits ())
13121           {
13122             QUIT;
13123             b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
13124             ALL_BLOCK_SYMBOLS (b, iter, sym)
13125               {
13126                 if (completion_skip_symbol (mode, sym))
13127                   continue;
13128
13129                 completion_list_add_name (tracker,
13130                                           sym->language (),
13131                                           sym->linkage_name (),
13132                                           lookup_name, text, word);
13133               }
13134           }
13135       }
13136
13137     for (objfile *objfile : current_program_space->objfiles ())
13138       {
13139         for (compunit_symtab *s : objfile->compunits ())
13140           {
13141             QUIT;
13142             b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
13143             /* Don't do this block twice.  */
13144             if (b == surrounding_static_block)
13145               continue;
13146             ALL_BLOCK_SYMBOLS (b, iter, sym)
13147               {
13148                 if (completion_skip_symbol (mode, sym))
13149                   continue;
13150
13151                 completion_list_add_name (tracker,
13152                                           sym->language (),
13153                                           sym->linkage_name (),
13154                                           lookup_name, text, word);
13155               }
13156           }
13157       }
13158   }
13159
13160   /* See language.h.  */
13161
13162   gdb::unique_xmalloc_ptr<char> watch_location_expression
13163         (struct type *type, CORE_ADDR addr) const override
13164   {
13165     type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
13166     std::string name = type_to_string (type);
13167     return gdb::unique_xmalloc_ptr<char>
13168       (xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr)));
13169   }
13170
13171   /* See language.h.  */
13172
13173   void value_print (struct value *val, struct ui_file *stream,
13174                     const struct value_print_options *options) const override
13175   {
13176     return ada_value_print (val, stream, options);
13177   }
13178
13179   /* See language.h.  */
13180
13181   void value_print_inner
13182         (struct value *val, struct ui_file *stream, int recurse,
13183          const struct value_print_options *options) const override
13184   {
13185     return ada_value_print_inner (val, stream, recurse, options);
13186   }
13187
13188   /* See language.h.  */
13189
13190   struct block_symbol lookup_symbol_nonlocal
13191         (const char *name, const struct block *block,
13192          const domain_enum domain) const override
13193   {
13194     struct block_symbol sym;
13195
13196     sym = ada_lookup_symbol (name, block_static_block (block), domain);
13197     if (sym.symbol != NULL)
13198       return sym;
13199
13200     /* If we haven't found a match at this point, try the primitive
13201        types.  In other languages, this search is performed before
13202        searching for global symbols in order to short-circuit that
13203        global-symbol search if it happens that the name corresponds
13204        to a primitive type.  But we cannot do the same in Ada, because
13205        it is perfectly legitimate for a program to declare a type which
13206        has the same name as a standard type.  If looking up a type in
13207        that situation, we have traditionally ignored the primitive type
13208        in favor of user-defined types.  This is why, unlike most other
13209        languages, we search the primitive types this late and only after
13210        having searched the global symbols without success.  */
13211
13212     if (domain == VAR_DOMAIN)
13213       {
13214         struct gdbarch *gdbarch;
13215
13216         if (block == NULL)
13217           gdbarch = target_gdbarch ();
13218         else
13219           gdbarch = block_gdbarch (block);
13220         sym.symbol
13221           = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13222         if (sym.symbol != NULL)
13223           return sym;
13224       }
13225
13226     return {};
13227   }
13228
13229   /* See language.h.  */
13230
13231   int parser (struct parser_state *ps) const override
13232   {
13233     warnings_issued = 0;
13234     return ada_parse (ps);
13235   }
13236
13237   /* See language.h.  */
13238
13239   void emitchar (int ch, struct type *chtype,
13240                  struct ui_file *stream, int quoter) const override
13241   {
13242     ada_emit_char (ch, chtype, stream, quoter, 1);
13243   }
13244
13245   /* See language.h.  */
13246
13247   void printchar (int ch, struct type *chtype,
13248                   struct ui_file *stream) const override
13249   {
13250     ada_printchar (ch, chtype, stream);
13251   }
13252
13253   /* See language.h.  */
13254
13255   void printstr (struct ui_file *stream, struct type *elttype,
13256                  const gdb_byte *string, unsigned int length,
13257                  const char *encoding, int force_ellipses,
13258                  const struct value_print_options *options) const override
13259   {
13260     ada_printstr (stream, elttype, string, length, encoding,
13261                   force_ellipses, options);
13262   }
13263
13264   /* See language.h.  */
13265
13266   void print_typedef (struct type *type, struct symbol *new_symbol,
13267                       struct ui_file *stream) const override
13268   {
13269     ada_print_typedef (type, new_symbol, stream);
13270   }
13271
13272   /* See language.h.  */
13273
13274   bool is_string_type_p (struct type *type) const override
13275   {
13276     return ada_is_string_type (type);
13277   }
13278
13279   /* See language.h.  */
13280
13281   const char *struct_too_deep_ellipsis () const override
13282   { return "(...)"; }
13283
13284   /* See language.h.  */
13285
13286   bool c_style_arrays_p () const override
13287   { return false; }
13288
13289   /* See language.h.  */
13290
13291   bool store_sym_names_in_linkage_form_p () const override
13292   { return true; }
13293
13294   /* See language.h.  */
13295
13296   const struct lang_varobj_ops *varobj_ops () const override
13297   { return &ada_varobj_ops; }
13298
13299 protected:
13300   /* See language.h.  */
13301
13302   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13303         (const lookup_name_info &lookup_name) const override
13304   {
13305     return ada_get_symbol_name_matcher (lookup_name);
13306   }
13307 };
13308
13309 /* Single instance of the Ada language class.  */
13310
13311 static ada_language ada_language_defn;
13312
13313 /* Command-list for the "set/show ada" prefix command.  */
13314 static struct cmd_list_element *set_ada_list;
13315 static struct cmd_list_element *show_ada_list;
13316
13317 static void
13318 initialize_ada_catchpoint_ops (void)
13319 {
13320   struct breakpoint_ops *ops;
13321
13322   initialize_breakpoint_ops ();
13323
13324   ops = &catch_exception_breakpoint_ops;
13325   *ops = bkpt_breakpoint_ops;
13326   ops->allocate_location = allocate_location_exception;
13327   ops->re_set = re_set_exception;
13328   ops->check_status = check_status_exception;
13329   ops->print_it = print_it_exception;
13330   ops->print_one = print_one_exception;
13331   ops->print_mention = print_mention_exception;
13332   ops->print_recreate = print_recreate_exception;
13333
13334   ops = &catch_exception_unhandled_breakpoint_ops;
13335   *ops = bkpt_breakpoint_ops;
13336   ops->allocate_location = allocate_location_exception;
13337   ops->re_set = re_set_exception;
13338   ops->check_status = check_status_exception;
13339   ops->print_it = print_it_exception;
13340   ops->print_one = print_one_exception;
13341   ops->print_mention = print_mention_exception;
13342   ops->print_recreate = print_recreate_exception;
13343
13344   ops = &catch_assert_breakpoint_ops;
13345   *ops = bkpt_breakpoint_ops;
13346   ops->allocate_location = allocate_location_exception;
13347   ops->re_set = re_set_exception;
13348   ops->check_status = check_status_exception;
13349   ops->print_it = print_it_exception;
13350   ops->print_one = print_one_exception;
13351   ops->print_mention = print_mention_exception;
13352   ops->print_recreate = print_recreate_exception;
13353
13354   ops = &catch_handlers_breakpoint_ops;
13355   *ops = bkpt_breakpoint_ops;
13356   ops->allocate_location = allocate_location_exception;
13357   ops->re_set = re_set_exception;
13358   ops->check_status = check_status_exception;
13359   ops->print_it = print_it_exception;
13360   ops->print_one = print_one_exception;
13361   ops->print_mention = print_mention_exception;
13362   ops->print_recreate = print_recreate_exception;
13363 }
13364
13365 /* This module's 'new_objfile' observer.  */
13366
13367 static void
13368 ada_new_objfile_observer (struct objfile *objfile)
13369 {
13370   ada_clear_symbol_cache ();
13371 }
13372
13373 /* This module's 'free_objfile' observer.  */
13374
13375 static void
13376 ada_free_objfile_observer (struct objfile *objfile)
13377 {
13378   ada_clear_symbol_cache ();
13379 }
13380
13381 void _initialize_ada_language ();
13382 void
13383 _initialize_ada_language ()
13384 {
13385   initialize_ada_catchpoint_ops ();
13386
13387   add_basic_prefix_cmd ("ada", no_class,
13388                         _("Prefix command for changing Ada-specific settings."),
13389                         &set_ada_list, "set ada ", 0, &setlist);
13390
13391   add_show_prefix_cmd ("ada", no_class,
13392                        _("Generic command for showing Ada-specific settings."),
13393                        &show_ada_list, "show ada ", 0, &showlist);
13394
13395   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13396                            &trust_pad_over_xvs, _("\
13397 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13398 Show whether an optimization trusting PAD types over XVS types is activated."),
13399                            _("\
13400 This is related to the encoding used by the GNAT compiler.  The debugger\n\
13401 should normally trust the contents of PAD types, but certain older versions\n\
13402 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13403 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
13404 work around this bug.  It is always safe to turn this option \"off\", but\n\
13405 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13406 this option to \"off\" unless necessary."),
13407                             NULL, NULL, &set_ada_list, &show_ada_list);
13408
13409   add_setshow_boolean_cmd ("print-signatures", class_vars,
13410                            &print_signatures, _("\
13411 Enable or disable the output of formal and return types for functions in the \
13412 overloads selection menu."), _("\
13413 Show whether the output of formal and return types for functions in the \
13414 overloads selection menu is activated."),
13415                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
13416
13417   add_catch_command ("exception", _("\
13418 Catch Ada exceptions, when raised.\n\
13419 Usage: catch exception [ARG] [if CONDITION]\n\
13420 Without any argument, stop when any Ada exception is raised.\n\
13421 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
13422 being raised does not have a handler (and will therefore lead to the task's\n\
13423 termination).\n\
13424 Otherwise, the catchpoint only stops when the name of the exception being\n\
13425 raised is the same as ARG.\n\
13426 CONDITION is a boolean expression that is evaluated to see whether the\n\
13427 exception should cause a stop."),
13428                      catch_ada_exception_command,
13429                      catch_ada_completer,
13430                      CATCH_PERMANENT,
13431                      CATCH_TEMPORARY);
13432
13433   add_catch_command ("handlers", _("\
13434 Catch Ada exceptions, when handled.\n\
13435 Usage: catch handlers [ARG] [if CONDITION]\n\
13436 Without any argument, stop when any Ada exception is handled.\n\
13437 With an argument, catch only exceptions with the given name.\n\
13438 CONDITION is a boolean expression that is evaluated to see whether the\n\
13439 exception should cause a stop."),
13440                      catch_ada_handlers_command,
13441                      catch_ada_completer,
13442                      CATCH_PERMANENT,
13443                      CATCH_TEMPORARY);
13444   add_catch_command ("assert", _("\
13445 Catch failed Ada assertions, when raised.\n\
13446 Usage: catch assert [if CONDITION]\n\
13447 CONDITION is a boolean expression that is evaluated to see whether the\n\
13448 exception should cause a stop."),
13449                      catch_assert_command,
13450                      NULL,
13451                      CATCH_PERMANENT,
13452                      CATCH_TEMPORARY);
13453
13454   varsize_limit = 65536;
13455   add_setshow_uinteger_cmd ("varsize-limit", class_support,
13456                             &varsize_limit, _("\
13457 Set the maximum number of bytes allowed in a variable-size object."), _("\
13458 Show the maximum number of bytes allowed in a variable-size object."), _("\
13459 Attempts to access an object whose size is not a compile-time constant\n\
13460 and exceeds this limit will cause an error."),
13461                             NULL, NULL, &setlist, &showlist);
13462
13463   add_info ("exceptions", info_exceptions_command,
13464             _("\
13465 List all Ada exception names.\n\
13466 Usage: info exceptions [REGEXP]\n\
13467 If a regular expression is passed as an argument, only those matching\n\
13468 the regular expression are listed."));
13469
13470   add_basic_prefix_cmd ("ada", class_maintenance,
13471                         _("Set Ada maintenance-related variables."),
13472                         &maint_set_ada_cmdlist, "maintenance set ada ",
13473                         0/*allow-unknown*/, &maintenance_set_cmdlist);
13474
13475   add_show_prefix_cmd ("ada", class_maintenance,
13476                        _("Show Ada maintenance-related variables."),
13477                        &maint_show_ada_cmdlist, "maintenance show ada ",
13478                        0/*allow-unknown*/, &maintenance_show_cmdlist);
13479
13480   add_setshow_boolean_cmd
13481     ("ignore-descriptive-types", class_maintenance,
13482      &ada_ignore_descriptive_types_p,
13483      _("Set whether descriptive types generated by GNAT should be ignored."),
13484      _("Show whether descriptive types generated by GNAT should be ignored."),
13485      _("\
13486 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13487 DWARF attribute."),
13488      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
13489
13490   decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
13491                                            NULL, xcalloc, xfree);
13492
13493   /* The ada-lang observers.  */
13494   gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
13495   gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
13496   gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");
13497 }
This page took 0.770337 seconds and 4 git commands to generate.