]> Git Repo - binutils.git/blob - gdb/ada-lang.c
Ada support for wide strings
[binutils.git] / gdb / ada-lang.c
1 /* Ada language support routines for GDB, the GNU debugger.
2
3    Copyright (C) 1992-2022 Free Software Foundation, Inc.
4
5    This file is part of GDB.
6
7    This program is free software; you can redistribute it and/or modify
8    it under the terms of the GNU General Public License as published by
9    the Free Software Foundation; either version 3 of the License, or
10    (at your option) any later version.
11
12    This program is distributed in the hope that it will be useful,
13    but WITHOUT ANY WARRANTY; without even the implied warranty of
14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15    GNU General Public License for more details.
16
17    You should have received a copy of the GNU General Public License
18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
19
20
21 #include "defs.h"
22 #include <ctype.h>
23 #include "gdbsupport/gdb_regex.h"
24 #include "frame.h"
25 #include "symtab.h"
26 #include "gdbtypes.h"
27 #include "gdbcmd.h"
28 #include "expression.h"
29 #include "parser-defs.h"
30 #include "language.h"
31 #include "varobj.h"
32 #include "inferior.h"
33 #include "symfile.h"
34 #include "objfiles.h"
35 #include "breakpoint.h"
36 #include "gdbcore.h"
37 #include "hashtab.h"
38 #include "gdbsupport/gdb_obstack.h"
39 #include "ada-lang.h"
40 #include "completer.h"
41 #include "ui-out.h"
42 #include "block.h"
43 #include "infcall.h"
44 #include "annotate.h"
45 #include "valprint.h"
46 #include "source.h"
47 #include "observable.h"
48 #include "stack.h"
49 #include "typeprint.h"
50 #include "namespace.h"
51 #include "cli/cli-style.h"
52 #include "cli/cli-decode.h"
53
54 #include "value.h"
55 #include "mi/mi-common.h"
56 #include "arch-utils.h"
57 #include "cli/cli-utils.h"
58 #include "gdbsupport/function-view.h"
59 #include "gdbsupport/byte-vector.h"
60 #include <algorithm>
61 #include "ada-exp.h"
62 #include "charset.h"
63
64 /* Define whether or not the C operator '/' truncates towards zero for
65    differently signed operands (truncation direction is undefined in C).
66    Copied from valarith.c.  */
67
68 #ifndef TRUNCATION_TOWARDS_ZERO
69 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
70 #endif
71
72 static struct type *desc_base_type (struct type *);
73
74 static struct type *desc_bounds_type (struct type *);
75
76 static struct value *desc_bounds (struct value *);
77
78 static int fat_pntr_bounds_bitpos (struct type *);
79
80 static int fat_pntr_bounds_bitsize (struct type *);
81
82 static struct type *desc_data_target_type (struct type *);
83
84 static struct value *desc_data (struct value *);
85
86 static int fat_pntr_data_bitpos (struct type *);
87
88 static int fat_pntr_data_bitsize (struct type *);
89
90 static struct value *desc_one_bound (struct value *, int, int);
91
92 static int desc_bound_bitpos (struct type *, int, int);
93
94 static int desc_bound_bitsize (struct type *, int, int);
95
96 static struct type *desc_index_type (struct type *, int);
97
98 static int desc_arity (struct type *);
99
100 static int ada_args_match (struct symbol *, struct value **, int);
101
102 static struct value *make_array_descriptor (struct type *, struct value *);
103
104 static void ada_add_block_symbols (std::vector<struct block_symbol> &,
105                                    const struct block *,
106                                    const lookup_name_info &lookup_name,
107                                    domain_enum, struct objfile *);
108
109 static void ada_add_all_symbols (std::vector<struct block_symbol> &,
110                                  const struct block *,
111                                  const lookup_name_info &lookup_name,
112                                  domain_enum, int, int *);
113
114 static int is_nonfunction (const std::vector<struct block_symbol> &);
115
116 static void add_defn_to_vec (std::vector<struct block_symbol> &,
117                              struct symbol *,
118                              const struct block *);
119
120 static int possible_user_operator_p (enum exp_opcode, struct value **);
121
122 static const char *ada_decoded_op_name (enum exp_opcode);
123
124 static int numeric_type_p (struct type *);
125
126 static int integer_type_p (struct type *);
127
128 static int scalar_type_p (struct type *);
129
130 static int discrete_type_p (struct type *);
131
132 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
133                                                 int, int);
134
135 static struct type *ada_find_parallel_type_with_name (struct type *,
136                                                       const char *);
137
138 static int is_dynamic_field (struct type *, int);
139
140 static struct type *to_fixed_variant_branch_type (struct type *,
141                                                   const gdb_byte *,
142                                                   CORE_ADDR, struct value *);
143
144 static struct type *to_fixed_array_type (struct type *, struct value *, int);
145
146 static struct type *to_fixed_range_type (struct type *, struct value *);
147
148 static struct type *to_static_fixed_type (struct type *);
149 static struct type *static_unwrap_type (struct type *type);
150
151 static struct value *unwrap_value (struct value *);
152
153 static struct type *constrained_packed_array_type (struct type *, long *);
154
155 static struct type *decode_constrained_packed_array_type (struct type *);
156
157 static long decode_packed_array_bitsize (struct type *);
158
159 static struct value *decode_constrained_packed_array (struct value *);
160
161 static int ada_is_unconstrained_packed_array_type (struct type *);
162
163 static struct value *value_subscript_packed (struct value *, int,
164                                              struct value **);
165
166 static struct value *coerce_unspec_val_to_type (struct value *,
167                                                 struct type *);
168
169 static int lesseq_defined_than (struct symbol *, struct symbol *);
170
171 static int equiv_types (struct type *, struct type *);
172
173 static int is_name_suffix (const char *);
174
175 static int advance_wild_match (const char **, const char *, char);
176
177 static bool wild_match (const char *name, const char *patn);
178
179 static struct value *ada_coerce_ref (struct value *);
180
181 static LONGEST pos_atr (struct value *);
182
183 static struct value *val_atr (struct type *, LONGEST);
184
185 static struct symbol *standard_lookup (const char *, const struct block *,
186                                        domain_enum);
187
188 static struct value *ada_search_struct_field (const char *, struct value *, int,
189                                               struct type *);
190
191 static int find_struct_field (const char *, struct type *, int,
192                               struct type **, int *, int *, int *, int *);
193
194 static int ada_resolve_function (std::vector<struct block_symbol> &,
195                                  struct value **, int, const char *,
196                                  struct type *, bool);
197
198 static int ada_is_direct_array_type (struct type *);
199
200 static struct value *ada_index_struct_field (int, struct value *, int,
201                                              struct type *);
202
203 static void add_component_interval (LONGEST, LONGEST, std::vector<LONGEST> &);
204
205
206 static struct type *ada_find_any_type (const char *name);
207
208 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
209   (const lookup_name_info &lookup_name);
210
211 \f
212
213 /* The character set used for source files.  */
214 static const char *ada_source_charset;
215
216 /* The string "UTF-8".  This is here so we can check for the UTF-8
217    charset using == rather than strcmp.  */
218 static const char ada_utf8[] = "UTF-8";
219
220 /* Each entry in the UTF-32 case-folding table is of this form.  */
221 struct utf8_entry
222 {
223   /* The start and end, inclusive, of this range of codepoints.  */
224   uint32_t start, end;
225   /* The delta to apply to get the upper-case form.  0 if this is
226      already upper-case.  */
227   int upper_delta;
228   /* The delta to apply to get the lower-case form.  0 if this is
229      already lower-case.  */
230   int lower_delta;
231
232   bool operator< (uint32_t val) const
233   {
234     return end < val;
235   }
236 };
237
238 static const utf8_entry ada_case_fold[] =
239 {
240 #include "ada-casefold.h"
241 };
242
243 \f
244
245 /* The result of a symbol lookup to be stored in our symbol cache.  */
246
247 struct cache_entry
248 {
249   /* The name used to perform the lookup.  */
250   const char *name;
251   /* The namespace used during the lookup.  */
252   domain_enum domain;
253   /* The symbol returned by the lookup, or NULL if no matching symbol
254      was found.  */
255   struct symbol *sym;
256   /* The block where the symbol was found, or NULL if no matching
257      symbol was found.  */
258   const struct block *block;
259   /* A pointer to the next entry with the same hash.  */
260   struct cache_entry *next;
261 };
262
263 /* The Ada symbol cache, used to store the result of Ada-mode symbol
264    lookups in the course of executing the user's commands.
265
266    The cache is implemented using a simple, fixed-sized hash.
267    The size is fixed on the grounds that there are not likely to be
268    all that many symbols looked up during any given session, regardless
269    of the size of the symbol table.  If we decide to go to a resizable
270    table, let's just use the stuff from libiberty instead.  */
271
272 #define HASH_SIZE 1009
273
274 struct ada_symbol_cache
275 {
276   /* An obstack used to store the entries in our cache.  */
277   struct auto_obstack cache_space;
278
279   /* The root of the hash table used to implement our symbol cache.  */
280   struct cache_entry *root[HASH_SIZE] {};
281 };
282
283 static const char ada_completer_word_break_characters[] =
284 #ifdef VMS
285   " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
286 #else
287   " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
288 #endif
289
290 /* The name of the symbol to use to get the name of the main subprogram.  */
291 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
292   = "__gnat_ada_main_program_name";
293
294 /* Limit on the number of warnings to raise per expression evaluation.  */
295 static int warning_limit = 2;
296
297 /* Number of warning messages issued; reset to 0 by cleanups after
298    expression evaluation.  */
299 static int warnings_issued = 0;
300
301 static const char * const known_runtime_file_name_patterns[] = {
302   ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
303 };
304
305 static const char * const known_auxiliary_function_name_patterns[] = {
306   ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
307 };
308
309 /* Maintenance-related settings for this module.  */
310
311 static struct cmd_list_element *maint_set_ada_cmdlist;
312 static struct cmd_list_element *maint_show_ada_cmdlist;
313
314 /* The "maintenance ada set/show ignore-descriptive-type" value.  */
315
316 static bool ada_ignore_descriptive_types_p = false;
317
318                         /* Inferior-specific data.  */
319
320 /* Per-inferior data for this module.  */
321
322 struct ada_inferior_data
323 {
324   /* The ada__tags__type_specific_data type, which is used when decoding
325      tagged types.  With older versions of GNAT, this type was directly
326      accessible through a component ("tsd") in the object tag.  But this
327      is no longer the case, so we cache it for each inferior.  */
328   struct type *tsd_type = nullptr;
329
330   /* The exception_support_info data.  This data is used to determine
331      how to implement support for Ada exception catchpoints in a given
332      inferior.  */
333   const struct exception_support_info *exception_info = nullptr;
334 };
335
336 /* Our key to this module's inferior data.  */
337 static const struct inferior_key<ada_inferior_data> ada_inferior_data;
338
339 /* Return our inferior data for the given inferior (INF).
340
341    This function always returns a valid pointer to an allocated
342    ada_inferior_data structure.  If INF's inferior data has not
343    been previously set, this functions creates a new one with all
344    fields set to zero, sets INF's inferior to it, and then returns
345    a pointer to that newly allocated ada_inferior_data.  */
346
347 static struct ada_inferior_data *
348 get_ada_inferior_data (struct inferior *inf)
349 {
350   struct ada_inferior_data *data;
351
352   data = ada_inferior_data.get (inf);
353   if (data == NULL)
354     data = ada_inferior_data.emplace (inf);
355
356   return data;
357 }
358
359 /* Perform all necessary cleanups regarding our module's inferior data
360    that is required after the inferior INF just exited.  */
361
362 static void
363 ada_inferior_exit (struct inferior *inf)
364 {
365   ada_inferior_data.clear (inf);
366 }
367
368
369                         /* program-space-specific data.  */
370
371 /* This module's per-program-space data.  */
372 struct ada_pspace_data
373 {
374   /* The Ada symbol cache.  */
375   std::unique_ptr<ada_symbol_cache> sym_cache;
376 };
377
378 /* Key to our per-program-space data.  */
379 static const struct program_space_key<ada_pspace_data> ada_pspace_data_handle;
380
381 /* Return this module's data for the given program space (PSPACE).
382    If not is found, add a zero'ed one now.
383
384    This function always returns a valid object.  */
385
386 static struct ada_pspace_data *
387 get_ada_pspace_data (struct program_space *pspace)
388 {
389   struct ada_pspace_data *data;
390
391   data = ada_pspace_data_handle.get (pspace);
392   if (data == NULL)
393     data = ada_pspace_data_handle.emplace (pspace);
394
395   return data;
396 }
397
398                         /* Utilities */
399
400 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
401    all typedef layers have been peeled.  Otherwise, return TYPE.
402
403    Normally, we really expect a typedef type to only have 1 typedef layer.
404    In other words, we really expect the target type of a typedef type to be
405    a non-typedef type.  This is particularly true for Ada units, because
406    the language does not have a typedef vs not-typedef distinction.
407    In that respect, the Ada compiler has been trying to eliminate as many
408    typedef definitions in the debugging information, since they generally
409    do not bring any extra information (we still use typedef under certain
410    circumstances related mostly to the GNAT encoding).
411
412    Unfortunately, we have seen situations where the debugging information
413    generated by the compiler leads to such multiple typedef layers.  For
414    instance, consider the following example with stabs:
415
416      .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
417      .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
418
419    This is an error in the debugging information which causes type
420    pck__float_array___XUP to be defined twice, and the second time,
421    it is defined as a typedef of a typedef.
422
423    This is on the fringe of legality as far as debugging information is
424    concerned, and certainly unexpected.  But it is easy to handle these
425    situations correctly, so we can afford to be lenient in this case.  */
426
427 static struct type *
428 ada_typedef_target_type (struct type *type)
429 {
430   while (type->code () == TYPE_CODE_TYPEDEF)
431     type = TYPE_TARGET_TYPE (type);
432   return type;
433 }
434
435 /* Given DECODED_NAME a string holding a symbol name in its
436    decoded form (ie using the Ada dotted notation), returns
437    its unqualified name.  */
438
439 static const char *
440 ada_unqualified_name (const char *decoded_name)
441 {
442   const char *result;
443   
444   /* If the decoded name starts with '<', it means that the encoded
445      name does not follow standard naming conventions, and thus that
446      it is not your typical Ada symbol name.  Trying to unqualify it
447      is therefore pointless and possibly erroneous.  */
448   if (decoded_name[0] == '<')
449     return decoded_name;
450
451   result = strrchr (decoded_name, '.');
452   if (result != NULL)
453     result++;                   /* Skip the dot...  */
454   else
455     result = decoded_name;
456
457   return result;
458 }
459
460 /* Return a string starting with '<', followed by STR, and '>'.  */
461
462 static std::string
463 add_angle_brackets (const char *str)
464 {
465   return string_printf ("<%s>", str);
466 }
467
468 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
469    suffix of FIELD_NAME beginning "___".  */
470
471 static int
472 field_name_match (const char *field_name, const char *target)
473 {
474   int len = strlen (target);
475
476   return
477     (strncmp (field_name, target, len) == 0
478      && (field_name[len] == '\0'
479          || (startswith (field_name + len, "___")
480              && strcmp (field_name + strlen (field_name) - 6,
481                         "___XVN") != 0)));
482 }
483
484
485 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
486    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
487    and return its index.  This function also handles fields whose name
488    have ___ suffixes because the compiler sometimes alters their name
489    by adding such a suffix to represent fields with certain constraints.
490    If the field could not be found, return a negative number if
491    MAYBE_MISSING is set.  Otherwise raise an error.  */
492
493 int
494 ada_get_field_index (const struct type *type, const char *field_name,
495                      int maybe_missing)
496 {
497   int fieldno;
498   struct type *struct_type = check_typedef ((struct type *) type);
499
500   for (fieldno = 0; fieldno < struct_type->num_fields (); fieldno++)
501     if (field_name_match (struct_type->field (fieldno).name (), field_name))
502       return fieldno;
503
504   if (!maybe_missing)
505     error (_("Unable to find field %s in struct %s.  Aborting"),
506            field_name, struct_type->name ());
507
508   return -1;
509 }
510
511 /* The length of the prefix of NAME prior to any "___" suffix.  */
512
513 int
514 ada_name_prefix_len (const char *name)
515 {
516   if (name == NULL)
517     return 0;
518   else
519     {
520       const char *p = strstr (name, "___");
521
522       if (p == NULL)
523         return strlen (name);
524       else
525         return p - name;
526     }
527 }
528
529 /* Return non-zero if SUFFIX is a suffix of STR.
530    Return zero if STR is null.  */
531
532 static int
533 is_suffix (const char *str, const char *suffix)
534 {
535   int len1, len2;
536
537   if (str == NULL)
538     return 0;
539   len1 = strlen (str);
540   len2 = strlen (suffix);
541   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
542 }
543
544 /* The contents of value VAL, treated as a value of type TYPE.  The
545    result is an lval in memory if VAL is.  */
546
547 static struct value *
548 coerce_unspec_val_to_type (struct value *val, struct type *type)
549 {
550   type = ada_check_typedef (type);
551   if (value_type (val) == type)
552     return val;
553   else
554     {
555       struct value *result;
556
557       if (value_optimized_out (val))
558         result = allocate_optimized_out_value (type);
559       else if (value_lazy (val)
560                /* Be careful not to make a lazy not_lval value.  */
561                || (VALUE_LVAL (val) != not_lval
562                    && TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val))))
563         result = allocate_value_lazy (type);
564       else
565         {
566           result = allocate_value (type);
567           value_contents_copy (result, 0, val, 0, TYPE_LENGTH (type));
568         }
569       set_value_component_location (result, val);
570       set_value_bitsize (result, value_bitsize (val));
571       set_value_bitpos (result, value_bitpos (val));
572       if (VALUE_LVAL (result) == lval_memory)
573         set_value_address (result, value_address (val));
574       return result;
575     }
576 }
577
578 static const gdb_byte *
579 cond_offset_host (const gdb_byte *valaddr, long offset)
580 {
581   if (valaddr == NULL)
582     return NULL;
583   else
584     return valaddr + offset;
585 }
586
587 static CORE_ADDR
588 cond_offset_target (CORE_ADDR address, long offset)
589 {
590   if (address == 0)
591     return 0;
592   else
593     return address + offset;
594 }
595
596 /* Issue a warning (as for the definition of warning in utils.c, but
597    with exactly one argument rather than ...), unless the limit on the
598    number of warnings has passed during the evaluation of the current
599    expression.  */
600
601 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
602    provided by "complaint".  */
603 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
604
605 static void
606 lim_warning (const char *format, ...)
607 {
608   va_list args;
609
610   va_start (args, format);
611   warnings_issued += 1;
612   if (warnings_issued <= warning_limit)
613     vwarning (format, args);
614
615   va_end (args);
616 }
617
618 /* Maximum value of a SIZE-byte signed integer type.  */
619 static LONGEST
620 max_of_size (int size)
621 {
622   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
623
624   return top_bit | (top_bit - 1);
625 }
626
627 /* Minimum value of a SIZE-byte signed integer type.  */
628 static LONGEST
629 min_of_size (int size)
630 {
631   return -max_of_size (size) - 1;
632 }
633
634 /* Maximum value of a SIZE-byte unsigned integer type.  */
635 static ULONGEST
636 umax_of_size (int size)
637 {
638   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
639
640   return top_bit | (top_bit - 1);
641 }
642
643 /* Maximum value of integral type T, as a signed quantity.  */
644 static LONGEST
645 max_of_type (struct type *t)
646 {
647   if (t->is_unsigned ())
648     return (LONGEST) umax_of_size (TYPE_LENGTH (t));
649   else
650     return max_of_size (TYPE_LENGTH (t));
651 }
652
653 /* Minimum value of integral type T, as a signed quantity.  */
654 static LONGEST
655 min_of_type (struct type *t)
656 {
657   if (t->is_unsigned ())
658     return 0;
659   else
660     return min_of_size (TYPE_LENGTH (t));
661 }
662
663 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
664 LONGEST
665 ada_discrete_type_high_bound (struct type *type)
666 {
667   type = resolve_dynamic_type (type, {}, 0);
668   switch (type->code ())
669     {
670     case TYPE_CODE_RANGE:
671       {
672         const dynamic_prop &high = type->bounds ()->high;
673
674         if (high.kind () == PROP_CONST)
675           return high.const_val ();
676         else
677           {
678             gdb_assert (high.kind () == PROP_UNDEFINED);
679
680             /* This happens when trying to evaluate a type's dynamic bound
681                without a live target.  There is nothing relevant for us to
682                return here, so return 0.  */
683             return 0;
684           }
685       }
686     case TYPE_CODE_ENUM:
687       return type->field (type->num_fields () - 1).loc_enumval ();
688     case TYPE_CODE_BOOL:
689       return 1;
690     case TYPE_CODE_CHAR:
691     case TYPE_CODE_INT:
692       return max_of_type (type);
693     default:
694       error (_("Unexpected type in ada_discrete_type_high_bound."));
695     }
696 }
697
698 /* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
699 LONGEST
700 ada_discrete_type_low_bound (struct type *type)
701 {
702   type = resolve_dynamic_type (type, {}, 0);
703   switch (type->code ())
704     {
705     case TYPE_CODE_RANGE:
706       {
707         const dynamic_prop &low = type->bounds ()->low;
708
709         if (low.kind () == PROP_CONST)
710           return low.const_val ();
711         else
712           {
713             gdb_assert (low.kind () == PROP_UNDEFINED);
714
715             /* This happens when trying to evaluate a type's dynamic bound
716                without a live target.  There is nothing relevant for us to
717                return here, so return 0.  */
718             return 0;
719           }
720       }
721     case TYPE_CODE_ENUM:
722       return type->field (0).loc_enumval ();
723     case TYPE_CODE_BOOL:
724       return 0;
725     case TYPE_CODE_CHAR:
726     case TYPE_CODE_INT:
727       return min_of_type (type);
728     default:
729       error (_("Unexpected type in ada_discrete_type_low_bound."));
730     }
731 }
732
733 /* The identity on non-range types.  For range types, the underlying
734    non-range scalar type.  */
735
736 static struct type *
737 get_base_type (struct type *type)
738 {
739   while (type != NULL && type->code () == TYPE_CODE_RANGE)
740     {
741       if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
742         return type;
743       type = TYPE_TARGET_TYPE (type);
744     }
745   return type;
746 }
747
748 /* Return a decoded version of the given VALUE.  This means returning
749    a value whose type is obtained by applying all the GNAT-specific
750    encodings, making the resulting type a static but standard description
751    of the initial type.  */
752
753 struct value *
754 ada_get_decoded_value (struct value *value)
755 {
756   struct type *type = ada_check_typedef (value_type (value));
757
758   if (ada_is_array_descriptor_type (type)
759       || (ada_is_constrained_packed_array_type (type)
760           && type->code () != TYPE_CODE_PTR))
761     {
762       if (type->code () == TYPE_CODE_TYPEDEF)  /* array access type.  */
763         value = ada_coerce_to_simple_array_ptr (value);
764       else
765         value = ada_coerce_to_simple_array (value);
766     }
767   else
768     value = ada_to_fixed_value (value);
769
770   return value;
771 }
772
773 /* Same as ada_get_decoded_value, but with the given TYPE.
774    Because there is no associated actual value for this type,
775    the resulting type might be a best-effort approximation in
776    the case of dynamic types.  */
777
778 struct type *
779 ada_get_decoded_type (struct type *type)
780 {
781   type = to_static_fixed_type (type);
782   if (ada_is_constrained_packed_array_type (type))
783     type = ada_coerce_to_simple_array_type (type);
784   return type;
785 }
786
787 \f
788
789                                 /* Language Selection */
790
791 /* If the main program is in Ada, return language_ada, otherwise return LANG
792    (the main program is in Ada iif the adainit symbol is found).  */
793
794 static enum language
795 ada_update_initial_language (enum language lang)
796 {
797   if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
798     return language_ada;
799
800   return lang;
801 }
802
803 /* If the main procedure is written in Ada, then return its name.
804    The result is good until the next call.  Return NULL if the main
805    procedure doesn't appear to be in Ada.  */
806
807 char *
808 ada_main_name (void)
809 {
810   struct bound_minimal_symbol msym;
811   static gdb::unique_xmalloc_ptr<char> main_program_name;
812
813   /* For Ada, the name of the main procedure is stored in a specific
814      string constant, generated by the binder.  Look for that symbol,
815      extract its address, and then read that string.  If we didn't find
816      that string, then most probably the main procedure is not written
817      in Ada.  */
818   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
819
820   if (msym.minsym != NULL)
821     {
822       CORE_ADDR main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
823       if (main_program_name_addr == 0)
824         error (_("Invalid address for Ada main program name."));
825
826       main_program_name = target_read_string (main_program_name_addr, 1024);
827       return main_program_name.get ();
828     }
829
830   /* The main procedure doesn't seem to be in Ada.  */
831   return NULL;
832 }
833 \f
834                                 /* Symbols */
835
836 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
837    of NULLs.  */
838
839 const struct ada_opname_map ada_opname_table[] = {
840   {"Oadd", "\"+\"", BINOP_ADD},
841   {"Osubtract", "\"-\"", BINOP_SUB},
842   {"Omultiply", "\"*\"", BINOP_MUL},
843   {"Odivide", "\"/\"", BINOP_DIV},
844   {"Omod", "\"mod\"", BINOP_MOD},
845   {"Orem", "\"rem\"", BINOP_REM},
846   {"Oexpon", "\"**\"", BINOP_EXP},
847   {"Olt", "\"<\"", BINOP_LESS},
848   {"Ole", "\"<=\"", BINOP_LEQ},
849   {"Ogt", "\">\"", BINOP_GTR},
850   {"Oge", "\">=\"", BINOP_GEQ},
851   {"Oeq", "\"=\"", BINOP_EQUAL},
852   {"One", "\"/=\"", BINOP_NOTEQUAL},
853   {"Oand", "\"and\"", BINOP_BITWISE_AND},
854   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
855   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
856   {"Oconcat", "\"&\"", BINOP_CONCAT},
857   {"Oabs", "\"abs\"", UNOP_ABS},
858   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
859   {"Oadd", "\"+\"", UNOP_PLUS},
860   {"Osubtract", "\"-\"", UNOP_NEG},
861   {NULL, NULL}
862 };
863
864 /* If STR is a decoded version of a compiler-provided suffix (like the
865    "[cold]" in "symbol[cold]"), return true.  Otherwise, return
866    false.  */
867
868 static bool
869 is_compiler_suffix (const char *str)
870 {
871   gdb_assert (*str == '[');
872   ++str;
873   while (*str != '\0' && isalpha (*str))
874     ++str;
875   /* We accept a missing "]" in order to support completion.  */
876   return *str == '\0' || (str[0] == ']' && str[1] == '\0');
877 }
878
879 /* Append a non-ASCII character to RESULT.  */
880 static void
881 append_hex_encoded (std::string &result, uint32_t one_char)
882 {
883   if (one_char <= 0xff)
884     {
885       result.append ("U");
886       result.append (phex (one_char, 1));
887     }
888   else if (one_char <= 0xffff)
889     {
890       result.append ("W");
891       result.append (phex (one_char, 2));
892     }
893   else
894     {
895       result.append ("WW");
896       result.append (phex (one_char, 4));
897     }
898 }
899
900 /* Return a string that is a copy of the data in STORAGE, with
901    non-ASCII characters replaced by the appropriate hex encoding.  A
902    template is used because, for UTF-8, we actually want to work with
903    UTF-32 codepoints.  */
904 template<typename T>
905 std::string
906 copy_and_hex_encode (struct obstack *storage)
907 {
908   const T *chars = (T *) obstack_base (storage);
909   int num_chars = obstack_object_size (storage) / sizeof (T);
910   std::string result;
911   for (int i = 0; i < num_chars; ++i)
912     {
913       if (chars[i] <= 0x7f)
914         {
915           /* The host character set has to be a superset of ASCII, as
916              are all the other character sets we can use.  */
917           result.push_back (chars[i]);
918         }
919       else
920         append_hex_encoded (result, chars[i]);
921     }
922   return result;
923 }
924
925 /* The "encoded" form of DECODED, according to GNAT conventions.  If
926    THROW_ERRORS, throw an error if invalid operator name is found.
927    Otherwise, return the empty string in that case.  */
928
929 static std::string
930 ada_encode_1 (const char *decoded, bool throw_errors)
931 {
932   if (decoded == NULL)
933     return {};
934
935   std::string encoding_buffer;
936   bool saw_non_ascii = false;
937   for (const char *p = decoded; *p != '\0'; p += 1)
938     {
939       if ((*p & 0x80) != 0)
940         saw_non_ascii = true;
941
942       if (*p == '.')
943         encoding_buffer.append ("__");
944       else if (*p == '[' && is_compiler_suffix (p))
945         {
946           encoding_buffer = encoding_buffer + "." + (p + 1);
947           if (encoding_buffer.back () == ']')
948             encoding_buffer.pop_back ();
949           break;
950         }
951       else if (*p == '"')
952         {
953           const struct ada_opname_map *mapping;
954
955           for (mapping = ada_opname_table;
956                mapping->encoded != NULL
957                && !startswith (p, mapping->decoded); mapping += 1)
958             ;
959           if (mapping->encoded == NULL)
960             {
961               if (throw_errors)
962                 error (_("invalid Ada operator name: %s"), p);
963               else
964                 return {};
965             }
966           encoding_buffer.append (mapping->encoded);
967           break;
968         }
969       else
970         encoding_buffer.push_back (*p);
971     }
972
973   /* If a non-ASCII character is seen, we must convert it to the
974      appropriate hex form.  As this is more expensive, we keep track
975      of whether it is even necessary.  */
976   if (saw_non_ascii)
977     {
978       auto_obstack storage;
979       bool is_utf8 = ada_source_charset == ada_utf8;
980       try
981         {
982           convert_between_encodings
983             (host_charset (),
984              is_utf8 ? HOST_UTF32 : ada_source_charset,
985              (const gdb_byte *) encoding_buffer.c_str (),
986              encoding_buffer.length (), 1,
987              &storage, translit_none);
988         }
989       catch (const gdb_exception &)
990         {
991           static bool warned = false;
992
993           /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
994              might like to know why.  */
995           if (!warned)
996             {
997               warned = true;
998               warning (_("charset conversion failure for '%s'.\n"
999                          "You may have the wrong value for 'set ada source-charset'."),
1000                        encoding_buffer.c_str ());
1001             }
1002
1003           /* We don't try to recover from errors.  */
1004           return encoding_buffer;
1005         }
1006
1007       if (is_utf8)
1008         return copy_and_hex_encode<uint32_t> (&storage);
1009       return copy_and_hex_encode<gdb_byte> (&storage);
1010     }
1011
1012   return encoding_buffer;
1013 }
1014
1015 /* Find the entry for C in the case-folding table.  Return nullptr if
1016    the entry does not cover C.  */
1017 static const utf8_entry *
1018 find_case_fold_entry (uint32_t c)
1019 {
1020   auto iter = std::lower_bound (std::begin (ada_case_fold),
1021                                 std::end (ada_case_fold),
1022                                 c);
1023   if (iter == std::end (ada_case_fold)
1024       || c < iter->start
1025       || c > iter->end)
1026     return nullptr;
1027   return &*iter;
1028 }
1029
1030 /* Return NAME folded to lower case, or, if surrounded by single
1031    quotes, unfolded, but with the quotes stripped away.  If
1032    THROW_ON_ERROR is true, encoding failures will throw an exception
1033    rather than emitting a warning.  Result good to next call.  */
1034
1035 static const char *
1036 ada_fold_name (gdb::string_view name, bool throw_on_error = false)
1037 {
1038   static std::string fold_storage;
1039
1040   if (!name.empty () && name[0] == '\'')
1041     fold_storage = gdb::to_string (name.substr (1, name.size () - 2));
1042   else
1043     {
1044       /* Why convert to UTF-32 and implement our own case-folding,
1045          rather than convert to wchar_t and use the platform's
1046          functions?  I'm glad you asked.
1047
1048          The main problem is that GNAT implements an unusual rule for
1049          case folding.  For ASCII letters, letters in single-byte
1050          encodings (such as ISO-8859-*), and Unicode letters that fit
1051          in a single byte (i.e., code point is <= 0xff), the letter is
1052          folded to lower case.  Other Unicode letters are folded to
1053          upper case.
1054
1055          This rule means that the code must be able to examine the
1056          value of the character.  And, some hosts do not use Unicode
1057          for wchar_t, so examining the value of such characters is
1058          forbidden.  */
1059       auto_obstack storage;
1060       try
1061         {
1062           convert_between_encodings
1063             (host_charset (), HOST_UTF32,
1064              (const gdb_byte *) name.data (),
1065              name.length (), 1,
1066              &storage, translit_none);
1067         }
1068       catch (const gdb_exception &)
1069         {
1070           if (throw_on_error)
1071             throw;
1072
1073           static bool warned = false;
1074
1075           /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
1076              might like to know why.  */
1077           if (!warned)
1078             {
1079               warned = true;
1080               warning (_("could not convert '%s' from the host encoding (%s) to UTF-32.\n"
1081                          "This normally should not happen, please file a bug report."),
1082                        gdb::to_string (name).c_str (), host_charset ());
1083             }
1084
1085           /* We don't try to recover from errors; just return the
1086              original string.  */
1087           fold_storage = gdb::to_string (name);
1088           return fold_storage.c_str ();
1089         }
1090
1091       bool is_utf8 = ada_source_charset == ada_utf8;
1092       uint32_t *chars = (uint32_t *) obstack_base (&storage);
1093       int num_chars = obstack_object_size (&storage) / sizeof (uint32_t);
1094       for (int i = 0; i < num_chars; ++i)
1095         {
1096           const struct utf8_entry *entry = find_case_fold_entry (chars[i]);
1097           if (entry != nullptr)
1098             {
1099               uint32_t low = chars[i] + entry->lower_delta;
1100               if (!is_utf8 || low <= 0xff)
1101                 chars[i] = low;
1102               else
1103                 chars[i] = chars[i] + entry->upper_delta;
1104             }
1105         }
1106
1107       /* Now convert back to ordinary characters.  */
1108       auto_obstack reconverted;
1109       try
1110         {
1111           convert_between_encodings (HOST_UTF32,
1112                                      host_charset (),
1113                                      (const gdb_byte *) chars,
1114                                      num_chars * sizeof (uint32_t),
1115                                      sizeof (uint32_t),
1116                                      &reconverted,
1117                                      translit_none);
1118           obstack_1grow (&reconverted, '\0');
1119           fold_storage = std::string ((const char *) obstack_base (&reconverted));
1120         }
1121       catch (const gdb_exception &)
1122         {
1123           if (throw_on_error)
1124             throw;
1125
1126           static bool warned = false;
1127
1128           /* Converting back from UTF-32 shouldn't normally fail, but
1129              there are some host encodings without upper/lower
1130              equivalence.  */
1131           if (!warned)
1132             {
1133               warned = true;
1134               warning (_("could not convert the lower-cased variant of '%s'\n"
1135                          "from UTF-32 to the host encoding (%s)."),
1136                        gdb::to_string (name).c_str (), host_charset ());
1137             }
1138
1139           /* We don't try to recover from errors; just return the
1140              original string.  */
1141           fold_storage = gdb::to_string (name);
1142         }
1143     }
1144
1145   return fold_storage.c_str ();
1146 }
1147
1148 /* The "encoded" form of DECODED, according to GNAT conventions.  */
1149
1150 std::string
1151 ada_encode (const char *decoded)
1152 {
1153   if (decoded[0] != '<')
1154     decoded = ada_fold_name (decoded);
1155   return ada_encode_1 (decoded, true);
1156 }
1157
1158 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
1159
1160 static int
1161 is_lower_alphanum (const char c)
1162 {
1163   return (isdigit (c) || (isalpha (c) && islower (c)));
1164 }
1165
1166 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1167    This function saves in LEN the length of that same symbol name but
1168    without either of these suffixes:
1169      . .{DIGIT}+
1170      . ${DIGIT}+
1171      . ___{DIGIT}+
1172      . __{DIGIT}+.
1173
1174    These are suffixes introduced by the compiler for entities such as
1175    nested subprogram for instance, in order to avoid name clashes.
1176    They do not serve any purpose for the debugger.  */
1177
1178 static void
1179 ada_remove_trailing_digits (const char *encoded, int *len)
1180 {
1181   if (*len > 1 && isdigit (encoded[*len - 1]))
1182     {
1183       int i = *len - 2;
1184
1185       while (i > 0 && isdigit (encoded[i]))
1186         i--;
1187       if (i >= 0 && encoded[i] == '.')
1188         *len = i;
1189       else if (i >= 0 && encoded[i] == '$')
1190         *len = i;
1191       else if (i >= 2 && startswith (encoded + i - 2, "___"))
1192         *len = i - 2;
1193       else if (i >= 1 && startswith (encoded + i - 1, "__"))
1194         *len = i - 1;
1195     }
1196 }
1197
1198 /* Remove the suffix introduced by the compiler for protected object
1199    subprograms.  */
1200
1201 static void
1202 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1203 {
1204   /* Remove trailing N.  */
1205
1206   /* Protected entry subprograms are broken into two
1207      separate subprograms: The first one is unprotected, and has
1208      a 'N' suffix; the second is the protected version, and has
1209      the 'P' suffix.  The second calls the first one after handling
1210      the protection.  Since the P subprograms are internally generated,
1211      we leave these names undecoded, giving the user a clue that this
1212      entity is internal.  */
1213
1214   if (*len > 1
1215       && encoded[*len - 1] == 'N'
1216       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1217     *len = *len - 1;
1218 }
1219
1220 /* If ENCODED ends with a compiler-provided suffix (like ".cold"),
1221    then update *LEN to remove the suffix and return the offset of the
1222    character just past the ".".  Otherwise, return -1.  */
1223
1224 static int
1225 remove_compiler_suffix (const char *encoded, int *len)
1226 {
1227   int offset = *len - 1;
1228   while (offset > 0 && isalpha (encoded[offset]))
1229     --offset;
1230   if (offset > 0 && encoded[offset] == '.')
1231     {
1232       *len = offset;
1233       return offset + 1;
1234     }
1235   return -1;
1236 }
1237
1238 /* Convert an ASCII hex string to a number.  Reads exactly N
1239    characters from STR.  Returns true on success, false if one of the
1240    digits was not a hex digit.  */
1241 static bool
1242 convert_hex (const char *str, int n, uint32_t *out)
1243 {
1244   uint32_t result = 0;
1245
1246   for (int i = 0; i < n; ++i)
1247     {
1248       if (!isxdigit (str[i]))
1249         return false;
1250       result <<= 4;
1251       result |= fromhex (str[i]);
1252     }
1253
1254   *out = result;
1255   return true;
1256 }
1257
1258 /* Convert a wide character from its ASCII hex representation in STR
1259    (consisting of exactly N characters) to the host encoding,
1260    appending the resulting bytes to OUT.  If N==2 and the Ada source
1261    charset is not UTF-8, then hex refers to an encoding in the
1262    ADA_SOURCE_CHARSET; otherwise, use UTF-32.  Return true on success.
1263    Return false and do not modify OUT on conversion failure.  */
1264 static bool
1265 convert_from_hex_encoded (std::string &out, const char *str, int n)
1266 {
1267   uint32_t value;
1268
1269   if (!convert_hex (str, n, &value))
1270     return false;
1271   try
1272     {
1273       auto_obstack bytes;
1274       /* In the 'U' case, the hex digits encode the character in the
1275          Ada source charset.  However, if the source charset is UTF-8,
1276          this really means it is a single-byte UTF-32 character.  */
1277       if (n == 2 && ada_source_charset != ada_utf8)
1278         {
1279           gdb_byte one_char = (gdb_byte) value;
1280
1281           convert_between_encodings (ada_source_charset, host_charset (),
1282                                      &one_char,
1283                                      sizeof (one_char), sizeof (one_char),
1284                                      &bytes, translit_none);
1285         }
1286       else
1287         convert_between_encodings (HOST_UTF32, host_charset (),
1288                                    (const gdb_byte *) &value,
1289                                    sizeof (value), sizeof (value),
1290                                    &bytes, translit_none);
1291       obstack_1grow (&bytes, '\0');
1292       out.append ((const char *) obstack_base (&bytes));
1293     }
1294   catch (const gdb_exception &)
1295     {
1296       /* On failure, the caller will just let the encoded form
1297          through, which seems basically reasonable.  */
1298       return false;
1299     }
1300
1301   return true;
1302 }
1303
1304 /* See ada-lang.h.  */
1305
1306 std::string
1307 ada_decode (const char *encoded, bool wrap)
1308 {
1309   int i;
1310   int len0;
1311   const char *p;
1312   int at_start_name;
1313   std::string decoded;
1314   int suffix = -1;
1315
1316   /* With function descriptors on PPC64, the value of a symbol named
1317      ".FN", if it exists, is the entry point of the function "FN".  */
1318   if (encoded[0] == '.')
1319     encoded += 1;
1320
1321   /* The name of the Ada main procedure starts with "_ada_".
1322      This prefix is not part of the decoded name, so skip this part
1323      if we see this prefix.  */
1324   if (startswith (encoded, "_ada_"))
1325     encoded += 5;
1326
1327   /* If the name starts with '_', then it is not a properly encoded
1328      name, so do not attempt to decode it.  Similarly, if the name
1329      starts with '<', the name should not be decoded.  */
1330   if (encoded[0] == '_' || encoded[0] == '<')
1331     goto Suppress;
1332
1333   len0 = strlen (encoded);
1334
1335   suffix = remove_compiler_suffix (encoded, &len0);
1336
1337   ada_remove_trailing_digits (encoded, &len0);
1338   ada_remove_po_subprogram_suffix (encoded, &len0);
1339
1340   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1341      the suffix is located before the current "end" of ENCODED.  We want
1342      to avoid re-matching parts of ENCODED that have previously been
1343      marked as discarded (by decrementing LEN0).  */
1344   p = strstr (encoded, "___");
1345   if (p != NULL && p - encoded < len0 - 3)
1346     {
1347       if (p[3] == 'X')
1348         len0 = p - encoded;
1349       else
1350         goto Suppress;
1351     }
1352
1353   /* Remove any trailing TKB suffix.  It tells us that this symbol
1354      is for the body of a task, but that information does not actually
1355      appear in the decoded name.  */
1356
1357   if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1358     len0 -= 3;
1359
1360   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1361      from the TKB suffix because it is used for non-anonymous task
1362      bodies.  */
1363
1364   if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1365     len0 -= 2;
1366
1367   /* Remove trailing "B" suffixes.  */
1368   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1369
1370   if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1371     len0 -= 1;
1372
1373   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1374
1375   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1376     {
1377       i = len0 - 2;
1378       while ((i >= 0 && isdigit (encoded[i]))
1379              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1380         i -= 1;
1381       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1382         len0 = i - 1;
1383       else if (encoded[i] == '$')
1384         len0 = i;
1385     }
1386
1387   /* The first few characters that are not alphabetic are not part
1388      of any encoding we use, so we can copy them over verbatim.  */
1389
1390   for (i = 0; i < len0 && !isalpha (encoded[i]); i += 1)
1391     decoded.push_back (encoded[i]);
1392
1393   at_start_name = 1;
1394   while (i < len0)
1395     {
1396       /* Is this a symbol function?  */
1397       if (at_start_name && encoded[i] == 'O')
1398         {
1399           int k;
1400
1401           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1402             {
1403               int op_len = strlen (ada_opname_table[k].encoded);
1404               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1405                             op_len - 1) == 0)
1406                   && !isalnum (encoded[i + op_len]))
1407                 {
1408                   decoded.append (ada_opname_table[k].decoded);
1409                   at_start_name = 0;
1410                   i += op_len;
1411                   break;
1412                 }
1413             }
1414           if (ada_opname_table[k].encoded != NULL)
1415             continue;
1416         }
1417       at_start_name = 0;
1418
1419       /* Replace "TK__" with "__", which will eventually be translated
1420          into "." (just below).  */
1421
1422       if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1423         i += 2;
1424
1425       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1426          be translated into "." (just below).  These are internal names
1427          generated for anonymous blocks inside which our symbol is nested.  */
1428
1429       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1430           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1431           && isdigit (encoded [i+4]))
1432         {
1433           int k = i + 5;
1434           
1435           while (k < len0 && isdigit (encoded[k]))
1436             k++;  /* Skip any extra digit.  */
1437
1438           /* Double-check that the "__B_{DIGITS}+" sequence we found
1439              is indeed followed by "__".  */
1440           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1441             i = k;
1442         }
1443
1444       /* Remove _E{DIGITS}+[sb] */
1445
1446       /* Just as for protected object subprograms, there are 2 categories
1447          of subprograms created by the compiler for each entry.  The first
1448          one implements the actual entry code, and has a suffix following
1449          the convention above; the second one implements the barrier and
1450          uses the same convention as above, except that the 'E' is replaced
1451          by a 'B'.
1452
1453          Just as above, we do not decode the name of barrier functions
1454          to give the user a clue that the code he is debugging has been
1455          internally generated.  */
1456
1457       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1458           && isdigit (encoded[i+2]))
1459         {
1460           int k = i + 3;
1461
1462           while (k < len0 && isdigit (encoded[k]))
1463             k++;
1464
1465           if (k < len0
1466               && (encoded[k] == 'b' || encoded[k] == 's'))
1467             {
1468               k++;
1469               /* Just as an extra precaution, make sure that if this
1470                  suffix is followed by anything else, it is a '_'.
1471                  Otherwise, we matched this sequence by accident.  */
1472               if (k == len0
1473                   || (k < len0 && encoded[k] == '_'))
1474                 i = k;
1475             }
1476         }
1477
1478       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1479          the GNAT front-end in protected object subprograms.  */
1480
1481       if (i < len0 + 3
1482           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1483         {
1484           /* Backtrack a bit up until we reach either the begining of
1485              the encoded name, or "__".  Make sure that we only find
1486              digits or lowercase characters.  */
1487           const char *ptr = encoded + i - 1;
1488
1489           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1490             ptr--;
1491           if (ptr < encoded
1492               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1493             i++;
1494         }
1495
1496       if (i < len0 + 3 && encoded[i] == 'U' && isxdigit (encoded[i + 1]))
1497         {
1498           if (convert_from_hex_encoded (decoded, &encoded[i + 1], 2))
1499             {
1500               i += 3;
1501               continue;
1502             }
1503         }
1504       else if (i < len0 + 5 && encoded[i] == 'W' && isxdigit (encoded[i + 1]))
1505         {
1506           if (convert_from_hex_encoded (decoded, &encoded[i + 1], 4))
1507             {
1508               i += 5;
1509               continue;
1510             }
1511         }
1512       else if (i < len0 + 10 && encoded[i] == 'W' && encoded[i + 1] == 'W'
1513                && isxdigit (encoded[i + 2]))
1514         {
1515           if (convert_from_hex_encoded (decoded, &encoded[i + 2], 8))
1516             {
1517               i += 10;
1518               continue;
1519             }
1520         }
1521
1522       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1523         {
1524           /* This is a X[bn]* sequence not separated from the previous
1525              part of the name with a non-alpha-numeric character (in other
1526              words, immediately following an alpha-numeric character), then
1527              verify that it is placed at the end of the encoded name.  If
1528              not, then the encoding is not valid and we should abort the
1529              decoding.  Otherwise, just skip it, it is used in body-nested
1530              package names.  */
1531           do
1532             i += 1;
1533           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1534           if (i < len0)
1535             goto Suppress;
1536         }
1537       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1538         {
1539          /* Replace '__' by '.'.  */
1540           decoded.push_back ('.');
1541           at_start_name = 1;
1542           i += 2;
1543         }
1544       else
1545         {
1546           /* It's a character part of the decoded name, so just copy it
1547              over.  */
1548           decoded.push_back (encoded[i]);
1549           i += 1;
1550         }
1551     }
1552
1553   /* Decoded names should never contain any uppercase character.
1554      Double-check this, and abort the decoding if we find one.  */
1555
1556   for (i = 0; i < decoded.length(); ++i)
1557     if (isupper (decoded[i]) || decoded[i] == ' ')
1558       goto Suppress;
1559
1560   /* If the compiler added a suffix, append it now.  */
1561   if (suffix >= 0)
1562     decoded = decoded + "[" + &encoded[suffix] + "]";
1563
1564   return decoded;
1565
1566 Suppress:
1567   if (!wrap)
1568     return {};
1569
1570   if (encoded[0] == '<')
1571     decoded = encoded;
1572   else
1573     decoded = '<' + std::string(encoded) + '>';
1574   return decoded;
1575 }
1576
1577 /* Table for keeping permanent unique copies of decoded names.  Once
1578    allocated, names in this table are never released.  While this is a
1579    storage leak, it should not be significant unless there are massive
1580    changes in the set of decoded names in successive versions of a 
1581    symbol table loaded during a single session.  */
1582 static struct htab *decoded_names_store;
1583
1584 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1585    in the language-specific part of GSYMBOL, if it has not been
1586    previously computed.  Tries to save the decoded name in the same
1587    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1588    in any case, the decoded symbol has a lifetime at least that of
1589    GSYMBOL).
1590    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1591    const, but nevertheless modified to a semantically equivalent form
1592    when a decoded name is cached in it.  */
1593
1594 const char *
1595 ada_decode_symbol (const struct general_symbol_info *arg)
1596 {
1597   struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1598   const char **resultp =
1599     &gsymbol->language_specific.demangled_name;
1600
1601   if (!gsymbol->ada_mangled)
1602     {
1603       std::string decoded = ada_decode (gsymbol->linkage_name ());
1604       struct obstack *obstack = gsymbol->language_specific.obstack;
1605
1606       gsymbol->ada_mangled = 1;
1607
1608       if (obstack != NULL)
1609         *resultp = obstack_strdup (obstack, decoded.c_str ());
1610       else
1611         {
1612           /* Sometimes, we can't find a corresponding objfile, in
1613              which case, we put the result on the heap.  Since we only
1614              decode when needed, we hope this usually does not cause a
1615              significant memory leak (FIXME).  */
1616
1617           char **slot = (char **) htab_find_slot (decoded_names_store,
1618                                                   decoded.c_str (), INSERT);
1619
1620           if (*slot == NULL)
1621             *slot = xstrdup (decoded.c_str ());
1622           *resultp = *slot;
1623         }
1624     }
1625
1626   return *resultp;
1627 }
1628
1629 \f
1630
1631                                 /* Arrays */
1632
1633 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1634    generated by the GNAT compiler to describe the index type used
1635    for each dimension of an array, check whether it follows the latest
1636    known encoding.  If not, fix it up to conform to the latest encoding.
1637    Otherwise, do nothing.  This function also does nothing if
1638    INDEX_DESC_TYPE is NULL.
1639
1640    The GNAT encoding used to describe the array index type evolved a bit.
1641    Initially, the information would be provided through the name of each
1642    field of the structure type only, while the type of these fields was
1643    described as unspecified and irrelevant.  The debugger was then expected
1644    to perform a global type lookup using the name of that field in order
1645    to get access to the full index type description.  Because these global
1646    lookups can be very expensive, the encoding was later enhanced to make
1647    the global lookup unnecessary by defining the field type as being
1648    the full index type description.
1649
1650    The purpose of this routine is to allow us to support older versions
1651    of the compiler by detecting the use of the older encoding, and by
1652    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1653    we essentially replace each field's meaningless type by the associated
1654    index subtype).  */
1655
1656 void
1657 ada_fixup_array_indexes_type (struct type *index_desc_type)
1658 {
1659   int i;
1660
1661   if (index_desc_type == NULL)
1662     return;
1663   gdb_assert (index_desc_type->num_fields () > 0);
1664
1665   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1666      to check one field only, no need to check them all).  If not, return
1667      now.
1668
1669      If our INDEX_DESC_TYPE was generated using the older encoding,
1670      the field type should be a meaningless integer type whose name
1671      is not equal to the field name.  */
1672   if (index_desc_type->field (0).type ()->name () != NULL
1673       && strcmp (index_desc_type->field (0).type ()->name (),
1674                  index_desc_type->field (0).name ()) == 0)
1675     return;
1676
1677   /* Fixup each field of INDEX_DESC_TYPE.  */
1678   for (i = 0; i < index_desc_type->num_fields (); i++)
1679    {
1680      const char *name = index_desc_type->field (i).name ();
1681      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1682
1683      if (raw_type)
1684        index_desc_type->field (i).set_type (raw_type);
1685    }
1686 }
1687
1688 /* The desc_* routines return primitive portions of array descriptors
1689    (fat pointers).  */
1690
1691 /* The descriptor or array type, if any, indicated by TYPE; removes
1692    level of indirection, if needed.  */
1693
1694 static struct type *
1695 desc_base_type (struct type *type)
1696 {
1697   if (type == NULL)
1698     return NULL;
1699   type = ada_check_typedef (type);
1700   if (type->code () == TYPE_CODE_TYPEDEF)
1701     type = ada_typedef_target_type (type);
1702
1703   if (type != NULL
1704       && (type->code () == TYPE_CODE_PTR
1705           || type->code () == TYPE_CODE_REF))
1706     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1707   else
1708     return type;
1709 }
1710
1711 /* True iff TYPE indicates a "thin" array pointer type.  */
1712
1713 static int
1714 is_thin_pntr (struct type *type)
1715 {
1716   return
1717     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1718     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1719 }
1720
1721 /* The descriptor type for thin pointer type TYPE.  */
1722
1723 static struct type *
1724 thin_descriptor_type (struct type *type)
1725 {
1726   struct type *base_type = desc_base_type (type);
1727
1728   if (base_type == NULL)
1729     return NULL;
1730   if (is_suffix (ada_type_name (base_type), "___XVE"))
1731     return base_type;
1732   else
1733     {
1734       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1735
1736       if (alt_type == NULL)
1737         return base_type;
1738       else
1739         return alt_type;
1740     }
1741 }
1742
1743 /* A pointer to the array data for thin-pointer value VAL.  */
1744
1745 static struct value *
1746 thin_data_pntr (struct value *val)
1747 {
1748   struct type *type = ada_check_typedef (value_type (val));
1749   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1750
1751   data_type = lookup_pointer_type (data_type);
1752
1753   if (type->code () == TYPE_CODE_PTR)
1754     return value_cast (data_type, value_copy (val));
1755   else
1756     return value_from_longest (data_type, value_address (val));
1757 }
1758
1759 /* True iff TYPE indicates a "thick" array pointer type.  */
1760
1761 static int
1762 is_thick_pntr (struct type *type)
1763 {
1764   type = desc_base_type (type);
1765   return (type != NULL && type->code () == TYPE_CODE_STRUCT
1766           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1767 }
1768
1769 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1770    pointer to one, the type of its bounds data; otherwise, NULL.  */
1771
1772 static struct type *
1773 desc_bounds_type (struct type *type)
1774 {
1775   struct type *r;
1776
1777   type = desc_base_type (type);
1778
1779   if (type == NULL)
1780     return NULL;
1781   else if (is_thin_pntr (type))
1782     {
1783       type = thin_descriptor_type (type);
1784       if (type == NULL)
1785         return NULL;
1786       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1787       if (r != NULL)
1788         return ada_check_typedef (r);
1789     }
1790   else if (type->code () == TYPE_CODE_STRUCT)
1791     {
1792       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1793       if (r != NULL)
1794         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1795     }
1796   return NULL;
1797 }
1798
1799 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1800    one, a pointer to its bounds data.   Otherwise NULL.  */
1801
1802 static struct value *
1803 desc_bounds (struct value *arr)
1804 {
1805   struct type *type = ada_check_typedef (value_type (arr));
1806
1807   if (is_thin_pntr (type))
1808     {
1809       struct type *bounds_type =
1810         desc_bounds_type (thin_descriptor_type (type));
1811       LONGEST addr;
1812
1813       if (bounds_type == NULL)
1814         error (_("Bad GNAT array descriptor"));
1815
1816       /* NOTE: The following calculation is not really kosher, but
1817          since desc_type is an XVE-encoded type (and shouldn't be),
1818          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1819       if (type->code () == TYPE_CODE_PTR)
1820         addr = value_as_long (arr);
1821       else
1822         addr = value_address (arr);
1823
1824       return
1825         value_from_longest (lookup_pointer_type (bounds_type),
1826                             addr - TYPE_LENGTH (bounds_type));
1827     }
1828
1829   else if (is_thick_pntr (type))
1830     {
1831       struct value *p_bounds = value_struct_elt (&arr, {}, "P_BOUNDS", NULL,
1832                                                _("Bad GNAT array descriptor"));
1833       struct type *p_bounds_type = value_type (p_bounds);
1834
1835       if (p_bounds_type
1836           && p_bounds_type->code () == TYPE_CODE_PTR)
1837         {
1838           struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1839
1840           if (target_type->is_stub ())
1841             p_bounds = value_cast (lookup_pointer_type
1842                                    (ada_check_typedef (target_type)),
1843                                    p_bounds);
1844         }
1845       else
1846         error (_("Bad GNAT array descriptor"));
1847
1848       return p_bounds;
1849     }
1850   else
1851     return NULL;
1852 }
1853
1854 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1855    position of the field containing the address of the bounds data.  */
1856
1857 static int
1858 fat_pntr_bounds_bitpos (struct type *type)
1859 {
1860   return desc_base_type (type)->field (1).loc_bitpos ();
1861 }
1862
1863 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1864    size of the field containing the address of the bounds data.  */
1865
1866 static int
1867 fat_pntr_bounds_bitsize (struct type *type)
1868 {
1869   type = desc_base_type (type);
1870
1871   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1872     return TYPE_FIELD_BITSIZE (type, 1);
1873   else
1874     return 8 * TYPE_LENGTH (ada_check_typedef (type->field (1).type ()));
1875 }
1876
1877 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1878    pointer to one, the type of its array data (a array-with-no-bounds type);
1879    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1880    data.  */
1881
1882 static struct type *
1883 desc_data_target_type (struct type *type)
1884 {
1885   type = desc_base_type (type);
1886
1887   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1888   if (is_thin_pntr (type))
1889     return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1890   else if (is_thick_pntr (type))
1891     {
1892       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1893
1894       if (data_type
1895           && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1896         return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1897     }
1898
1899   return NULL;
1900 }
1901
1902 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1903    its array data.  */
1904
1905 static struct value *
1906 desc_data (struct value *arr)
1907 {
1908   struct type *type = value_type (arr);
1909
1910   if (is_thin_pntr (type))
1911     return thin_data_pntr (arr);
1912   else if (is_thick_pntr (type))
1913     return value_struct_elt (&arr, {}, "P_ARRAY", NULL,
1914                              _("Bad GNAT array descriptor"));
1915   else
1916     return NULL;
1917 }
1918
1919
1920 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1921    position of the field containing the address of the data.  */
1922
1923 static int
1924 fat_pntr_data_bitpos (struct type *type)
1925 {
1926   return desc_base_type (type)->field (0).loc_bitpos ();
1927 }
1928
1929 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1930    size of the field containing the address of the data.  */
1931
1932 static int
1933 fat_pntr_data_bitsize (struct type *type)
1934 {
1935   type = desc_base_type (type);
1936
1937   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1938     return TYPE_FIELD_BITSIZE (type, 0);
1939   else
1940     return TARGET_CHAR_BIT * TYPE_LENGTH (type->field (0).type ());
1941 }
1942
1943 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1944    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1945    bound, if WHICH is 1.  The first bound is I=1.  */
1946
1947 static struct value *
1948 desc_one_bound (struct value *bounds, int i, int which)
1949 {
1950   char bound_name[20];
1951   xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1952              which ? 'U' : 'L', i - 1);
1953   return value_struct_elt (&bounds, {}, bound_name, NULL,
1954                            _("Bad GNAT array descriptor bounds"));
1955 }
1956
1957 /* If BOUNDS is an array-bounds structure type, return the bit position
1958    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1959    bound, if WHICH is 1.  The first bound is I=1.  */
1960
1961 static int
1962 desc_bound_bitpos (struct type *type, int i, int which)
1963 {
1964   return desc_base_type (type)->field (2 * i + which - 2).loc_bitpos ();
1965 }
1966
1967 /* If BOUNDS is an array-bounds structure type, return the bit field size
1968    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1969    bound, if WHICH is 1.  The first bound is I=1.  */
1970
1971 static int
1972 desc_bound_bitsize (struct type *type, int i, int which)
1973 {
1974   type = desc_base_type (type);
1975
1976   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1977     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1978   else
1979     return 8 * TYPE_LENGTH (type->field (2 * i + which - 2).type ());
1980 }
1981
1982 /* If TYPE is the type of an array-bounds structure, the type of its
1983    Ith bound (numbering from 1).  Otherwise, NULL.  */
1984
1985 static struct type *
1986 desc_index_type (struct type *type, int i)
1987 {
1988   type = desc_base_type (type);
1989
1990   if (type->code () == TYPE_CODE_STRUCT)
1991     {
1992       char bound_name[20];
1993       xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
1994       return lookup_struct_elt_type (type, bound_name, 1);
1995     }
1996   else
1997     return NULL;
1998 }
1999
2000 /* The number of index positions in the array-bounds type TYPE.
2001    Return 0 if TYPE is NULL.  */
2002
2003 static int
2004 desc_arity (struct type *type)
2005 {
2006   type = desc_base_type (type);
2007
2008   if (type != NULL)
2009     return type->num_fields () / 2;
2010   return 0;
2011 }
2012
2013 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
2014    an array descriptor type (representing an unconstrained array
2015    type).  */
2016
2017 static int
2018 ada_is_direct_array_type (struct type *type)
2019 {
2020   if (type == NULL)
2021     return 0;
2022   type = ada_check_typedef (type);
2023   return (type->code () == TYPE_CODE_ARRAY
2024           || ada_is_array_descriptor_type (type));
2025 }
2026
2027 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
2028  * to one.  */
2029
2030 static int
2031 ada_is_array_type (struct type *type)
2032 {
2033   while (type != NULL
2034          && (type->code () == TYPE_CODE_PTR
2035              || type->code () == TYPE_CODE_REF))
2036     type = TYPE_TARGET_TYPE (type);
2037   return ada_is_direct_array_type (type);
2038 }
2039
2040 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
2041
2042 int
2043 ada_is_simple_array_type (struct type *type)
2044 {
2045   if (type == NULL)
2046     return 0;
2047   type = ada_check_typedef (type);
2048   return (type->code () == TYPE_CODE_ARRAY
2049           || (type->code () == TYPE_CODE_PTR
2050               && (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ()
2051                   == TYPE_CODE_ARRAY)));
2052 }
2053
2054 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
2055
2056 int
2057 ada_is_array_descriptor_type (struct type *type)
2058 {
2059   struct type *data_type = desc_data_target_type (type);
2060
2061   if (type == NULL)
2062     return 0;
2063   type = ada_check_typedef (type);
2064   return (data_type != NULL
2065           && data_type->code () == TYPE_CODE_ARRAY
2066           && desc_arity (desc_bounds_type (type)) > 0);
2067 }
2068
2069 /* Non-zero iff type is a partially mal-formed GNAT array
2070    descriptor.  FIXME: This is to compensate for some problems with
2071    debugging output from GNAT.  Re-examine periodically to see if it
2072    is still needed.  */
2073
2074 int
2075 ada_is_bogus_array_descriptor (struct type *type)
2076 {
2077   return
2078     type != NULL
2079     && type->code () == TYPE_CODE_STRUCT
2080     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
2081         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
2082     && !ada_is_array_descriptor_type (type);
2083 }
2084
2085
2086 /* If ARR has a record type in the form of a standard GNAT array descriptor,
2087    (fat pointer) returns the type of the array data described---specifically,
2088    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
2089    in from the descriptor; otherwise, they are left unspecified.  If
2090    the ARR denotes a null array descriptor and BOUNDS is non-zero,
2091    returns NULL.  The result is simply the type of ARR if ARR is not
2092    a descriptor.  */
2093
2094 static struct type *
2095 ada_type_of_array (struct value *arr, int bounds)
2096 {
2097   if (ada_is_constrained_packed_array_type (value_type (arr)))
2098     return decode_constrained_packed_array_type (value_type (arr));
2099
2100   if (!ada_is_array_descriptor_type (value_type (arr)))
2101     return value_type (arr);
2102
2103   if (!bounds)
2104     {
2105       struct type *array_type =
2106         ada_check_typedef (desc_data_target_type (value_type (arr)));
2107
2108       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2109         TYPE_FIELD_BITSIZE (array_type, 0) =
2110           decode_packed_array_bitsize (value_type (arr));
2111       
2112       return array_type;
2113     }
2114   else
2115     {
2116       struct type *elt_type;
2117       int arity;
2118       struct value *descriptor;
2119
2120       elt_type = ada_array_element_type (value_type (arr), -1);
2121       arity = ada_array_arity (value_type (arr));
2122
2123       if (elt_type == NULL || arity == 0)
2124         return ada_check_typedef (value_type (arr));
2125
2126       descriptor = desc_bounds (arr);
2127       if (value_as_long (descriptor) == 0)
2128         return NULL;
2129       while (arity > 0)
2130         {
2131           struct type *range_type = alloc_type_copy (value_type (arr));
2132           struct type *array_type = alloc_type_copy (value_type (arr));
2133           struct value *low = desc_one_bound (descriptor, arity, 0);
2134           struct value *high = desc_one_bound (descriptor, arity, 1);
2135
2136           arity -= 1;
2137           create_static_range_type (range_type, value_type (low),
2138                                     longest_to_int (value_as_long (low)),
2139                                     longest_to_int (value_as_long (high)));
2140           elt_type = create_array_type (array_type, elt_type, range_type);
2141
2142           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2143             {
2144               /* We need to store the element packed bitsize, as well as
2145                  recompute the array size, because it was previously
2146                  computed based on the unpacked element size.  */
2147               LONGEST lo = value_as_long (low);
2148               LONGEST hi = value_as_long (high);
2149
2150               TYPE_FIELD_BITSIZE (elt_type, 0) =
2151                 decode_packed_array_bitsize (value_type (arr));
2152               /* If the array has no element, then the size is already
2153                  zero, and does not need to be recomputed.  */
2154               if (lo < hi)
2155                 {
2156                   int array_bitsize =
2157                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2158
2159                   TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2160                 }
2161             }
2162         }
2163
2164       return lookup_pointer_type (elt_type);
2165     }
2166 }
2167
2168 /* If ARR does not represent an array, returns ARR unchanged.
2169    Otherwise, returns either a standard GDB array with bounds set
2170    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2171    GDB array.  Returns NULL if ARR is a null fat pointer.  */
2172
2173 struct value *
2174 ada_coerce_to_simple_array_ptr (struct value *arr)
2175 {
2176   if (ada_is_array_descriptor_type (value_type (arr)))
2177     {
2178       struct type *arrType = ada_type_of_array (arr, 1);
2179
2180       if (arrType == NULL)
2181         return NULL;
2182       return value_cast (arrType, value_copy (desc_data (arr)));
2183     }
2184   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2185     return decode_constrained_packed_array (arr);
2186   else
2187     return arr;
2188 }
2189
2190 /* If ARR does not represent an array, returns ARR unchanged.
2191    Otherwise, returns a standard GDB array describing ARR (which may
2192    be ARR itself if it already is in the proper form).  */
2193
2194 struct value *
2195 ada_coerce_to_simple_array (struct value *arr)
2196 {
2197   if (ada_is_array_descriptor_type (value_type (arr)))
2198     {
2199       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2200
2201       if (arrVal == NULL)
2202         error (_("Bounds unavailable for null array pointer."));
2203       return value_ind (arrVal);
2204     }
2205   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2206     return decode_constrained_packed_array (arr);
2207   else
2208     return arr;
2209 }
2210
2211 /* If TYPE represents a GNAT array type, return it translated to an
2212    ordinary GDB array type (possibly with BITSIZE fields indicating
2213    packing).  For other types, is the identity.  */
2214
2215 struct type *
2216 ada_coerce_to_simple_array_type (struct type *type)
2217 {
2218   if (ada_is_constrained_packed_array_type (type))
2219     return decode_constrained_packed_array_type (type);
2220
2221   if (ada_is_array_descriptor_type (type))
2222     return ada_check_typedef (desc_data_target_type (type));
2223
2224   return type;
2225 }
2226
2227 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
2228
2229 static int
2230 ada_is_gnat_encoded_packed_array_type  (struct type *type)
2231 {
2232   if (type == NULL)
2233     return 0;
2234   type = desc_base_type (type);
2235   type = ada_check_typedef (type);
2236   return
2237     ada_type_name (type) != NULL
2238     && strstr (ada_type_name (type), "___XP") != NULL;
2239 }
2240
2241 /* Non-zero iff TYPE represents a standard GNAT constrained
2242    packed-array type.  */
2243
2244 int
2245 ada_is_constrained_packed_array_type (struct type *type)
2246 {
2247   return ada_is_gnat_encoded_packed_array_type (type)
2248     && !ada_is_array_descriptor_type (type);
2249 }
2250
2251 /* Non-zero iff TYPE represents an array descriptor for a
2252    unconstrained packed-array type.  */
2253
2254 static int
2255 ada_is_unconstrained_packed_array_type (struct type *type)
2256 {
2257   if (!ada_is_array_descriptor_type (type))
2258     return 0;
2259
2260   if (ada_is_gnat_encoded_packed_array_type (type))
2261     return 1;
2262
2263   /* If we saw GNAT encodings, then the above code is sufficient.
2264      However, with minimal encodings, we will just have a thick
2265      pointer instead.  */
2266   if (is_thick_pntr (type))
2267     {
2268       type = desc_base_type (type);
2269       /* The structure's first field is a pointer to an array, so this
2270          fetches the array type.  */
2271       type = TYPE_TARGET_TYPE (type->field (0).type ());
2272       if (type->code () == TYPE_CODE_TYPEDEF)
2273         type = ada_typedef_target_type (type);
2274       /* Now we can see if the array elements are packed.  */
2275       return TYPE_FIELD_BITSIZE (type, 0) > 0;
2276     }
2277
2278   return 0;
2279 }
2280
2281 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2282    type, or if it is an ordinary (non-Gnat-encoded) packed array.  */
2283
2284 static bool
2285 ada_is_any_packed_array_type (struct type *type)
2286 {
2287   return (ada_is_constrained_packed_array_type (type)
2288           || (type->code () == TYPE_CODE_ARRAY
2289               && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
2290 }
2291
2292 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2293    return the size of its elements in bits.  */
2294
2295 static long
2296 decode_packed_array_bitsize (struct type *type)
2297 {
2298   const char *raw_name;
2299   const char *tail;
2300   long bits;
2301
2302   /* Access to arrays implemented as fat pointers are encoded as a typedef
2303      of the fat pointer type.  We need the name of the fat pointer type
2304      to do the decoding, so strip the typedef layer.  */
2305   if (type->code () == TYPE_CODE_TYPEDEF)
2306     type = ada_typedef_target_type (type);
2307
2308   raw_name = ada_type_name (ada_check_typedef (type));
2309   if (!raw_name)
2310     raw_name = ada_type_name (desc_base_type (type));
2311
2312   if (!raw_name)
2313     return 0;
2314
2315   tail = strstr (raw_name, "___XP");
2316   if (tail == nullptr)
2317     {
2318       gdb_assert (is_thick_pntr (type));
2319       /* The structure's first field is a pointer to an array, so this
2320          fetches the array type.  */
2321       type = TYPE_TARGET_TYPE (type->field (0).type ());
2322       /* Now we can see if the array elements are packed.  */
2323       return TYPE_FIELD_BITSIZE (type, 0);
2324     }
2325
2326   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2327     {
2328       lim_warning
2329         (_("could not understand bit size information on packed array"));
2330       return 0;
2331     }
2332
2333   return bits;
2334 }
2335
2336 /* Given that TYPE is a standard GDB array type with all bounds filled
2337    in, and that the element size of its ultimate scalar constituents
2338    (that is, either its elements, or, if it is an array of arrays, its
2339    elements' elements, etc.) is *ELT_BITS, return an identical type,
2340    but with the bit sizes of its elements (and those of any
2341    constituent arrays) recorded in the BITSIZE components of its
2342    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2343    in bits.
2344
2345    Note that, for arrays whose index type has an XA encoding where
2346    a bound references a record discriminant, getting that discriminant,
2347    and therefore the actual value of that bound, is not possible
2348    because none of the given parameters gives us access to the record.
2349    This function assumes that it is OK in the context where it is being
2350    used to return an array whose bounds are still dynamic and where
2351    the length is arbitrary.  */
2352
2353 static struct type *
2354 constrained_packed_array_type (struct type *type, long *elt_bits)
2355 {
2356   struct type *new_elt_type;
2357   struct type *new_type;
2358   struct type *index_type_desc;
2359   struct type *index_type;
2360   LONGEST low_bound, high_bound;
2361
2362   type = ada_check_typedef (type);
2363   if (type->code () != TYPE_CODE_ARRAY)
2364     return type;
2365
2366   index_type_desc = ada_find_parallel_type (type, "___XA");
2367   if (index_type_desc)
2368     index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2369                                       NULL);
2370   else
2371     index_type = type->index_type ();
2372
2373   new_type = alloc_type_copy (type);
2374   new_elt_type =
2375     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2376                                    elt_bits);
2377   create_array_type (new_type, new_elt_type, index_type);
2378   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2379   new_type->set_name (ada_type_name (type));
2380
2381   if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2382        && is_dynamic_type (check_typedef (index_type)))
2383       || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2384     low_bound = high_bound = 0;
2385   if (high_bound < low_bound)
2386     *elt_bits = TYPE_LENGTH (new_type) = 0;
2387   else
2388     {
2389       *elt_bits *= (high_bound - low_bound + 1);
2390       TYPE_LENGTH (new_type) =
2391         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2392     }
2393
2394   new_type->set_is_fixed_instance (true);
2395   return new_type;
2396 }
2397
2398 /* The array type encoded by TYPE, where
2399    ada_is_constrained_packed_array_type (TYPE).  */
2400
2401 static struct type *
2402 decode_constrained_packed_array_type (struct type *type)
2403 {
2404   const char *raw_name = ada_type_name (ada_check_typedef (type));
2405   char *name;
2406   const char *tail;
2407   struct type *shadow_type;
2408   long bits;
2409
2410   if (!raw_name)
2411     raw_name = ada_type_name (desc_base_type (type));
2412
2413   if (!raw_name)
2414     return NULL;
2415
2416   name = (char *) alloca (strlen (raw_name) + 1);
2417   tail = strstr (raw_name, "___XP");
2418   type = desc_base_type (type);
2419
2420   memcpy (name, raw_name, tail - raw_name);
2421   name[tail - raw_name] = '\000';
2422
2423   shadow_type = ada_find_parallel_type_with_name (type, name);
2424
2425   if (shadow_type == NULL)
2426     {
2427       lim_warning (_("could not find bounds information on packed array"));
2428       return NULL;
2429     }
2430   shadow_type = check_typedef (shadow_type);
2431
2432   if (shadow_type->code () != TYPE_CODE_ARRAY)
2433     {
2434       lim_warning (_("could not understand bounds "
2435                      "information on packed array"));
2436       return NULL;
2437     }
2438
2439   bits = decode_packed_array_bitsize (type);
2440   return constrained_packed_array_type (shadow_type, &bits);
2441 }
2442
2443 /* Helper function for decode_constrained_packed_array.  Set the field
2444    bitsize on a series of packed arrays.  Returns the number of
2445    elements in TYPE.  */
2446
2447 static LONGEST
2448 recursively_update_array_bitsize (struct type *type)
2449 {
2450   gdb_assert (type->code () == TYPE_CODE_ARRAY);
2451
2452   LONGEST low, high;
2453   if (!get_discrete_bounds (type->index_type (), &low, &high)
2454       || low > high)
2455     return 0;
2456   LONGEST our_len = high - low + 1;
2457
2458   struct type *elt_type = TYPE_TARGET_TYPE (type);
2459   if (elt_type->code () == TYPE_CODE_ARRAY)
2460     {
2461       LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2462       LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2463       TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2464
2465       TYPE_LENGTH (type) = ((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2466                             / HOST_CHAR_BIT);
2467     }
2468
2469   return our_len;
2470 }
2471
2472 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2473    array, returns a simple array that denotes that array.  Its type is a
2474    standard GDB array type except that the BITSIZEs of the array
2475    target types are set to the number of bits in each element, and the
2476    type length is set appropriately.  */
2477
2478 static struct value *
2479 decode_constrained_packed_array (struct value *arr)
2480 {
2481   struct type *type;
2482
2483   /* If our value is a pointer, then dereference it. Likewise if
2484      the value is a reference.  Make sure that this operation does not
2485      cause the target type to be fixed, as this would indirectly cause
2486      this array to be decoded.  The rest of the routine assumes that
2487      the array hasn't been decoded yet, so we use the basic "coerce_ref"
2488      and "value_ind" routines to perform the dereferencing, as opposed
2489      to using "ada_coerce_ref" or "ada_value_ind".  */
2490   arr = coerce_ref (arr);
2491   if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2492     arr = value_ind (arr);
2493
2494   type = decode_constrained_packed_array_type (value_type (arr));
2495   if (type == NULL)
2496     {
2497       error (_("can't unpack array"));
2498       return NULL;
2499     }
2500
2501   /* Decoding the packed array type could not correctly set the field
2502      bitsizes for any dimension except the innermost, because the
2503      bounds may be variable and were not passed to that function.  So,
2504      we further resolve the array bounds here and then update the
2505      sizes.  */
2506   const gdb_byte *valaddr = value_contents_for_printing (arr).data ();
2507   CORE_ADDR address = value_address (arr);
2508   gdb::array_view<const gdb_byte> view
2509     = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
2510   type = resolve_dynamic_type (type, view, address);
2511   recursively_update_array_bitsize (type);
2512
2513   if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2514       && ada_is_modular_type (value_type (arr)))
2515     {
2516        /* This is a (right-justified) modular type representing a packed
2517           array with no wrapper.  In order to interpret the value through
2518           the (left-justified) packed array type we just built, we must
2519           first left-justify it.  */
2520       int bit_size, bit_pos;
2521       ULONGEST mod;
2522
2523       mod = ada_modulus (value_type (arr)) - 1;
2524       bit_size = 0;
2525       while (mod > 0)
2526         {
2527           bit_size += 1;
2528           mod >>= 1;
2529         }
2530       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2531       arr = ada_value_primitive_packed_val (arr, NULL,
2532                                             bit_pos / HOST_CHAR_BIT,
2533                                             bit_pos % HOST_CHAR_BIT,
2534                                             bit_size,
2535                                             type);
2536     }
2537
2538   return coerce_unspec_val_to_type (arr, type);
2539 }
2540
2541
2542 /* The value of the element of packed array ARR at the ARITY indices
2543    given in IND.   ARR must be a simple array.  */
2544
2545 static struct value *
2546 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2547 {
2548   int i;
2549   int bits, elt_off, bit_off;
2550   long elt_total_bit_offset;
2551   struct type *elt_type;
2552   struct value *v;
2553
2554   bits = 0;
2555   elt_total_bit_offset = 0;
2556   elt_type = ada_check_typedef (value_type (arr));
2557   for (i = 0; i < arity; i += 1)
2558     {
2559       if (elt_type->code () != TYPE_CODE_ARRAY
2560           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2561         error
2562           (_("attempt to do packed indexing of "
2563              "something other than a packed array"));
2564       else
2565         {
2566           struct type *range_type = elt_type->index_type ();
2567           LONGEST lowerbound, upperbound;
2568           LONGEST idx;
2569
2570           if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2571             {
2572               lim_warning (_("don't know bounds of array"));
2573               lowerbound = upperbound = 0;
2574             }
2575
2576           idx = pos_atr (ind[i]);
2577           if (idx < lowerbound || idx > upperbound)
2578             lim_warning (_("packed array index %ld out of bounds"),
2579                          (long) idx);
2580           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2581           elt_total_bit_offset += (idx - lowerbound) * bits;
2582           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2583         }
2584     }
2585   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2586   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2587
2588   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2589                                       bits, elt_type);
2590   return v;
2591 }
2592
2593 /* Non-zero iff TYPE includes negative integer values.  */
2594
2595 static int
2596 has_negatives (struct type *type)
2597 {
2598   switch (type->code ())
2599     {
2600     default:
2601       return 0;
2602     case TYPE_CODE_INT:
2603       return !type->is_unsigned ();
2604     case TYPE_CODE_RANGE:
2605       return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2606     }
2607 }
2608
2609 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2610    unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
2611    the unpacked buffer.
2612
2613    The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2614    enough to contain at least BIT_OFFSET bits.  If not, an error is raised.
2615
2616    IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2617    zero otherwise.
2618
2619    IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2620
2621    IS_SCALAR is nonzero if the data corresponds to a signed type.  */
2622
2623 static void
2624 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2625                           gdb_byte *unpacked, int unpacked_len,
2626                           int is_big_endian, int is_signed_type,
2627                           int is_scalar)
2628 {
2629   int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2630   int src_idx;                  /* Index into the source area */
2631   int src_bytes_left;           /* Number of source bytes left to process.  */
2632   int srcBitsLeft;              /* Number of source bits left to move */
2633   int unusedLS;                 /* Number of bits in next significant
2634                                    byte of source that are unused */
2635
2636   int unpacked_idx;             /* Index into the unpacked buffer */
2637   int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */
2638
2639   unsigned long accum;          /* Staging area for bits being transferred */
2640   int accumSize;                /* Number of meaningful bits in accum */
2641   unsigned char sign;
2642
2643   /* Transmit bytes from least to most significant; delta is the direction
2644      the indices move.  */
2645   int delta = is_big_endian ? -1 : 1;
2646
2647   /* Make sure that unpacked is large enough to receive the BIT_SIZE
2648      bits from SRC.  .*/
2649   if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2650     error (_("Cannot unpack %d bits into buffer of %d bytes"),
2651            bit_size, unpacked_len);
2652
2653   srcBitsLeft = bit_size;
2654   src_bytes_left = src_len;
2655   unpacked_bytes_left = unpacked_len;
2656   sign = 0;
2657
2658   if (is_big_endian)
2659     {
2660       src_idx = src_len - 1;
2661       if (is_signed_type
2662           && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2663         sign = ~0;
2664
2665       unusedLS =
2666         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2667         % HOST_CHAR_BIT;
2668
2669       if (is_scalar)
2670         {
2671           accumSize = 0;
2672           unpacked_idx = unpacked_len - 1;
2673         }
2674       else
2675         {
2676           /* Non-scalar values must be aligned at a byte boundary...  */
2677           accumSize =
2678             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2679           /* ... And are placed at the beginning (most-significant) bytes
2680              of the target.  */
2681           unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2682           unpacked_bytes_left = unpacked_idx + 1;
2683         }
2684     }
2685   else
2686     {
2687       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2688
2689       src_idx = unpacked_idx = 0;
2690       unusedLS = bit_offset;
2691       accumSize = 0;
2692
2693       if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2694         sign = ~0;
2695     }
2696
2697   accum = 0;
2698   while (src_bytes_left > 0)
2699     {
2700       /* Mask for removing bits of the next source byte that are not
2701          part of the value.  */
2702       unsigned int unusedMSMask =
2703         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2704         1;
2705       /* Sign-extend bits for this byte.  */
2706       unsigned int signMask = sign & ~unusedMSMask;
2707
2708       accum |=
2709         (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2710       accumSize += HOST_CHAR_BIT - unusedLS;
2711       if (accumSize >= HOST_CHAR_BIT)
2712         {
2713           unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2714           accumSize -= HOST_CHAR_BIT;
2715           accum >>= HOST_CHAR_BIT;
2716           unpacked_bytes_left -= 1;
2717           unpacked_idx += delta;
2718         }
2719       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2720       unusedLS = 0;
2721       src_bytes_left -= 1;
2722       src_idx += delta;
2723     }
2724   while (unpacked_bytes_left > 0)
2725     {
2726       accum |= sign << accumSize;
2727       unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2728       accumSize -= HOST_CHAR_BIT;
2729       if (accumSize < 0)
2730         accumSize = 0;
2731       accum >>= HOST_CHAR_BIT;
2732       unpacked_bytes_left -= 1;
2733       unpacked_idx += delta;
2734     }
2735 }
2736
2737 /* Create a new value of type TYPE from the contents of OBJ starting
2738    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2739    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2740    assigning through the result will set the field fetched from.
2741    VALADDR is ignored unless OBJ is NULL, in which case,
2742    VALADDR+OFFSET must address the start of storage containing the 
2743    packed value.  The value returned  in this case is never an lval.
2744    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2745
2746 struct value *
2747 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2748                                 long offset, int bit_offset, int bit_size,
2749                                 struct type *type)
2750 {
2751   struct value *v;
2752   const gdb_byte *src;                /* First byte containing data to unpack */
2753   gdb_byte *unpacked;
2754   const int is_scalar = is_scalar_type (type);
2755   const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2756   gdb::byte_vector staging;
2757
2758   type = ada_check_typedef (type);
2759
2760   if (obj == NULL)
2761     src = valaddr + offset;
2762   else
2763     src = value_contents (obj).data () + offset;
2764
2765   if (is_dynamic_type (type))
2766     {
2767       /* The length of TYPE might by dynamic, so we need to resolve
2768          TYPE in order to know its actual size, which we then use
2769          to create the contents buffer of the value we return.
2770          The difficulty is that the data containing our object is
2771          packed, and therefore maybe not at a byte boundary.  So, what
2772          we do, is unpack the data into a byte-aligned buffer, and then
2773          use that buffer as our object's value for resolving the type.  */
2774       int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2775       staging.resize (staging_len);
2776
2777       ada_unpack_from_contents (src, bit_offset, bit_size,
2778                                 staging.data (), staging.size (),
2779                                 is_big_endian, has_negatives (type),
2780                                 is_scalar);
2781       type = resolve_dynamic_type (type, staging, 0);
2782       if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2783         {
2784           /* This happens when the length of the object is dynamic,
2785              and is actually smaller than the space reserved for it.
2786              For instance, in an array of variant records, the bit_size
2787              we're given is the array stride, which is constant and
2788              normally equal to the maximum size of its element.
2789              But, in reality, each element only actually spans a portion
2790              of that stride.  */
2791           bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2792         }
2793     }
2794
2795   if (obj == NULL)
2796     {
2797       v = allocate_value (type);
2798       src = valaddr + offset;
2799     }
2800   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2801     {
2802       int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2803       gdb_byte *buf;
2804
2805       v = value_at (type, value_address (obj) + offset);
2806       buf = (gdb_byte *) alloca (src_len);
2807       read_memory (value_address (v), buf, src_len);
2808       src = buf;
2809     }
2810   else
2811     {
2812       v = allocate_value (type);
2813       src = value_contents (obj).data () + offset;
2814     }
2815
2816   if (obj != NULL)
2817     {
2818       long new_offset = offset;
2819
2820       set_value_component_location (v, obj);
2821       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2822       set_value_bitsize (v, bit_size);
2823       if (value_bitpos (v) >= HOST_CHAR_BIT)
2824         {
2825           ++new_offset;
2826           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2827         }
2828       set_value_offset (v, new_offset);
2829
2830       /* Also set the parent value.  This is needed when trying to
2831          assign a new value (in inferior memory).  */
2832       set_value_parent (v, obj);
2833     }
2834   else
2835     set_value_bitsize (v, bit_size);
2836   unpacked = value_contents_writeable (v).data ();
2837
2838   if (bit_size == 0)
2839     {
2840       memset (unpacked, 0, TYPE_LENGTH (type));
2841       return v;
2842     }
2843
2844   if (staging.size () == TYPE_LENGTH (type))
2845     {
2846       /* Small short-cut: If we've unpacked the data into a buffer
2847          of the same size as TYPE's length, then we can reuse that,
2848          instead of doing the unpacking again.  */
2849       memcpy (unpacked, staging.data (), staging.size ());
2850     }
2851   else
2852     ada_unpack_from_contents (src, bit_offset, bit_size,
2853                               unpacked, TYPE_LENGTH (type),
2854                               is_big_endian, has_negatives (type), is_scalar);
2855
2856   return v;
2857 }
2858
2859 /* Store the contents of FROMVAL into the location of TOVAL.
2860    Return a new value with the location of TOVAL and contents of
2861    FROMVAL.   Handles assignment into packed fields that have
2862    floating-point or non-scalar types.  */
2863
2864 static struct value *
2865 ada_value_assign (struct value *toval, struct value *fromval)
2866 {
2867   struct type *type = value_type (toval);
2868   int bits = value_bitsize (toval);
2869
2870   toval = ada_coerce_ref (toval);
2871   fromval = ada_coerce_ref (fromval);
2872
2873   if (ada_is_direct_array_type (value_type (toval)))
2874     toval = ada_coerce_to_simple_array (toval);
2875   if (ada_is_direct_array_type (value_type (fromval)))
2876     fromval = ada_coerce_to_simple_array (fromval);
2877
2878   if (!deprecated_value_modifiable (toval))
2879     error (_("Left operand of assignment is not a modifiable lvalue."));
2880
2881   if (VALUE_LVAL (toval) == lval_memory
2882       && bits > 0
2883       && (type->code () == TYPE_CODE_FLT
2884           || type->code () == TYPE_CODE_STRUCT))
2885     {
2886       int len = (value_bitpos (toval)
2887                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2888       int from_size;
2889       gdb_byte *buffer = (gdb_byte *) alloca (len);
2890       struct value *val;
2891       CORE_ADDR to_addr = value_address (toval);
2892
2893       if (type->code () == TYPE_CODE_FLT)
2894         fromval = value_cast (type, fromval);
2895
2896       read_memory (to_addr, buffer, len);
2897       from_size = value_bitsize (fromval);
2898       if (from_size == 0)
2899         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2900
2901       const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2902       ULONGEST from_offset = 0;
2903       if (is_big_endian && is_scalar_type (value_type (fromval)))
2904         from_offset = from_size - bits;
2905       copy_bitwise (buffer, value_bitpos (toval),
2906                     value_contents (fromval).data (), from_offset,
2907                     bits, is_big_endian);
2908       write_memory_with_notification (to_addr, buffer, len);
2909
2910       val = value_copy (toval);
2911       memcpy (value_contents_raw (val).data (),
2912               value_contents (fromval).data (),
2913               TYPE_LENGTH (type));
2914       deprecated_set_value_type (val, type);
2915
2916       return val;
2917     }
2918
2919   return value_assign (toval, fromval);
2920 }
2921
2922
2923 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2924    CONTAINER, assign the contents of VAL to COMPONENTS's place in
2925    CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2926    COMPONENT, and not the inferior's memory.  The current contents
2927    of COMPONENT are ignored.
2928
2929    Although not part of the initial design, this function also works
2930    when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2931    had a null address, and COMPONENT had an address which is equal to
2932    its offset inside CONTAINER.  */
2933
2934 static void
2935 value_assign_to_component (struct value *container, struct value *component,
2936                            struct value *val)
2937 {
2938   LONGEST offset_in_container =
2939     (LONGEST)  (value_address (component) - value_address (container));
2940   int bit_offset_in_container =
2941     value_bitpos (component) - value_bitpos (container);
2942   int bits;
2943
2944   val = value_cast (value_type (component), val);
2945
2946   if (value_bitsize (component) == 0)
2947     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2948   else
2949     bits = value_bitsize (component);
2950
2951   if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2952     {
2953       int src_offset;
2954
2955       if (is_scalar_type (check_typedef (value_type (component))))
2956         src_offset
2957           = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2958       else
2959         src_offset = 0;
2960       copy_bitwise ((value_contents_writeable (container).data ()
2961                      + offset_in_container),
2962                     value_bitpos (container) + bit_offset_in_container,
2963                     value_contents (val).data (), src_offset, bits, 1);
2964     }
2965   else
2966     copy_bitwise ((value_contents_writeable (container).data ()
2967                    + offset_in_container),
2968                   value_bitpos (container) + bit_offset_in_container,
2969                   value_contents (val).data (), 0, bits, 0);
2970 }
2971
2972 /* Determine if TYPE is an access to an unconstrained array.  */
2973
2974 bool
2975 ada_is_access_to_unconstrained_array (struct type *type)
2976 {
2977   return (type->code () == TYPE_CODE_TYPEDEF
2978           && is_thick_pntr (ada_typedef_target_type (type)));
2979 }
2980
2981 /* The value of the element of array ARR at the ARITY indices given in IND.
2982    ARR may be either a simple array, GNAT array descriptor, or pointer
2983    thereto.  */
2984
2985 struct value *
2986 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2987 {
2988   int k;
2989   struct value *elt;
2990   struct type *elt_type;
2991
2992   elt = ada_coerce_to_simple_array (arr);
2993
2994   elt_type = ada_check_typedef (value_type (elt));
2995   if (elt_type->code () == TYPE_CODE_ARRAY
2996       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2997     return value_subscript_packed (elt, arity, ind);
2998
2999   for (k = 0; k < arity; k += 1)
3000     {
3001       struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
3002
3003       if (elt_type->code () != TYPE_CODE_ARRAY)
3004         error (_("too many subscripts (%d expected)"), k);
3005
3006       elt = value_subscript (elt, pos_atr (ind[k]));
3007
3008       if (ada_is_access_to_unconstrained_array (saved_elt_type)
3009           && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
3010         {
3011           /* The element is a typedef to an unconstrained array,
3012              except that the value_subscript call stripped the
3013              typedef layer.  The typedef layer is GNAT's way to
3014              specify that the element is, at the source level, an
3015              access to the unconstrained array, rather than the
3016              unconstrained array.  So, we need to restore that
3017              typedef layer, which we can do by forcing the element's
3018              type back to its original type. Otherwise, the returned
3019              value is going to be printed as the array, rather
3020              than as an access.  Another symptom of the same issue
3021              would be that an expression trying to dereference the
3022              element would also be improperly rejected.  */
3023           deprecated_set_value_type (elt, saved_elt_type);
3024         }
3025
3026       elt_type = ada_check_typedef (value_type (elt));
3027     }
3028
3029   return elt;
3030 }
3031
3032 /* Assuming ARR is a pointer to a GDB array, the value of the element
3033    of *ARR at the ARITY indices given in IND.
3034    Does not read the entire array into memory.
3035
3036    Note: Unlike what one would expect, this function is used instead of
3037    ada_value_subscript for basically all non-packed array types.  The reason
3038    for this is that a side effect of doing our own pointer arithmetics instead
3039    of relying on value_subscript is that there is no implicit typedef peeling.
3040    This is important for arrays of array accesses, where it allows us to
3041    preserve the fact that the array's element is an array access, where the
3042    access part os encoded in a typedef layer.  */
3043
3044 static struct value *
3045 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
3046 {
3047   int k;
3048   struct value *array_ind = ada_value_ind (arr);
3049   struct type *type
3050     = check_typedef (value_enclosing_type (array_ind));
3051
3052   if (type->code () == TYPE_CODE_ARRAY
3053       && TYPE_FIELD_BITSIZE (type, 0) > 0)
3054     return value_subscript_packed (array_ind, arity, ind);
3055
3056   for (k = 0; k < arity; k += 1)
3057     {
3058       LONGEST lwb, upb;
3059
3060       if (type->code () != TYPE_CODE_ARRAY)
3061         error (_("too many subscripts (%d expected)"), k);
3062       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
3063                         value_copy (arr));
3064       get_discrete_bounds (type->index_type (), &lwb, &upb);
3065       arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
3066       type = TYPE_TARGET_TYPE (type);
3067     }
3068
3069   return value_ind (arr);
3070 }
3071
3072 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
3073    actual type of ARRAY_PTR is ignored), returns the Ada slice of
3074    HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
3075    this array is LOW, as per Ada rules.  */
3076 static struct value *
3077 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
3078                           int low, int high)
3079 {
3080   struct type *type0 = ada_check_typedef (type);
3081   struct type *base_index_type = TYPE_TARGET_TYPE (type0->index_type ());
3082   struct type *index_type
3083     = create_static_range_type (NULL, base_index_type, low, high);
3084   struct type *slice_type = create_array_type_with_stride
3085                               (NULL, TYPE_TARGET_TYPE (type0), index_type,
3086                                type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
3087                                TYPE_FIELD_BITSIZE (type0, 0));
3088   int base_low =  ada_discrete_type_low_bound (type0->index_type ());
3089   gdb::optional<LONGEST> base_low_pos, low_pos;
3090   CORE_ADDR base;
3091
3092   low_pos = discrete_position (base_index_type, low);
3093   base_low_pos = discrete_position (base_index_type, base_low);
3094
3095   if (!low_pos.has_value () || !base_low_pos.has_value ())
3096     {
3097       warning (_("unable to get positions in slice, use bounds instead"));
3098       low_pos = low;
3099       base_low_pos = base_low;
3100     }
3101
3102   ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
3103   if (stride == 0)
3104     stride = TYPE_LENGTH (TYPE_TARGET_TYPE (type0));
3105
3106   base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
3107   return value_at_lazy (slice_type, base);
3108 }
3109
3110
3111 static struct value *
3112 ada_value_slice (struct value *array, int low, int high)
3113 {
3114   struct type *type = ada_check_typedef (value_type (array));
3115   struct type *base_index_type = TYPE_TARGET_TYPE (type->index_type ());
3116   struct type *index_type
3117     = create_static_range_type (NULL, type->index_type (), low, high);
3118   struct type *slice_type = create_array_type_with_stride
3119                               (NULL, TYPE_TARGET_TYPE (type), index_type,
3120                                type->dyn_prop (DYN_PROP_BYTE_STRIDE),
3121                                TYPE_FIELD_BITSIZE (type, 0));
3122   gdb::optional<LONGEST> low_pos, high_pos;
3123
3124
3125   low_pos = discrete_position (base_index_type, low);
3126   high_pos = discrete_position (base_index_type, high);
3127
3128   if (!low_pos.has_value () || !high_pos.has_value ())
3129     {
3130       warning (_("unable to get positions in slice, use bounds instead"));
3131       low_pos = low;
3132       high_pos = high;
3133     }
3134
3135   return value_cast (slice_type,
3136                      value_slice (array, low, *high_pos - *low_pos + 1));
3137 }
3138
3139 /* If type is a record type in the form of a standard GNAT array
3140    descriptor, returns the number of dimensions for type.  If arr is a
3141    simple array, returns the number of "array of"s that prefix its
3142    type designation.  Otherwise, returns 0.  */
3143
3144 int
3145 ada_array_arity (struct type *type)
3146 {
3147   int arity;
3148
3149   if (type == NULL)
3150     return 0;
3151
3152   type = desc_base_type (type);
3153
3154   arity = 0;
3155   if (type->code () == TYPE_CODE_STRUCT)
3156     return desc_arity (desc_bounds_type (type));
3157   else
3158     while (type->code () == TYPE_CODE_ARRAY)
3159       {
3160         arity += 1;
3161         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
3162       }
3163
3164   return arity;
3165 }
3166
3167 /* If TYPE is a record type in the form of a standard GNAT array
3168    descriptor or a simple array type, returns the element type for
3169    TYPE after indexing by NINDICES indices, or by all indices if
3170    NINDICES is -1.  Otherwise, returns NULL.  */
3171
3172 struct type *
3173 ada_array_element_type (struct type *type, int nindices)
3174 {
3175   type = desc_base_type (type);
3176
3177   if (type->code () == TYPE_CODE_STRUCT)
3178     {
3179       int k;
3180       struct type *p_array_type;
3181
3182       p_array_type = desc_data_target_type (type);
3183
3184       k = ada_array_arity (type);
3185       if (k == 0)
3186         return NULL;
3187
3188       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
3189       if (nindices >= 0 && k > nindices)
3190         k = nindices;
3191       while (k > 0 && p_array_type != NULL)
3192         {
3193           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
3194           k -= 1;
3195         }
3196       return p_array_type;
3197     }
3198   else if (type->code () == TYPE_CODE_ARRAY)
3199     {
3200       while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
3201         {
3202           type = TYPE_TARGET_TYPE (type);
3203           nindices -= 1;
3204         }
3205       return type;
3206     }
3207
3208   return NULL;
3209 }
3210
3211 /* See ada-lang.h.  */
3212
3213 struct type *
3214 ada_index_type (struct type *type, int n, const char *name)
3215 {
3216   struct type *result_type;
3217
3218   type = desc_base_type (type);
3219
3220   if (n < 0 || n > ada_array_arity (type))
3221     error (_("invalid dimension number to '%s"), name);
3222
3223   if (ada_is_simple_array_type (type))
3224     {
3225       int i;
3226
3227       for (i = 1; i < n; i += 1)
3228         {
3229           type = ada_check_typedef (type);
3230           type = TYPE_TARGET_TYPE (type);
3231         }
3232       result_type = TYPE_TARGET_TYPE (ada_check_typedef (type)->index_type ());
3233       /* FIXME: The stabs type r(0,0);bound;bound in an array type
3234          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
3235          perhaps stabsread.c would make more sense.  */
3236       if (result_type && result_type->code () == TYPE_CODE_UNDEF)
3237         result_type = NULL;
3238     }
3239   else
3240     {
3241       result_type = desc_index_type (desc_bounds_type (type), n);
3242       if (result_type == NULL)
3243         error (_("attempt to take bound of something that is not an array"));
3244     }
3245
3246   return result_type;
3247 }
3248
3249 /* Given that arr is an array type, returns the lower bound of the
3250    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3251    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
3252    array-descriptor type.  It works for other arrays with bounds supplied
3253    by run-time quantities other than discriminants.  */
3254
3255 static LONGEST
3256 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3257 {
3258   struct type *type, *index_type_desc, *index_type;
3259   int i;
3260
3261   gdb_assert (which == 0 || which == 1);
3262
3263   if (ada_is_constrained_packed_array_type (arr_type))
3264     arr_type = decode_constrained_packed_array_type (arr_type);
3265
3266   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3267     return (LONGEST) - which;
3268
3269   if (arr_type->code () == TYPE_CODE_PTR)
3270     type = TYPE_TARGET_TYPE (arr_type);
3271   else
3272     type = arr_type;
3273
3274   if (type->is_fixed_instance ())
3275     {
3276       /* The array has already been fixed, so we do not need to
3277          check the parallel ___XA type again.  That encoding has
3278          already been applied, so ignore it now.  */
3279       index_type_desc = NULL;
3280     }
3281   else
3282     {
3283       index_type_desc = ada_find_parallel_type (type, "___XA");
3284       ada_fixup_array_indexes_type (index_type_desc);
3285     }
3286
3287   if (index_type_desc != NULL)
3288     index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
3289                                       NULL);
3290   else
3291     {
3292       struct type *elt_type = check_typedef (type);
3293
3294       for (i = 1; i < n; i++)
3295         elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3296
3297       index_type = elt_type->index_type ();
3298     }
3299
3300   return
3301     (LONGEST) (which == 0
3302                ? ada_discrete_type_low_bound (index_type)
3303                : ada_discrete_type_high_bound (index_type));
3304 }
3305
3306 /* Given that arr is an array value, returns the lower bound of the
3307    nth index (numbering from 1) if WHICH is 0, and the upper bound if
3308    WHICH is 1.  This routine will also work for arrays with bounds
3309    supplied by run-time quantities other than discriminants.  */
3310
3311 static LONGEST
3312 ada_array_bound (struct value *arr, int n, int which)
3313 {
3314   struct type *arr_type;
3315
3316   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3317     arr = value_ind (arr);
3318   arr_type = value_enclosing_type (arr);
3319
3320   if (ada_is_constrained_packed_array_type (arr_type))
3321     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3322   else if (ada_is_simple_array_type (arr_type))
3323     return ada_array_bound_from_type (arr_type, n, which);
3324   else
3325     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3326 }
3327
3328 /* Given that arr is an array value, returns the length of the
3329    nth index.  This routine will also work for arrays with bounds
3330    supplied by run-time quantities other than discriminants.
3331    Does not work for arrays indexed by enumeration types with representation
3332    clauses at the moment.  */
3333
3334 static LONGEST
3335 ada_array_length (struct value *arr, int n)
3336 {
3337   struct type *arr_type, *index_type;
3338   int low, high;
3339
3340   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3341     arr = value_ind (arr);
3342   arr_type = value_enclosing_type (arr);
3343
3344   if (ada_is_constrained_packed_array_type (arr_type))
3345     return ada_array_length (decode_constrained_packed_array (arr), n);
3346
3347   if (ada_is_simple_array_type (arr_type))
3348     {
3349       low = ada_array_bound_from_type (arr_type, n, 0);
3350       high = ada_array_bound_from_type (arr_type, n, 1);
3351     }
3352   else
3353     {
3354       low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3355       high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3356     }
3357
3358   arr_type = check_typedef (arr_type);
3359   index_type = ada_index_type (arr_type, n, "length");
3360   if (index_type != NULL)
3361     {
3362       struct type *base_type;
3363       if (index_type->code () == TYPE_CODE_RANGE)
3364         base_type = TYPE_TARGET_TYPE (index_type);
3365       else
3366         base_type = index_type;
3367
3368       low = pos_atr (value_from_longest (base_type, low));
3369       high = pos_atr (value_from_longest (base_type, high));
3370     }
3371   return high - low + 1;
3372 }
3373
3374 /* An array whose type is that of ARR_TYPE (an array type), with
3375    bounds LOW to HIGH, but whose contents are unimportant.  If HIGH is
3376    less than LOW, then LOW-1 is used.  */
3377
3378 static struct value *
3379 empty_array (struct type *arr_type, int low, int high)
3380 {
3381   struct type *arr_type0 = ada_check_typedef (arr_type);
3382   struct type *index_type
3383     = create_static_range_type
3384         (NULL, TYPE_TARGET_TYPE (arr_type0->index_type ()), low,
3385          high < low ? low - 1 : high);
3386   struct type *elt_type = ada_array_element_type (arr_type0, 1);
3387
3388   return allocate_value (create_array_type (NULL, elt_type, index_type));
3389 }
3390 \f
3391
3392                                 /* Name resolution */
3393
3394 /* The "decoded" name for the user-definable Ada operator corresponding
3395    to OP.  */
3396
3397 static const char *
3398 ada_decoded_op_name (enum exp_opcode op)
3399 {
3400   int i;
3401
3402   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3403     {
3404       if (ada_opname_table[i].op == op)
3405         return ada_opname_table[i].decoded;
3406     }
3407   error (_("Could not find operator name for opcode"));
3408 }
3409
3410 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3411    in a listing of choices during disambiguation (see sort_choices, below).
3412    The idea is that overloadings of a subprogram name from the
3413    same package should sort in their source order.  We settle for ordering
3414    such symbols by their trailing number (__N  or $N).  */
3415
3416 static int
3417 encoded_ordered_before (const char *N0, const char *N1)
3418 {
3419   if (N1 == NULL)
3420     return 0;
3421   else if (N0 == NULL)
3422     return 1;
3423   else
3424     {
3425       int k0, k1;
3426
3427       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3428         ;
3429       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3430         ;
3431       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3432           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3433         {
3434           int n0, n1;
3435
3436           n0 = k0;
3437           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3438             n0 -= 1;
3439           n1 = k1;
3440           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3441             n1 -= 1;
3442           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3443             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3444         }
3445       return (strcmp (N0, N1) < 0);
3446     }
3447 }
3448
3449 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3450    encoded names.  */
3451
3452 static void
3453 sort_choices (struct block_symbol syms[], int nsyms)
3454 {
3455   int i;
3456
3457   for (i = 1; i < nsyms; i += 1)
3458     {
3459       struct block_symbol sym = syms[i];
3460       int j;
3461
3462       for (j = i - 1; j >= 0; j -= 1)
3463         {
3464           if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3465                                       sym.symbol->linkage_name ()))
3466             break;
3467           syms[j + 1] = syms[j];
3468         }
3469       syms[j + 1] = sym;
3470     }
3471 }
3472
3473 /* Whether GDB should display formals and return types for functions in the
3474    overloads selection menu.  */
3475 static bool print_signatures = true;
3476
3477 /* Print the signature for SYM on STREAM according to the FLAGS options.  For
3478    all but functions, the signature is just the name of the symbol.  For
3479    functions, this is the name of the function, the list of types for formals
3480    and the return type (if any).  */
3481
3482 static void
3483 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3484                             const struct type_print_options *flags)
3485 {
3486   struct type *type = sym->type ();
3487
3488   fprintf_filtered (stream, "%s", sym->print_name ());
3489   if (!print_signatures
3490       || type == NULL
3491       || type->code () != TYPE_CODE_FUNC)
3492     return;
3493
3494   if (type->num_fields () > 0)
3495     {
3496       int i;
3497
3498       fprintf_filtered (stream, " (");
3499       for (i = 0; i < type->num_fields (); ++i)
3500         {
3501           if (i > 0)
3502             fprintf_filtered (stream, "; ");
3503           ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3504                           flags);
3505         }
3506       fprintf_filtered (stream, ")");
3507     }
3508   if (TYPE_TARGET_TYPE (type) != NULL
3509       && TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_VOID)
3510     {
3511       fprintf_filtered (stream, " return ");
3512       ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3513     }
3514 }
3515
3516 /* Read and validate a set of numeric choices from the user in the
3517    range 0 .. N_CHOICES-1.  Place the results in increasing
3518    order in CHOICES[0 .. N-1], and return N.
3519
3520    The user types choices as a sequence of numbers on one line
3521    separated by blanks, encoding them as follows:
3522
3523      + A choice of 0 means to cancel the selection, throwing an error.
3524      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3525      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3526
3527    The user is not allowed to choose more than MAX_RESULTS values.
3528
3529    ANNOTATION_SUFFIX, if present, is used to annotate the input
3530    prompts (for use with the -f switch).  */
3531
3532 static int
3533 get_selections (int *choices, int n_choices, int max_results,
3534                 int is_all_choice, const char *annotation_suffix)
3535 {
3536   const char *args;
3537   const char *prompt;
3538   int n_chosen;
3539   int first_choice = is_all_choice ? 2 : 1;
3540
3541   prompt = getenv ("PS2");
3542   if (prompt == NULL)
3543     prompt = "> ";
3544
3545   args = command_line_input (prompt, annotation_suffix);
3546
3547   if (args == NULL)
3548     error_no_arg (_("one or more choice numbers"));
3549
3550   n_chosen = 0;
3551
3552   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3553      order, as given in args.  Choices are validated.  */
3554   while (1)
3555     {
3556       char *args2;
3557       int choice, j;
3558
3559       args = skip_spaces (args);
3560       if (*args == '\0' && n_chosen == 0)
3561         error_no_arg (_("one or more choice numbers"));
3562       else if (*args == '\0')
3563         break;
3564
3565       choice = strtol (args, &args2, 10);
3566       if (args == args2 || choice < 0
3567           || choice > n_choices + first_choice - 1)
3568         error (_("Argument must be choice number"));
3569       args = args2;
3570
3571       if (choice == 0)
3572         error (_("cancelled"));
3573
3574       if (choice < first_choice)
3575         {
3576           n_chosen = n_choices;
3577           for (j = 0; j < n_choices; j += 1)
3578             choices[j] = j;
3579           break;
3580         }
3581       choice -= first_choice;
3582
3583       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3584         {
3585         }
3586
3587       if (j < 0 || choice != choices[j])
3588         {
3589           int k;
3590
3591           for (k = n_chosen - 1; k > j; k -= 1)
3592             choices[k + 1] = choices[k];
3593           choices[j + 1] = choice;
3594           n_chosen += 1;
3595         }
3596     }
3597
3598   if (n_chosen > max_results)
3599     error (_("Select no more than %d of the above"), max_results);
3600
3601   return n_chosen;
3602 }
3603
3604 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3605    by asking the user (if necessary), returning the number selected,
3606    and setting the first elements of SYMS items.  Error if no symbols
3607    selected.  */
3608
3609 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3610    to be re-integrated one of these days.  */
3611
3612 static int
3613 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3614 {
3615   int i;
3616   int *chosen = XALLOCAVEC (int , nsyms);
3617   int n_chosen;
3618   int first_choice = (max_results == 1) ? 1 : 2;
3619   const char *select_mode = multiple_symbols_select_mode ();
3620
3621   if (max_results < 1)
3622     error (_("Request to select 0 symbols!"));
3623   if (nsyms <= 1)
3624     return nsyms;
3625
3626   if (select_mode == multiple_symbols_cancel)
3627     error (_("\
3628 canceled because the command is ambiguous\n\
3629 See set/show multiple-symbol."));
3630
3631   /* If select_mode is "all", then return all possible symbols.
3632      Only do that if more than one symbol can be selected, of course.
3633      Otherwise, display the menu as usual.  */
3634   if (select_mode == multiple_symbols_all && max_results > 1)
3635     return nsyms;
3636
3637   printf_filtered (_("[0] cancel\n"));
3638   if (max_results > 1)
3639     printf_filtered (_("[1] all\n"));
3640
3641   sort_choices (syms, nsyms);
3642
3643   for (i = 0; i < nsyms; i += 1)
3644     {
3645       if (syms[i].symbol == NULL)
3646         continue;
3647
3648       if (syms[i].symbol->aclass () == LOC_BLOCK)
3649         {
3650           struct symtab_and_line sal =
3651             find_function_start_sal (syms[i].symbol, 1);
3652
3653           printf_filtered ("[%d] ", i + first_choice);
3654           ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3655                                       &type_print_raw_options);
3656           if (sal.symtab == NULL)
3657             printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3658                              metadata_style.style ().ptr (), nullptr, sal.line);
3659           else
3660             printf_filtered
3661               (_(" at %ps:%d\n"),
3662                styled_string (file_name_style.style (),
3663                               symtab_to_filename_for_display (sal.symtab)),
3664                sal.line);
3665           continue;
3666         }
3667       else
3668         {
3669           int is_enumeral =
3670             (syms[i].symbol->aclass () == LOC_CONST
3671              && syms[i].symbol->type () != NULL
3672              && syms[i].symbol->type ()->code () == TYPE_CODE_ENUM);
3673           struct symtab *symtab = NULL;
3674
3675           if (syms[i].symbol->is_objfile_owned ())
3676             symtab = symbol_symtab (syms[i].symbol);
3677
3678           if (syms[i].symbol->line () != 0 && symtab != NULL)
3679             {
3680               printf_filtered ("[%d] ", i + first_choice);
3681               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3682                                           &type_print_raw_options);
3683               printf_filtered (_(" at %s:%d\n"),
3684                                symtab_to_filename_for_display (symtab),
3685                                syms[i].symbol->line ());
3686             }
3687           else if (is_enumeral
3688                    && syms[i].symbol->type ()->name () != NULL)
3689             {
3690               printf_filtered (("[%d] "), i + first_choice);
3691               ada_print_type (syms[i].symbol->type (), NULL,
3692                               gdb_stdout, -1, 0, &type_print_raw_options);
3693               printf_filtered (_("'(%s) (enumeral)\n"),
3694                                syms[i].symbol->print_name ());
3695             }
3696           else
3697             {
3698               printf_filtered ("[%d] ", i + first_choice);
3699               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3700                                           &type_print_raw_options);
3701
3702               if (symtab != NULL)
3703                 printf_filtered (is_enumeral
3704                                  ? _(" in %s (enumeral)\n")
3705                                  : _(" at %s:?\n"),
3706                                  symtab_to_filename_for_display (symtab));
3707               else
3708                 printf_filtered (is_enumeral
3709                                  ? _(" (enumeral)\n")
3710                                  : _(" at ?\n"));
3711             }
3712         }
3713     }
3714
3715   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3716                              "overload-choice");
3717
3718   for (i = 0; i < n_chosen; i += 1)
3719     syms[i] = syms[chosen[i]];
3720
3721   return n_chosen;
3722 }
3723
3724 /* See ada-lang.h.  */
3725
3726 block_symbol
3727 ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
3728                           int nargs, value *argvec[])
3729 {
3730   if (possible_user_operator_p (op, argvec))
3731     {
3732       std::vector<struct block_symbol> candidates
3733         = ada_lookup_symbol_list (ada_decoded_op_name (op),
3734                                   NULL, VAR_DOMAIN);
3735
3736       int i = ada_resolve_function (candidates, argvec,
3737                                     nargs, ada_decoded_op_name (op), NULL,
3738                                     parse_completion);
3739       if (i >= 0)
3740         return candidates[i];
3741     }
3742   return {};
3743 }
3744
3745 /* See ada-lang.h.  */
3746
3747 block_symbol
3748 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3749                      struct type *context_type,
3750                      bool parse_completion,
3751                      int nargs, value *argvec[],
3752                      innermost_block_tracker *tracker)
3753 {
3754   std::vector<struct block_symbol> candidates
3755     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3756
3757   int i;
3758   if (candidates.size () == 1)
3759     i = 0;
3760   else
3761     {
3762       i = ada_resolve_function
3763         (candidates,
3764          argvec, nargs,
3765          sym->linkage_name (),
3766          context_type, parse_completion);
3767       if (i < 0)
3768         error (_("Could not find a match for %s"), sym->print_name ());
3769     }
3770
3771   tracker->update (candidates[i]);
3772   return candidates[i];
3773 }
3774
3775 /* Resolve a mention of a name where the context type is an
3776    enumeration type.  */
3777
3778 static int
3779 ada_resolve_enum (std::vector<struct block_symbol> &syms,
3780                   const char *name, struct type *context_type,
3781                   bool parse_completion)
3782 {
3783   gdb_assert (context_type->code () == TYPE_CODE_ENUM);
3784   context_type = ada_check_typedef (context_type);
3785
3786   for (int i = 0; i < syms.size (); ++i)
3787     {
3788       /* We already know the name matches, so we're just looking for
3789          an element of the correct enum type.  */
3790       if (ada_check_typedef (syms[i].symbol->type ()) == context_type)
3791         return i;
3792     }
3793
3794   error (_("No name '%s' in enumeration type '%s'"), name,
3795          ada_type_name (context_type));
3796 }
3797
3798 /* See ada-lang.h.  */
3799
3800 block_symbol
3801 ada_resolve_variable (struct symbol *sym, const struct block *block,
3802                       struct type *context_type,
3803                       bool parse_completion,
3804                       int deprocedure_p,
3805                       innermost_block_tracker *tracker)
3806 {
3807   std::vector<struct block_symbol> candidates
3808     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3809
3810   if (std::any_of (candidates.begin (),
3811                    candidates.end (),
3812                    [] (block_symbol &bsym)
3813                    {
3814                      switch (bsym.symbol->aclass ())
3815                        {
3816                        case LOC_REGISTER:
3817                        case LOC_ARG:
3818                        case LOC_REF_ARG:
3819                        case LOC_REGPARM_ADDR:
3820                        case LOC_LOCAL:
3821                        case LOC_COMPUTED:
3822                          return true;
3823                        default:
3824                          return false;
3825                        }
3826                    }))
3827     {
3828       /* Types tend to get re-introduced locally, so if there
3829          are any local symbols that are not types, first filter
3830          out all types.  */
3831       candidates.erase
3832         (std::remove_if
3833          (candidates.begin (),
3834           candidates.end (),
3835           [] (block_symbol &bsym)
3836           {
3837             return bsym.symbol->aclass () == LOC_TYPEDEF;
3838           }),
3839          candidates.end ());
3840     }
3841
3842   /* Filter out artificial symbols.  */
3843   candidates.erase
3844     (std::remove_if
3845      (candidates.begin (),
3846       candidates.end (),
3847       [] (block_symbol &bsym)
3848       {
3849        return bsym.symbol->artificial;
3850       }),
3851      candidates.end ());
3852
3853   int i;
3854   if (candidates.empty ())
3855     error (_("No definition found for %s"), sym->print_name ());
3856   else if (candidates.size () == 1)
3857     i = 0;
3858   else if (context_type != nullptr
3859            && context_type->code () == TYPE_CODE_ENUM)
3860     i = ada_resolve_enum (candidates, sym->linkage_name (), context_type,
3861                           parse_completion);
3862   else if (deprocedure_p && !is_nonfunction (candidates))
3863     {
3864       i = ada_resolve_function
3865         (candidates, NULL, 0,
3866          sym->linkage_name (),
3867          context_type, parse_completion);
3868       if (i < 0)
3869         error (_("Could not find a match for %s"), sym->print_name ());
3870     }
3871   else
3872     {
3873       printf_filtered (_("Multiple matches for %s\n"), sym->print_name ());
3874       user_select_syms (candidates.data (), candidates.size (), 1);
3875       i = 0;
3876     }
3877
3878   tracker->update (candidates[i]);
3879   return candidates[i];
3880 }
3881
3882 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  */
3883 /* The term "match" here is rather loose.  The match is heuristic and
3884    liberal.  */
3885
3886 static int
3887 ada_type_match (struct type *ftype, struct type *atype)
3888 {
3889   ftype = ada_check_typedef (ftype);
3890   atype = ada_check_typedef (atype);
3891
3892   if (ftype->code () == TYPE_CODE_REF)
3893     ftype = TYPE_TARGET_TYPE (ftype);
3894   if (atype->code () == TYPE_CODE_REF)
3895     atype = TYPE_TARGET_TYPE (atype);
3896
3897   switch (ftype->code ())
3898     {
3899     default:
3900       return ftype->code () == atype->code ();
3901     case TYPE_CODE_PTR:
3902       if (atype->code () != TYPE_CODE_PTR)
3903         return 0;
3904       atype = TYPE_TARGET_TYPE (atype);
3905       /* This can only happen if the actual argument is 'null'.  */
3906       if (atype->code () == TYPE_CODE_INT && TYPE_LENGTH (atype) == 0)
3907         return 1;
3908       return ada_type_match (TYPE_TARGET_TYPE (ftype), atype);
3909     case TYPE_CODE_INT:
3910     case TYPE_CODE_ENUM:
3911     case TYPE_CODE_RANGE:
3912       switch (atype->code ())
3913         {
3914         case TYPE_CODE_INT:
3915         case TYPE_CODE_ENUM:
3916         case TYPE_CODE_RANGE:
3917           return 1;
3918         default:
3919           return 0;
3920         }
3921
3922     case TYPE_CODE_ARRAY:
3923       return (atype->code () == TYPE_CODE_ARRAY
3924               || ada_is_array_descriptor_type (atype));
3925
3926     case TYPE_CODE_STRUCT:
3927       if (ada_is_array_descriptor_type (ftype))
3928         return (atype->code () == TYPE_CODE_ARRAY
3929                 || ada_is_array_descriptor_type (atype));
3930       else
3931         return (atype->code () == TYPE_CODE_STRUCT
3932                 && !ada_is_array_descriptor_type (atype));
3933
3934     case TYPE_CODE_UNION:
3935     case TYPE_CODE_FLT:
3936       return (atype->code () == ftype->code ());
3937     }
3938 }
3939
3940 /* Return non-zero if the formals of FUNC "sufficiently match" the
3941    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3942    may also be an enumeral, in which case it is treated as a 0-
3943    argument function.  */
3944
3945 static int
3946 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3947 {
3948   int i;
3949   struct type *func_type = func->type ();
3950
3951   if (func->aclass () == LOC_CONST
3952       && func_type->code () == TYPE_CODE_ENUM)
3953     return (n_actuals == 0);
3954   else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3955     return 0;
3956
3957   if (func_type->num_fields () != n_actuals)
3958     return 0;
3959
3960   for (i = 0; i < n_actuals; i += 1)
3961     {
3962       if (actuals[i] == NULL)
3963         return 0;
3964       else
3965         {
3966           struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3967           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3968
3969           if (!ada_type_match (ftype, atype))
3970             return 0;
3971         }
3972     }
3973   return 1;
3974 }
3975
3976 /* False iff function type FUNC_TYPE definitely does not produce a value
3977    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3978    FUNC_TYPE is not a valid function type with a non-null return type
3979    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3980
3981 static int
3982 return_match (struct type *func_type, struct type *context_type)
3983 {
3984   struct type *return_type;
3985
3986   if (func_type == NULL)
3987     return 1;
3988
3989   if (func_type->code () == TYPE_CODE_FUNC)
3990     return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3991   else
3992     return_type = get_base_type (func_type);
3993   if (return_type == NULL)
3994     return 1;
3995
3996   context_type = get_base_type (context_type);
3997
3998   if (return_type->code () == TYPE_CODE_ENUM)
3999     return context_type == NULL || return_type == context_type;
4000   else if (context_type == NULL)
4001     return return_type->code () != TYPE_CODE_VOID;
4002   else
4003     return return_type->code () == context_type->code ();
4004 }
4005
4006
4007 /* Returns the index in SYMS that contains the symbol for the
4008    function (if any) that matches the types of the NARGS arguments in
4009    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
4010    that returns that type, then eliminate matches that don't.  If
4011    CONTEXT_TYPE is void and there is at least one match that does not
4012    return void, eliminate all matches that do.
4013
4014    Asks the user if there is more than one match remaining.  Returns -1
4015    if there is no such symbol or none is selected.  NAME is used
4016    solely for messages.  May re-arrange and modify SYMS in
4017    the process; the index returned is for the modified vector.  */
4018
4019 static int
4020 ada_resolve_function (std::vector<struct block_symbol> &syms,
4021                       struct value **args, int nargs,
4022                       const char *name, struct type *context_type,
4023                       bool parse_completion)
4024 {
4025   int fallback;
4026   int k;
4027   int m;                        /* Number of hits */
4028
4029   m = 0;
4030   /* In the first pass of the loop, we only accept functions matching
4031      context_type.  If none are found, we add a second pass of the loop
4032      where every function is accepted.  */
4033   for (fallback = 0; m == 0 && fallback < 2; fallback++)
4034     {
4035       for (k = 0; k < syms.size (); k += 1)
4036         {
4037           struct type *type = ada_check_typedef (syms[k].symbol->type ());
4038
4039           if (ada_args_match (syms[k].symbol, args, nargs)
4040               && (fallback || return_match (type, context_type)))
4041             {
4042               syms[m] = syms[k];
4043               m += 1;
4044             }
4045         }
4046     }
4047
4048   /* If we got multiple matches, ask the user which one to use.  Don't do this
4049      interactive thing during completion, though, as the purpose of the
4050      completion is providing a list of all possible matches.  Prompting the
4051      user to filter it down would be completely unexpected in this case.  */
4052   if (m == 0)
4053     return -1;
4054   else if (m > 1 && !parse_completion)
4055     {
4056       printf_filtered (_("Multiple matches for %s\n"), name);
4057       user_select_syms (syms.data (), m, 1);
4058       return 0;
4059     }
4060   return 0;
4061 }
4062
4063 /* Type-class predicates */
4064
4065 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4066    or FLOAT).  */
4067
4068 static int
4069 numeric_type_p (struct type *type)
4070 {
4071   if (type == NULL)
4072     return 0;
4073   else
4074     {
4075       switch (type->code ())
4076         {
4077         case TYPE_CODE_INT:
4078         case TYPE_CODE_FLT:
4079         case TYPE_CODE_FIXED_POINT:
4080           return 1;
4081         case TYPE_CODE_RANGE:
4082           return (type == TYPE_TARGET_TYPE (type)
4083                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
4084         default:
4085           return 0;
4086         }
4087     }
4088 }
4089
4090 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
4091
4092 static int
4093 integer_type_p (struct type *type)
4094 {
4095   if (type == NULL)
4096     return 0;
4097   else
4098     {
4099       switch (type->code ())
4100         {
4101         case TYPE_CODE_INT:
4102           return 1;
4103         case TYPE_CODE_RANGE:
4104           return (type == TYPE_TARGET_TYPE (type)
4105                   || integer_type_p (TYPE_TARGET_TYPE (type)));
4106         default:
4107           return 0;
4108         }
4109     }
4110 }
4111
4112 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
4113
4114 static int
4115 scalar_type_p (struct type *type)
4116 {
4117   if (type == NULL)
4118     return 0;
4119   else
4120     {
4121       switch (type->code ())
4122         {
4123         case TYPE_CODE_INT:
4124         case TYPE_CODE_RANGE:
4125         case TYPE_CODE_ENUM:
4126         case TYPE_CODE_FLT:
4127         case TYPE_CODE_FIXED_POINT:
4128           return 1;
4129         default:
4130           return 0;
4131         }
4132     }
4133 }
4134
4135 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
4136
4137 static int
4138 discrete_type_p (struct type *type)
4139 {
4140   if (type == NULL)
4141     return 0;
4142   else
4143     {
4144       switch (type->code ())
4145         {
4146         case TYPE_CODE_INT:
4147         case TYPE_CODE_RANGE:
4148         case TYPE_CODE_ENUM:
4149         case TYPE_CODE_BOOL:
4150           return 1;
4151         default:
4152           return 0;
4153         }
4154     }
4155 }
4156
4157 /* Returns non-zero if OP with operands in the vector ARGS could be
4158    a user-defined function.  Errs on the side of pre-defined operators
4159    (i.e., result 0).  */
4160
4161 static int
4162 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4163 {
4164   struct type *type0 =
4165     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4166   struct type *type1 =
4167     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4168
4169   if (type0 == NULL)
4170     return 0;
4171
4172   switch (op)
4173     {
4174     default:
4175       return 0;
4176
4177     case BINOP_ADD:
4178     case BINOP_SUB:
4179     case BINOP_MUL:
4180     case BINOP_DIV:
4181       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4182
4183     case BINOP_REM:
4184     case BINOP_MOD:
4185     case BINOP_BITWISE_AND:
4186     case BINOP_BITWISE_IOR:
4187     case BINOP_BITWISE_XOR:
4188       return (!(integer_type_p (type0) && integer_type_p (type1)));
4189
4190     case BINOP_EQUAL:
4191     case BINOP_NOTEQUAL:
4192     case BINOP_LESS:
4193     case BINOP_GTR:
4194     case BINOP_LEQ:
4195     case BINOP_GEQ:
4196       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4197
4198     case BINOP_CONCAT:
4199       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4200
4201     case BINOP_EXP:
4202       return (!(numeric_type_p (type0) && integer_type_p (type1)));
4203
4204     case UNOP_NEG:
4205     case UNOP_PLUS:
4206     case UNOP_LOGICAL_NOT:
4207     case UNOP_ABS:
4208       return (!numeric_type_p (type0));
4209
4210     }
4211 }
4212 \f
4213                                 /* Renaming */
4214
4215 /* NOTES: 
4216
4217    1. In the following, we assume that a renaming type's name may
4218       have an ___XD suffix.  It would be nice if this went away at some
4219       point.
4220    2. We handle both the (old) purely type-based representation of 
4221       renamings and the (new) variable-based encoding.  At some point,
4222       it is devoutly to be hoped that the former goes away 
4223       (FIXME: hilfinger-2007-07-09).
4224    3. Subprogram renamings are not implemented, although the XRS
4225       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
4226
4227 /* If SYM encodes a renaming, 
4228
4229        <renaming> renames <renamed entity>,
4230
4231    sets *LEN to the length of the renamed entity's name,
4232    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4233    the string describing the subcomponent selected from the renamed
4234    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4235    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4236    are undefined).  Otherwise, returns a value indicating the category
4237    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4238    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4239    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
4240    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4241    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4242    may be NULL, in which case they are not assigned.
4243
4244    [Currently, however, GCC does not generate subprogram renamings.]  */
4245
4246 enum ada_renaming_category
4247 ada_parse_renaming (struct symbol *sym,
4248                     const char **renamed_entity, int *len, 
4249                     const char **renaming_expr)
4250 {
4251   enum ada_renaming_category kind;
4252   const char *info;
4253   const char *suffix;
4254
4255   if (sym == NULL)
4256     return ADA_NOT_RENAMING;
4257   switch (sym->aclass ()) 
4258     {
4259     default:
4260       return ADA_NOT_RENAMING;
4261     case LOC_LOCAL:
4262     case LOC_STATIC:
4263     case LOC_COMPUTED:
4264     case LOC_OPTIMIZED_OUT:
4265       info = strstr (sym->linkage_name (), "___XR");
4266       if (info == NULL)
4267         return ADA_NOT_RENAMING;
4268       switch (info[5])
4269         {
4270         case '_':
4271           kind = ADA_OBJECT_RENAMING;
4272           info += 6;
4273           break;
4274         case 'E':
4275           kind = ADA_EXCEPTION_RENAMING;
4276           info += 7;
4277           break;
4278         case 'P':
4279           kind = ADA_PACKAGE_RENAMING;
4280           info += 7;
4281           break;
4282         case 'S':
4283           kind = ADA_SUBPROGRAM_RENAMING;
4284           info += 7;
4285           break;
4286         default:
4287           return ADA_NOT_RENAMING;
4288         }
4289     }
4290
4291   if (renamed_entity != NULL)
4292     *renamed_entity = info;
4293   suffix = strstr (info, "___XE");
4294   if (suffix == NULL || suffix == info)
4295     return ADA_NOT_RENAMING;
4296   if (len != NULL)
4297     *len = strlen (info) - strlen (suffix);
4298   suffix += 5;
4299   if (renaming_expr != NULL)
4300     *renaming_expr = suffix;
4301   return kind;
4302 }
4303
4304 /* Compute the value of the given RENAMING_SYM, which is expected to
4305    be a symbol encoding a renaming expression.  BLOCK is the block
4306    used to evaluate the renaming.  */
4307
4308 static struct value *
4309 ada_read_renaming_var_value (struct symbol *renaming_sym,
4310                              const struct block *block)
4311 {
4312   const char *sym_name;
4313
4314   sym_name = renaming_sym->linkage_name ();
4315   expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4316   return evaluate_expression (expr.get ());
4317 }
4318 \f
4319
4320                                 /* Evaluation: Function Calls */
4321
4322 /* Return an lvalue containing the value VAL.  This is the identity on
4323    lvalues, and otherwise has the side-effect of allocating memory
4324    in the inferior where a copy of the value contents is copied.  */
4325
4326 static struct value *
4327 ensure_lval (struct value *val)
4328 {
4329   if (VALUE_LVAL (val) == not_lval
4330       || VALUE_LVAL (val) == lval_internalvar)
4331     {
4332       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4333       const CORE_ADDR addr =
4334         value_as_long (value_allocate_space_in_inferior (len));
4335
4336       VALUE_LVAL (val) = lval_memory;
4337       set_value_address (val, addr);
4338       write_memory (addr, value_contents (val).data (), len);
4339     }
4340
4341   return val;
4342 }
4343
4344 /* Given ARG, a value of type (pointer or reference to a)*
4345    structure/union, extract the component named NAME from the ultimate
4346    target structure/union and return it as a value with its
4347    appropriate type.
4348
4349    The routine searches for NAME among all members of the structure itself
4350    and (recursively) among all members of any wrapper members
4351    (e.g., '_parent').
4352
4353    If NO_ERR, then simply return NULL in case of error, rather than
4354    calling error.  */
4355
4356 static struct value *
4357 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
4358 {
4359   struct type *t, *t1;
4360   struct value *v;
4361   int check_tag;
4362
4363   v = NULL;
4364   t1 = t = ada_check_typedef (value_type (arg));
4365   if (t->code () == TYPE_CODE_REF)
4366     {
4367       t1 = TYPE_TARGET_TYPE (t);
4368       if (t1 == NULL)
4369         goto BadValue;
4370       t1 = ada_check_typedef (t1);
4371       if (t1->code () == TYPE_CODE_PTR)
4372         {
4373           arg = coerce_ref (arg);
4374           t = t1;
4375         }
4376     }
4377
4378   while (t->code () == TYPE_CODE_PTR)
4379     {
4380       t1 = TYPE_TARGET_TYPE (t);
4381       if (t1 == NULL)
4382         goto BadValue;
4383       t1 = ada_check_typedef (t1);
4384       if (t1->code () == TYPE_CODE_PTR)
4385         {
4386           arg = value_ind (arg);
4387           t = t1;
4388         }
4389       else
4390         break;
4391     }
4392
4393   if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4394     goto BadValue;
4395
4396   if (t1 == t)
4397     v = ada_search_struct_field (name, arg, 0, t);
4398   else
4399     {
4400       int bit_offset, bit_size, byte_offset;
4401       struct type *field_type;
4402       CORE_ADDR address;
4403
4404       if (t->code () == TYPE_CODE_PTR)
4405         address = value_address (ada_value_ind (arg));
4406       else
4407         address = value_address (ada_coerce_ref (arg));
4408
4409       /* Check to see if this is a tagged type.  We also need to handle
4410          the case where the type is a reference to a tagged type, but
4411          we have to be careful to exclude pointers to tagged types.
4412          The latter should be shown as usual (as a pointer), whereas
4413          a reference should mostly be transparent to the user.  */
4414
4415       if (ada_is_tagged_type (t1, 0)
4416           || (t1->code () == TYPE_CODE_REF
4417               && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
4418         {
4419           /* We first try to find the searched field in the current type.
4420              If not found then let's look in the fixed type.  */
4421
4422           if (!find_struct_field (name, t1, 0,
4423                                   nullptr, nullptr, nullptr,
4424                                   nullptr, nullptr))
4425             check_tag = 1;
4426           else
4427             check_tag = 0;
4428         }
4429       else
4430         check_tag = 0;
4431
4432       /* Convert to fixed type in all cases, so that we have proper
4433          offsets to each field in unconstrained record types.  */
4434       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4435                               address, NULL, check_tag);
4436
4437       /* Resolve the dynamic type as well.  */
4438       arg = value_from_contents_and_address (t1, nullptr, address);
4439       t1 = value_type (arg);
4440
4441       if (find_struct_field (name, t1, 0,
4442                              &field_type, &byte_offset, &bit_offset,
4443                              &bit_size, NULL))
4444         {
4445           if (bit_size != 0)
4446             {
4447               if (t->code () == TYPE_CODE_REF)
4448                 arg = ada_coerce_ref (arg);
4449               else
4450                 arg = ada_value_ind (arg);
4451               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4452                                                   bit_offset, bit_size,
4453                                                   field_type);
4454             }
4455           else
4456             v = value_at_lazy (field_type, address + byte_offset);
4457         }
4458     }
4459
4460   if (v != NULL || no_err)
4461     return v;
4462   else
4463     error (_("There is no member named %s."), name);
4464
4465  BadValue:
4466   if (no_err)
4467     return NULL;
4468   else
4469     error (_("Attempt to extract a component of "
4470              "a value that is not a record."));
4471 }
4472
4473 /* Return the value ACTUAL, converted to be an appropriate value for a
4474    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4475    allocating any necessary descriptors (fat pointers), or copies of
4476    values not residing in memory, updating it as needed.  */
4477
4478 struct value *
4479 ada_convert_actual (struct value *actual, struct type *formal_type0)
4480 {
4481   struct type *actual_type = ada_check_typedef (value_type (actual));
4482   struct type *formal_type = ada_check_typedef (formal_type0);
4483   struct type *formal_target =
4484     formal_type->code () == TYPE_CODE_PTR
4485     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4486   struct type *actual_target =
4487     actual_type->code () == TYPE_CODE_PTR
4488     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4489
4490   if (ada_is_array_descriptor_type (formal_target)
4491       && actual_target->code () == TYPE_CODE_ARRAY)
4492     return make_array_descriptor (formal_type, actual);
4493   else if (formal_type->code () == TYPE_CODE_PTR
4494            || formal_type->code () == TYPE_CODE_REF)
4495     {
4496       struct value *result;
4497
4498       if (formal_target->code () == TYPE_CODE_ARRAY
4499           && ada_is_array_descriptor_type (actual_target))
4500         result = desc_data (actual);
4501       else if (formal_type->code () != TYPE_CODE_PTR)
4502         {
4503           if (VALUE_LVAL (actual) != lval_memory)
4504             {
4505               struct value *val;
4506
4507               actual_type = ada_check_typedef (value_type (actual));
4508               val = allocate_value (actual_type);
4509               copy (value_contents (actual), value_contents_raw (val));
4510               actual = ensure_lval (val);
4511             }
4512           result = value_addr (actual);
4513         }
4514       else
4515         return actual;
4516       return value_cast_pointers (formal_type, result, 0);
4517     }
4518   else if (actual_type->code () == TYPE_CODE_PTR)
4519     return ada_value_ind (actual);
4520   else if (ada_is_aligner_type (formal_type))
4521     {
4522       /* We need to turn this parameter into an aligner type
4523          as well.  */
4524       struct value *aligner = allocate_value (formal_type);
4525       struct value *component = ada_value_struct_elt (aligner, "F", 0);
4526
4527       value_assign_to_component (aligner, component, actual);
4528       return aligner;
4529     }
4530
4531   return actual;
4532 }
4533
4534 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4535    type TYPE.  This is usually an inefficient no-op except on some targets
4536    (such as AVR) where the representation of a pointer and an address
4537    differs.  */
4538
4539 static CORE_ADDR
4540 value_pointer (struct value *value, struct type *type)
4541 {
4542   unsigned len = TYPE_LENGTH (type);
4543   gdb_byte *buf = (gdb_byte *) alloca (len);
4544   CORE_ADDR addr;
4545
4546   addr = value_address (value);
4547   gdbarch_address_to_pointer (type->arch (), type, buf, addr);
4548   addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4549   return addr;
4550 }
4551
4552
4553 /* Push a descriptor of type TYPE for array value ARR on the stack at
4554    *SP, updating *SP to reflect the new descriptor.  Return either
4555    an lvalue representing the new descriptor, or (if TYPE is a pointer-
4556    to-descriptor type rather than a descriptor type), a struct value *
4557    representing a pointer to this descriptor.  */
4558
4559 static struct value *
4560 make_array_descriptor (struct type *type, struct value *arr)
4561 {
4562   struct type *bounds_type = desc_bounds_type (type);
4563   struct type *desc_type = desc_base_type (type);
4564   struct value *descriptor = allocate_value (desc_type);
4565   struct value *bounds = allocate_value (bounds_type);
4566   int i;
4567
4568   for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4569        i > 0; i -= 1)
4570     {
4571       modify_field (value_type (bounds),
4572                     value_contents_writeable (bounds).data (),
4573                     ada_array_bound (arr, i, 0),
4574                     desc_bound_bitpos (bounds_type, i, 0),
4575                     desc_bound_bitsize (bounds_type, i, 0));
4576       modify_field (value_type (bounds),
4577                     value_contents_writeable (bounds).data (),
4578                     ada_array_bound (arr, i, 1),
4579                     desc_bound_bitpos (bounds_type, i, 1),
4580                     desc_bound_bitsize (bounds_type, i, 1));
4581     }
4582
4583   bounds = ensure_lval (bounds);
4584
4585   modify_field (value_type (descriptor),
4586                 value_contents_writeable (descriptor).data (),
4587                 value_pointer (ensure_lval (arr),
4588                                desc_type->field (0).type ()),
4589                 fat_pntr_data_bitpos (desc_type),
4590                 fat_pntr_data_bitsize (desc_type));
4591
4592   modify_field (value_type (descriptor),
4593                 value_contents_writeable (descriptor).data (),
4594                 value_pointer (bounds,
4595                                desc_type->field (1).type ()),
4596                 fat_pntr_bounds_bitpos (desc_type),
4597                 fat_pntr_bounds_bitsize (desc_type));
4598
4599   descriptor = ensure_lval (descriptor);
4600
4601   if (type->code () == TYPE_CODE_PTR)
4602     return value_addr (descriptor);
4603   else
4604     return descriptor;
4605 }
4606 \f
4607                                 /* Symbol Cache Module */
4608
4609 /* Performance measurements made as of 2010-01-15 indicate that
4610    this cache does bring some noticeable improvements.  Depending
4611    on the type of entity being printed, the cache can make it as much
4612    as an order of magnitude faster than without it.
4613
4614    The descriptive type DWARF extension has significantly reduced
4615    the need for this cache, at least when DWARF is being used.  However,
4616    even in this case, some expensive name-based symbol searches are still
4617    sometimes necessary - to find an XVZ variable, mostly.  */
4618
4619 /* Return the symbol cache associated to the given program space PSPACE.
4620    If not allocated for this PSPACE yet, allocate and initialize one.  */
4621
4622 static struct ada_symbol_cache *
4623 ada_get_symbol_cache (struct program_space *pspace)
4624 {
4625   struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4626
4627   if (pspace_data->sym_cache == nullptr)
4628     pspace_data->sym_cache.reset (new ada_symbol_cache);
4629
4630   return pspace_data->sym_cache.get ();
4631 }
4632
4633 /* Clear all entries from the symbol cache.  */
4634
4635 static void
4636 ada_clear_symbol_cache ()
4637 {
4638   struct ada_pspace_data *pspace_data
4639     = get_ada_pspace_data (current_program_space);
4640
4641   if (pspace_data->sym_cache != nullptr)
4642     pspace_data->sym_cache.reset ();
4643 }
4644
4645 /* Search our cache for an entry matching NAME and DOMAIN.
4646    Return it if found, or NULL otherwise.  */
4647
4648 static struct cache_entry **
4649 find_entry (const char *name, domain_enum domain)
4650 {
4651   struct ada_symbol_cache *sym_cache
4652     = ada_get_symbol_cache (current_program_space);
4653   int h = msymbol_hash (name) % HASH_SIZE;
4654   struct cache_entry **e;
4655
4656   for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4657     {
4658       if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4659         return e;
4660     }
4661   return NULL;
4662 }
4663
4664 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4665    Return 1 if found, 0 otherwise.
4666
4667    If an entry was found and SYM is not NULL, set *SYM to the entry's
4668    SYM.  Same principle for BLOCK if not NULL.  */
4669
4670 static int
4671 lookup_cached_symbol (const char *name, domain_enum domain,
4672                       struct symbol **sym, const struct block **block)
4673 {
4674   struct cache_entry **e = find_entry (name, domain);
4675
4676   if (e == NULL)
4677     return 0;
4678   if (sym != NULL)
4679     *sym = (*e)->sym;
4680   if (block != NULL)
4681     *block = (*e)->block;
4682   return 1;
4683 }
4684
4685 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4686    in domain DOMAIN, save this result in our symbol cache.  */
4687
4688 static void
4689 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4690               const struct block *block)
4691 {
4692   struct ada_symbol_cache *sym_cache
4693     = ada_get_symbol_cache (current_program_space);
4694   int h;
4695   struct cache_entry *e;
4696
4697   /* Symbols for builtin types don't have a block.
4698      For now don't cache such symbols.  */
4699   if (sym != NULL && !sym->is_objfile_owned ())
4700     return;
4701
4702   /* If the symbol is a local symbol, then do not cache it, as a search
4703      for that symbol depends on the context.  To determine whether
4704      the symbol is local or not, we check the block where we found it
4705      against the global and static blocks of its associated symtab.  */
4706   if (sym
4707       && BLOCKVECTOR_BLOCK (symbol_symtab (sym)->blockvector (),
4708                             GLOBAL_BLOCK) != block
4709       && BLOCKVECTOR_BLOCK (symbol_symtab (sym)->blockvector (),
4710                             STATIC_BLOCK) != block)
4711     return;
4712
4713   h = msymbol_hash (name) % HASH_SIZE;
4714   e = XOBNEW (&sym_cache->cache_space, cache_entry);
4715   e->next = sym_cache->root[h];
4716   sym_cache->root[h] = e;
4717   e->name = obstack_strdup (&sym_cache->cache_space, name);
4718   e->sym = sym;
4719   e->domain = domain;
4720   e->block = block;
4721 }
4722 \f
4723                                 /* Symbol Lookup */
4724
4725 /* Return the symbol name match type that should be used used when
4726    searching for all symbols matching LOOKUP_NAME.
4727
4728    LOOKUP_NAME is expected to be a symbol name after transformation
4729    for Ada lookups.  */
4730
4731 static symbol_name_match_type
4732 name_match_type_from_name (const char *lookup_name)
4733 {
4734   return (strstr (lookup_name, "__") == NULL
4735           ? symbol_name_match_type::WILD
4736           : symbol_name_match_type::FULL);
4737 }
4738
4739 /* Return the result of a standard (literal, C-like) lookup of NAME in
4740    given DOMAIN, visible from lexical block BLOCK.  */
4741
4742 static struct symbol *
4743 standard_lookup (const char *name, const struct block *block,
4744                  domain_enum domain)
4745 {
4746   /* Initialize it just to avoid a GCC false warning.  */
4747   struct block_symbol sym = {};
4748
4749   if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4750     return sym.symbol;
4751   ada_lookup_encoded_symbol (name, block, domain, &sym);
4752   cache_symbol (name, domain, sym.symbol, sym.block);
4753   return sym.symbol;
4754 }
4755
4756
4757 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4758    in the symbol fields of SYMS.  We treat enumerals as functions, 
4759    since they contend in overloading in the same way.  */
4760 static int
4761 is_nonfunction (const std::vector<struct block_symbol> &syms)
4762 {
4763   for (const block_symbol &sym : syms)
4764     if (sym.symbol->type ()->code () != TYPE_CODE_FUNC
4765         && (sym.symbol->type ()->code () != TYPE_CODE_ENUM
4766             || sym.symbol->aclass () != LOC_CONST))
4767       return 1;
4768
4769   return 0;
4770 }
4771
4772 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4773    struct types.  Otherwise, they may not.  */
4774
4775 static int
4776 equiv_types (struct type *type0, struct type *type1)
4777 {
4778   if (type0 == type1)
4779     return 1;
4780   if (type0 == NULL || type1 == NULL
4781       || type0->code () != type1->code ())
4782     return 0;
4783   if ((type0->code () == TYPE_CODE_STRUCT
4784        || type0->code () == TYPE_CODE_ENUM)
4785       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4786       && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4787     return 1;
4788
4789   return 0;
4790 }
4791
4792 /* True iff SYM0 represents the same entity as SYM1, or one that is
4793    no more defined than that of SYM1.  */
4794
4795 static int
4796 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4797 {
4798   if (sym0 == sym1)
4799     return 1;
4800   if (sym0->domain () != sym1->domain ()
4801       || sym0->aclass () != sym1->aclass ())
4802     return 0;
4803
4804   switch (sym0->aclass ())
4805     {
4806     case LOC_UNDEF:
4807       return 1;
4808     case LOC_TYPEDEF:
4809       {
4810         struct type *type0 = sym0->type ();
4811         struct type *type1 = sym1->type ();
4812         const char *name0 = sym0->linkage_name ();
4813         const char *name1 = sym1->linkage_name ();
4814         int len0 = strlen (name0);
4815
4816         return
4817           type0->code () == type1->code ()
4818           && (equiv_types (type0, type1)
4819               || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4820                   && startswith (name1 + len0, "___XV")));
4821       }
4822     case LOC_CONST:
4823       return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4824         && equiv_types (sym0->type (), sym1->type ());
4825
4826     case LOC_STATIC:
4827       {
4828         const char *name0 = sym0->linkage_name ();
4829         const char *name1 = sym1->linkage_name ();
4830         return (strcmp (name0, name1) == 0
4831                 && SYMBOL_VALUE_ADDRESS (sym0) == SYMBOL_VALUE_ADDRESS (sym1));
4832       }
4833
4834     default:
4835       return 0;
4836     }
4837 }
4838
4839 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4840    records in RESULT.  Do nothing if SYM is a duplicate.  */
4841
4842 static void
4843 add_defn_to_vec (std::vector<struct block_symbol> &result,
4844                  struct symbol *sym,
4845                  const struct block *block)
4846 {
4847   /* Do not try to complete stub types, as the debugger is probably
4848      already scanning all symbols matching a certain name at the
4849      time when this function is called.  Trying to replace the stub
4850      type by its associated full type will cause us to restart a scan
4851      which may lead to an infinite recursion.  Instead, the client
4852      collecting the matching symbols will end up collecting several
4853      matches, with at least one of them complete.  It can then filter
4854      out the stub ones if needed.  */
4855
4856   for (int i = result.size () - 1; i >= 0; i -= 1)
4857     {
4858       if (lesseq_defined_than (sym, result[i].symbol))
4859         return;
4860       else if (lesseq_defined_than (result[i].symbol, sym))
4861         {
4862           result[i].symbol = sym;
4863           result[i].block = block;
4864           return;
4865         }
4866     }
4867
4868   struct block_symbol info;
4869   info.symbol = sym;
4870   info.block = block;
4871   result.push_back (info);
4872 }
4873
4874 /* Return a bound minimal symbol matching NAME according to Ada
4875    decoding rules.  Returns an invalid symbol if there is no such
4876    minimal symbol.  Names prefixed with "standard__" are handled
4877    specially: "standard__" is first stripped off, and only static and
4878    global symbols are searched.  */
4879
4880 struct bound_minimal_symbol
4881 ada_lookup_simple_minsym (const char *name)
4882 {
4883   struct bound_minimal_symbol result;
4884
4885   symbol_name_match_type match_type = name_match_type_from_name (name);
4886   lookup_name_info lookup_name (name, match_type);
4887
4888   symbol_name_matcher_ftype *match_name
4889     = ada_get_symbol_name_matcher (lookup_name);
4890
4891   for (objfile *objfile : current_program_space->objfiles ())
4892     {
4893       for (minimal_symbol *msymbol : objfile->msymbols ())
4894         {
4895           if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4896               && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4897             {
4898               result.minsym = msymbol;
4899               result.objfile = objfile;
4900               break;
4901             }
4902         }
4903     }
4904
4905   return result;
4906 }
4907
4908 /* True if TYPE is definitely an artificial type supplied to a symbol
4909    for which no debugging information was given in the symbol file.  */
4910
4911 static int
4912 is_nondebugging_type (struct type *type)
4913 {
4914   const char *name = ada_type_name (type);
4915
4916   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4917 }
4918
4919 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4920    that are deemed "identical" for practical purposes.
4921
4922    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4923    types and that their number of enumerals is identical (in other
4924    words, type1->num_fields () == type2->num_fields ()).  */
4925
4926 static int
4927 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4928 {
4929   int i;
4930
4931   /* The heuristic we use here is fairly conservative.  We consider
4932      that 2 enumerate types are identical if they have the same
4933      number of enumerals and that all enumerals have the same
4934      underlying value and name.  */
4935
4936   /* All enums in the type should have an identical underlying value.  */
4937   for (i = 0; i < type1->num_fields (); i++)
4938     if (type1->field (i).loc_enumval () != type2->field (i).loc_enumval ())
4939       return 0;
4940
4941   /* All enumerals should also have the same name (modulo any numerical
4942      suffix).  */
4943   for (i = 0; i < type1->num_fields (); i++)
4944     {
4945       const char *name_1 = type1->field (i).name ();
4946       const char *name_2 = type2->field (i).name ();
4947       int len_1 = strlen (name_1);
4948       int len_2 = strlen (name_2);
4949
4950       ada_remove_trailing_digits (type1->field (i).name (), &len_1);
4951       ada_remove_trailing_digits (type2->field (i).name (), &len_2);
4952       if (len_1 != len_2
4953           || strncmp (type1->field (i).name (),
4954                       type2->field (i).name (),
4955                       len_1) != 0)
4956         return 0;
4957     }
4958
4959   return 1;
4960 }
4961
4962 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4963    that are deemed "identical" for practical purposes.  Sometimes,
4964    enumerals are not strictly identical, but their types are so similar
4965    that they can be considered identical.
4966
4967    For instance, consider the following code:
4968
4969       type Color is (Black, Red, Green, Blue, White);
4970       type RGB_Color is new Color range Red .. Blue;
4971
4972    Type RGB_Color is a subrange of an implicit type which is a copy
4973    of type Color. If we call that implicit type RGB_ColorB ("B" is
4974    for "Base Type"), then type RGB_ColorB is a copy of type Color.
4975    As a result, when an expression references any of the enumeral
4976    by name (Eg. "print green"), the expression is technically
4977    ambiguous and the user should be asked to disambiguate. But
4978    doing so would only hinder the user, since it wouldn't matter
4979    what choice he makes, the outcome would always be the same.
4980    So, for practical purposes, we consider them as the same.  */
4981
4982 static int
4983 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
4984 {
4985   int i;
4986
4987   /* Before performing a thorough comparison check of each type,
4988      we perform a series of inexpensive checks.  We expect that these
4989      checks will quickly fail in the vast majority of cases, and thus
4990      help prevent the unnecessary use of a more expensive comparison.
4991      Said comparison also expects us to make some of these checks
4992      (see ada_identical_enum_types_p).  */
4993
4994   /* Quick check: All symbols should have an enum type.  */
4995   for (i = 0; i < syms.size (); i++)
4996     if (syms[i].symbol->type ()->code () != TYPE_CODE_ENUM)
4997       return 0;
4998
4999   /* Quick check: They should all have the same value.  */
5000   for (i = 1; i < syms.size (); i++)
5001     if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
5002       return 0;
5003
5004   /* Quick check: They should all have the same number of enumerals.  */
5005   for (i = 1; i < syms.size (); i++)
5006     if (syms[i].symbol->type ()->num_fields ()
5007         != syms[0].symbol->type ()->num_fields ())
5008       return 0;
5009
5010   /* All the sanity checks passed, so we might have a set of
5011      identical enumeration types.  Perform a more complete
5012      comparison of the type of each symbol.  */
5013   for (i = 1; i < syms.size (); i++)
5014     if (!ada_identical_enum_types_p (syms[i].symbol->type (),
5015                                      syms[0].symbol->type ()))
5016       return 0;
5017
5018   return 1;
5019 }
5020
5021 /* Remove any non-debugging symbols in SYMS that definitely
5022    duplicate other symbols in the list (The only case I know of where
5023    this happens is when object files containing stabs-in-ecoff are
5024    linked with files containing ordinary ecoff debugging symbols (or no
5025    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.  */
5026
5027 static void
5028 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5029 {
5030   int i, j;
5031
5032   /* We should never be called with less than 2 symbols, as there
5033      cannot be any extra symbol in that case.  But it's easy to
5034      handle, since we have nothing to do in that case.  */
5035   if (syms->size () < 2)
5036     return;
5037
5038   i = 0;
5039   while (i < syms->size ())
5040     {
5041       int remove_p = 0;
5042
5043       /* If two symbols have the same name and one of them is a stub type,
5044          the get rid of the stub.  */
5045
5046       if ((*syms)[i].symbol->type ()->is_stub ()
5047           && (*syms)[i].symbol->linkage_name () != NULL)
5048         {
5049           for (j = 0; j < syms->size (); j++)
5050             {
5051               if (j != i
5052                   && !(*syms)[j].symbol->type ()->is_stub ()
5053                   && (*syms)[j].symbol->linkage_name () != NULL
5054                   && strcmp ((*syms)[i].symbol->linkage_name (),
5055                              (*syms)[j].symbol->linkage_name ()) == 0)
5056                 remove_p = 1;
5057             }
5058         }
5059
5060       /* Two symbols with the same name, same class and same address
5061          should be identical.  */
5062
5063       else if ((*syms)[i].symbol->linkage_name () != NULL
5064           && (*syms)[i].symbol->aclass () == LOC_STATIC
5065           && is_nondebugging_type ((*syms)[i].symbol->type ()))
5066         {
5067           for (j = 0; j < syms->size (); j += 1)
5068             {
5069               if (i != j
5070                   && (*syms)[j].symbol->linkage_name () != NULL
5071                   && strcmp ((*syms)[i].symbol->linkage_name (),
5072                              (*syms)[j].symbol->linkage_name ()) == 0
5073                   && ((*syms)[i].symbol->aclass ()
5074                       == (*syms)[j].symbol->aclass ())
5075                   && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
5076                   == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
5077                 remove_p = 1;
5078             }
5079         }
5080       
5081       if (remove_p)
5082         syms->erase (syms->begin () + i);
5083       else
5084         i += 1;
5085     }
5086
5087   /* If all the remaining symbols are identical enumerals, then
5088      just keep the first one and discard the rest.
5089
5090      Unlike what we did previously, we do not discard any entry
5091      unless they are ALL identical.  This is because the symbol
5092      comparison is not a strict comparison, but rather a practical
5093      comparison.  If all symbols are considered identical, then
5094      we can just go ahead and use the first one and discard the rest.
5095      But if we cannot reduce the list to a single element, we have
5096      to ask the user to disambiguate anyways.  And if we have to
5097      present a multiple-choice menu, it's less confusing if the list
5098      isn't missing some choices that were identical and yet distinct.  */
5099   if (symbols_are_identical_enums (*syms))
5100     syms->resize (1);
5101 }
5102
5103 /* Given a type that corresponds to a renaming entity, use the type name
5104    to extract the scope (package name or function name, fully qualified,
5105    and following the GNAT encoding convention) where this renaming has been
5106    defined.  */
5107
5108 static std::string
5109 xget_renaming_scope (struct type *renaming_type)
5110 {
5111   /* The renaming types adhere to the following convention:
5112      <scope>__<rename>___<XR extension>.
5113      So, to extract the scope, we search for the "___XR" extension,
5114      and then backtrack until we find the first "__".  */
5115
5116   const char *name = renaming_type->name ();
5117   const char *suffix = strstr (name, "___XR");
5118   const char *last;
5119
5120   /* Now, backtrack a bit until we find the first "__".  Start looking
5121      at suffix - 3, as the <rename> part is at least one character long.  */
5122
5123   for (last = suffix - 3; last > name; last--)
5124     if (last[0] == '_' && last[1] == '_')
5125       break;
5126
5127   /* Make a copy of scope and return it.  */
5128   return std::string (name, last);
5129 }
5130
5131 /* Return nonzero if NAME corresponds to a package name.  */
5132
5133 static int
5134 is_package_name (const char *name)
5135 {
5136   /* Here, We take advantage of the fact that no symbols are generated
5137      for packages, while symbols are generated for each function.
5138      So the condition for NAME represent a package becomes equivalent
5139      to NAME not existing in our list of symbols.  There is only one
5140      small complication with library-level functions (see below).  */
5141
5142   /* If it is a function that has not been defined at library level,
5143      then we should be able to look it up in the symbols.  */
5144   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5145     return 0;
5146
5147   /* Library-level function names start with "_ada_".  See if function
5148      "_ada_" followed by NAME can be found.  */
5149
5150   /* Do a quick check that NAME does not contain "__", since library-level
5151      functions names cannot contain "__" in them.  */
5152   if (strstr (name, "__") != NULL)
5153     return 0;
5154
5155   std::string fun_name = string_printf ("_ada_%s", name);
5156
5157   return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5158 }
5159
5160 /* Return nonzero if SYM corresponds to a renaming entity that is
5161    not visible from FUNCTION_NAME.  */
5162
5163 static int
5164 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5165 {
5166   if (sym->aclass () != LOC_TYPEDEF)
5167     return 0;
5168
5169   std::string scope = xget_renaming_scope (sym->type ());
5170
5171   /* If the rename has been defined in a package, then it is visible.  */
5172   if (is_package_name (scope.c_str ()))
5173     return 0;
5174
5175   /* Check that the rename is in the current function scope by checking
5176      that its name starts with SCOPE.  */
5177
5178   /* If the function name starts with "_ada_", it means that it is
5179      a library-level function.  Strip this prefix before doing the
5180      comparison, as the encoding for the renaming does not contain
5181      this prefix.  */
5182   if (startswith (function_name, "_ada_"))
5183     function_name += 5;
5184
5185   return !startswith (function_name, scope.c_str ());
5186 }
5187
5188 /* Remove entries from SYMS that corresponds to a renaming entity that
5189    is not visible from the function associated with CURRENT_BLOCK or
5190    that is superfluous due to the presence of more specific renaming
5191    information.  Places surviving symbols in the initial entries of
5192    SYMS.
5193
5194    Rationale:
5195    First, in cases where an object renaming is implemented as a
5196    reference variable, GNAT may produce both the actual reference
5197    variable and the renaming encoding.  In this case, we discard the
5198    latter.
5199
5200    Second, GNAT emits a type following a specified encoding for each renaming
5201    entity.  Unfortunately, STABS currently does not support the definition
5202    of types that are local to a given lexical block, so all renamings types
5203    are emitted at library level.  As a consequence, if an application
5204    contains two renaming entities using the same name, and a user tries to
5205    print the value of one of these entities, the result of the ada symbol
5206    lookup will also contain the wrong renaming type.
5207
5208    This function partially covers for this limitation by attempting to
5209    remove from the SYMS list renaming symbols that should be visible
5210    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
5211    method with the current information available.  The implementation
5212    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
5213    
5214       - When the user tries to print a rename in a function while there
5215         is another rename entity defined in a package:  Normally, the
5216         rename in the function has precedence over the rename in the
5217         package, so the latter should be removed from the list.  This is
5218         currently not the case.
5219         
5220       - This function will incorrectly remove valid renames if
5221         the CURRENT_BLOCK corresponds to a function which symbol name
5222         has been changed by an "Export" pragma.  As a consequence,
5223         the user will be unable to print such rename entities.  */
5224
5225 static void
5226 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5227                              const struct block *current_block)
5228 {
5229   struct symbol *current_function;
5230   const char *current_function_name;
5231   int i;
5232   int is_new_style_renaming;
5233
5234   /* If there is both a renaming foo___XR... encoded as a variable and
5235      a simple variable foo in the same block, discard the latter.
5236      First, zero out such symbols, then compress.  */
5237   is_new_style_renaming = 0;
5238   for (i = 0; i < syms->size (); i += 1)
5239     {
5240       struct symbol *sym = (*syms)[i].symbol;
5241       const struct block *block = (*syms)[i].block;
5242       const char *name;
5243       const char *suffix;
5244
5245       if (sym == NULL || sym->aclass () == LOC_TYPEDEF)
5246         continue;
5247       name = sym->linkage_name ();
5248       suffix = strstr (name, "___XR");
5249
5250       if (suffix != NULL)
5251         {
5252           int name_len = suffix - name;
5253           int j;
5254
5255           is_new_style_renaming = 1;
5256           for (j = 0; j < syms->size (); j += 1)
5257             if (i != j && (*syms)[j].symbol != NULL
5258                 && strncmp (name, (*syms)[j].symbol->linkage_name (),
5259                             name_len) == 0
5260                 && block == (*syms)[j].block)
5261               (*syms)[j].symbol = NULL;
5262         }
5263     }
5264   if (is_new_style_renaming)
5265     {
5266       int j, k;
5267
5268       for (j = k = 0; j < syms->size (); j += 1)
5269         if ((*syms)[j].symbol != NULL)
5270             {
5271               (*syms)[k] = (*syms)[j];
5272               k += 1;
5273             }
5274       syms->resize (k);
5275       return;
5276     }
5277
5278   /* Extract the function name associated to CURRENT_BLOCK.
5279      Abort if unable to do so.  */
5280
5281   if (current_block == NULL)
5282     return;
5283
5284   current_function = block_linkage_function (current_block);
5285   if (current_function == NULL)
5286     return;
5287
5288   current_function_name = current_function->linkage_name ();
5289   if (current_function_name == NULL)
5290     return;
5291
5292   /* Check each of the symbols, and remove it from the list if it is
5293      a type corresponding to a renaming that is out of the scope of
5294      the current block.  */
5295
5296   i = 0;
5297   while (i < syms->size ())
5298     {
5299       if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5300           == ADA_OBJECT_RENAMING
5301           && old_renaming_is_invisible ((*syms)[i].symbol,
5302                                         current_function_name))
5303         syms->erase (syms->begin () + i);
5304       else
5305         i += 1;
5306     }
5307 }
5308
5309 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5310    whose name and domain match LOOKUP_NAME and DOMAIN respectively.
5311
5312    Note: This function assumes that RESULT is empty.  */
5313
5314 static void
5315 ada_add_local_symbols (std::vector<struct block_symbol> &result,
5316                        const lookup_name_info &lookup_name,
5317                        const struct block *block, domain_enum domain)
5318 {
5319   while (block != NULL)
5320     {
5321       ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5322
5323       /* If we found a non-function match, assume that's the one.  We
5324          only check this when finding a function boundary, so that we
5325          can accumulate all results from intervening blocks first.  */
5326       if (BLOCK_FUNCTION (block) != nullptr && is_nonfunction (result))
5327         return;
5328
5329       block = BLOCK_SUPERBLOCK (block);
5330     }
5331 }
5332
5333 /* An object of this type is used as the callback argument when
5334    calling the map_matching_symbols method.  */
5335
5336 struct match_data
5337 {
5338   explicit match_data (std::vector<struct block_symbol> *rp)
5339     : resultp (rp)
5340   {
5341   }
5342   DISABLE_COPY_AND_ASSIGN (match_data);
5343
5344   bool operator() (struct block_symbol *bsym);
5345
5346   struct objfile *objfile = nullptr;
5347   std::vector<struct block_symbol> *resultp;
5348   struct symbol *arg_sym = nullptr;
5349   bool found_sym = false;
5350 };
5351
5352 /* A callback for add_nonlocal_symbols that adds symbol, found in
5353    BSYM, to a list of symbols.  */
5354
5355 bool
5356 match_data::operator() (struct block_symbol *bsym)
5357 {
5358   const struct block *block = bsym->block;
5359   struct symbol *sym = bsym->symbol;
5360
5361   if (sym == NULL)
5362     {
5363       if (!found_sym && arg_sym != NULL)
5364         add_defn_to_vec (*resultp,
5365                          fixup_symbol_section (arg_sym, objfile),
5366                          block);
5367       found_sym = false;
5368       arg_sym = NULL;
5369     }
5370   else 
5371     {
5372       if (sym->aclass () == LOC_UNRESOLVED)
5373         return true;
5374       else if (sym->is_argument ())
5375         arg_sym = sym;
5376       else
5377         {
5378           found_sym = true;
5379           add_defn_to_vec (*resultp,
5380                            fixup_symbol_section (sym, objfile),
5381                            block);
5382         }
5383     }
5384   return true;
5385 }
5386
5387 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5388    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5389    symbols to RESULT.  Return whether we found such symbols.  */
5390
5391 static int
5392 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5393                          const struct block *block,
5394                          const lookup_name_info &lookup_name,
5395                          domain_enum domain)
5396 {
5397   struct using_direct *renaming;
5398   int defns_mark = result.size ();
5399
5400   symbol_name_matcher_ftype *name_match
5401     = ada_get_symbol_name_matcher (lookup_name);
5402
5403   for (renaming = block_using (block);
5404        renaming != NULL;
5405        renaming = renaming->next)
5406     {
5407       const char *r_name;
5408
5409       /* Avoid infinite recursions: skip this renaming if we are actually
5410          already traversing it.
5411
5412          Currently, symbol lookup in Ada don't use the namespace machinery from
5413          C++/Fortran support: skip namespace imports that use them.  */
5414       if (renaming->searched
5415           || (renaming->import_src != NULL
5416               && renaming->import_src[0] != '\0')
5417           || (renaming->import_dest != NULL
5418               && renaming->import_dest[0] != '\0'))
5419         continue;
5420       renaming->searched = 1;
5421
5422       /* TODO: here, we perform another name-based symbol lookup, which can
5423          pull its own multiple overloads.  In theory, we should be able to do
5424          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5425          not a simple name.  But in order to do this, we would need to enhance
5426          the DWARF reader to associate a symbol to this renaming, instead of a
5427          name.  So, for now, we do something simpler: re-use the C++/Fortran
5428          namespace machinery.  */
5429       r_name = (renaming->alias != NULL
5430                 ? renaming->alias
5431                 : renaming->declaration);
5432       if (name_match (r_name, lookup_name, NULL))
5433         {
5434           lookup_name_info decl_lookup_name (renaming->declaration,
5435                                              lookup_name.match_type ());
5436           ada_add_all_symbols (result, block, decl_lookup_name, domain,
5437                                1, NULL);
5438         }
5439       renaming->searched = 0;
5440     }
5441   return result.size () != defns_mark;
5442 }
5443
5444 /* Implements compare_names, but only applying the comparision using
5445    the given CASING.  */
5446
5447 static int
5448 compare_names_with_case (const char *string1, const char *string2,
5449                          enum case_sensitivity casing)
5450 {
5451   while (*string1 != '\0' && *string2 != '\0')
5452     {
5453       char c1, c2;
5454
5455       if (isspace (*string1) || isspace (*string2))
5456         return strcmp_iw_ordered (string1, string2);
5457
5458       if (casing == case_sensitive_off)
5459         {
5460           c1 = tolower (*string1);
5461           c2 = tolower (*string2);
5462         }
5463       else
5464         {
5465           c1 = *string1;
5466           c2 = *string2;
5467         }
5468       if (c1 != c2)
5469         break;
5470
5471       string1 += 1;
5472       string2 += 1;
5473     }
5474
5475   switch (*string1)
5476     {
5477     case '(':
5478       return strcmp_iw_ordered (string1, string2);
5479     case '_':
5480       if (*string2 == '\0')
5481         {
5482           if (is_name_suffix (string1))
5483             return 0;
5484           else
5485             return 1;
5486         }
5487       /* FALLTHROUGH */
5488     default:
5489       if (*string2 == '(')
5490         return strcmp_iw_ordered (string1, string2);
5491       else
5492         {
5493           if (casing == case_sensitive_off)
5494             return tolower (*string1) - tolower (*string2);
5495           else
5496             return *string1 - *string2;
5497         }
5498     }
5499 }
5500
5501 /* Compare STRING1 to STRING2, with results as for strcmp.
5502    Compatible with strcmp_iw_ordered in that...
5503
5504        strcmp_iw_ordered (STRING1, STRING2) <= 0
5505
5506    ... implies...
5507
5508        compare_names (STRING1, STRING2) <= 0
5509
5510    (they may differ as to what symbols compare equal).  */
5511
5512 static int
5513 compare_names (const char *string1, const char *string2)
5514 {
5515   int result;
5516
5517   /* Similar to what strcmp_iw_ordered does, we need to perform
5518      a case-insensitive comparison first, and only resort to
5519      a second, case-sensitive, comparison if the first one was
5520      not sufficient to differentiate the two strings.  */
5521
5522   result = compare_names_with_case (string1, string2, case_sensitive_off);
5523   if (result == 0)
5524     result = compare_names_with_case (string1, string2, case_sensitive_on);
5525
5526   return result;
5527 }
5528
5529 /* Convenience function to get at the Ada encoded lookup name for
5530    LOOKUP_NAME, as a C string.  */
5531
5532 static const char *
5533 ada_lookup_name (const lookup_name_info &lookup_name)
5534 {
5535   return lookup_name.ada ().lookup_name ().c_str ();
5536 }
5537
5538 /* A helper for add_nonlocal_symbols.  Call expand_matching_symbols
5539    for OBJFILE, then walk the objfile's symtabs and update the
5540    results.  */
5541
5542 static void
5543 map_matching_symbols (struct objfile *objfile,
5544                       const lookup_name_info &lookup_name,
5545                       bool is_wild_match,
5546                       domain_enum domain,
5547                       int global,
5548                       match_data &data)
5549 {
5550   data.objfile = objfile;
5551   objfile->expand_matching_symbols (lookup_name, domain, global,
5552                                     is_wild_match ? nullptr : compare_names);
5553
5554   const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5555   for (compunit_symtab *symtab : objfile->compunits ())
5556     {
5557       const struct block *block
5558         = BLOCKVECTOR_BLOCK (symtab->blockvector (), block_kind);
5559       if (!iterate_over_symbols_terminated (block, lookup_name,
5560                                             domain, data))
5561         break;
5562     }
5563 }
5564
5565 /* Add to RESULT all non-local symbols whose name and domain match
5566    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5567    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5568    symbols otherwise.  */
5569
5570 static void
5571 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5572                       const lookup_name_info &lookup_name,
5573                       domain_enum domain, int global)
5574 {
5575   struct match_data data (&result);
5576
5577   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5578
5579   for (objfile *objfile : current_program_space->objfiles ())
5580     {
5581       map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5582                             global, data);
5583
5584       for (compunit_symtab *cu : objfile->compunits ())
5585         {
5586           const struct block *global_block
5587             = BLOCKVECTOR_BLOCK (cu->blockvector (), GLOBAL_BLOCK);
5588
5589           if (ada_add_block_renamings (result, global_block, lookup_name,
5590                                        domain))
5591             data.found_sym = true;
5592         }
5593     }
5594
5595   if (result.empty () && global && !is_wild_match)
5596     {
5597       const char *name = ada_lookup_name (lookup_name);
5598       std::string bracket_name = std::string ("<_ada_") + name + '>';
5599       lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5600
5601       for (objfile *objfile : current_program_space->objfiles ())
5602         map_matching_symbols (objfile, name1, false, domain, global, data);
5603     }
5604 }
5605
5606 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5607    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5608    returning the number of matches.  Add these to RESULT.
5609
5610    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5611    symbol match within the nest of blocks whose innermost member is BLOCK,
5612    is the one match returned (no other matches in that or
5613    enclosing blocks is returned).  If there are any matches in or
5614    surrounding BLOCK, then these alone are returned.
5615
5616    Names prefixed with "standard__" are handled specially:
5617    "standard__" is first stripped off (by the lookup_name
5618    constructor), and only static and global symbols are searched.
5619
5620    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5621    to lookup global symbols.  */
5622
5623 static void
5624 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5625                      const struct block *block,
5626                      const lookup_name_info &lookup_name,
5627                      domain_enum domain,
5628                      int full_search,
5629                      int *made_global_lookup_p)
5630 {
5631   struct symbol *sym;
5632
5633   if (made_global_lookup_p)
5634     *made_global_lookup_p = 0;
5635
5636   /* Special case: If the user specifies a symbol name inside package
5637      Standard, do a non-wild matching of the symbol name without
5638      the "standard__" prefix.  This was primarily introduced in order
5639      to allow the user to specifically access the standard exceptions
5640      using, for instance, Standard.Constraint_Error when Constraint_Error
5641      is ambiguous (due to the user defining its own Constraint_Error
5642      entity inside its program).  */
5643   if (lookup_name.ada ().standard_p ())
5644     block = NULL;
5645
5646   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5647
5648   if (block != NULL)
5649     {
5650       if (full_search)
5651         ada_add_local_symbols (result, lookup_name, block, domain);
5652       else
5653         {
5654           /* In the !full_search case we're are being called by
5655              iterate_over_symbols, and we don't want to search
5656              superblocks.  */
5657           ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5658         }
5659       if (!result.empty () || !full_search)
5660         return;
5661     }
5662
5663   /* No non-global symbols found.  Check our cache to see if we have
5664      already performed this search before.  If we have, then return
5665      the same result.  */
5666
5667   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5668                             domain, &sym, &block))
5669     {
5670       if (sym != NULL)
5671         add_defn_to_vec (result, sym, block);
5672       return;
5673     }
5674
5675   if (made_global_lookup_p)
5676     *made_global_lookup_p = 1;
5677
5678   /* Search symbols from all global blocks.  */
5679  
5680   add_nonlocal_symbols (result, lookup_name, domain, 1);
5681
5682   /* Now add symbols from all per-file blocks if we've gotten no hits
5683      (not strictly correct, but perhaps better than an error).  */
5684
5685   if (result.empty ())
5686     add_nonlocal_symbols (result, lookup_name, domain, 0);
5687 }
5688
5689 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5690    is non-zero, enclosing scope and in global scopes.
5691
5692    Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5693    blocks and symbol tables (if any) in which they were found.
5694
5695    When full_search is non-zero, any non-function/non-enumeral
5696    symbol match within the nest of blocks whose innermost member is BLOCK,
5697    is the one match returned (no other matches in that or
5698    enclosing blocks is returned).  If there are any matches in or
5699    surrounding BLOCK, then these alone are returned.
5700
5701    Names prefixed with "standard__" are handled specially: "standard__"
5702    is first stripped off, and only static and global symbols are searched.  */
5703
5704 static std::vector<struct block_symbol>
5705 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5706                                const struct block *block,
5707                                domain_enum domain,
5708                                int full_search)
5709 {
5710   int syms_from_global_search;
5711   std::vector<struct block_symbol> results;
5712
5713   ada_add_all_symbols (results, block, lookup_name,
5714                        domain, full_search, &syms_from_global_search);
5715
5716   remove_extra_symbols (&results);
5717
5718   if (results.empty () && full_search && syms_from_global_search)
5719     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5720
5721   if (results.size () == 1 && full_search && syms_from_global_search)
5722     cache_symbol (ada_lookup_name (lookup_name), domain,
5723                   results[0].symbol, results[0].block);
5724
5725   remove_irrelevant_renamings (&results, block);
5726   return results;
5727 }
5728
5729 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5730    in global scopes, returning (SYM,BLOCK) tuples.
5731
5732    See ada_lookup_symbol_list_worker for further details.  */
5733
5734 std::vector<struct block_symbol>
5735 ada_lookup_symbol_list (const char *name, const struct block *block,
5736                         domain_enum domain)
5737 {
5738   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5739   lookup_name_info lookup_name (name, name_match_type);
5740
5741   return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5742 }
5743
5744 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5745    to 1, but choosing the first symbol found if there are multiple
5746    choices.
5747
5748    The result is stored in *INFO, which must be non-NULL.
5749    If no match is found, INFO->SYM is set to NULL.  */
5750
5751 void
5752 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5753                            domain_enum domain,
5754                            struct block_symbol *info)
5755 {
5756   /* Since we already have an encoded name, wrap it in '<>' to force a
5757      verbatim match.  Otherwise, if the name happens to not look like
5758      an encoded name (because it doesn't include a "__"),
5759      ada_lookup_name_info would re-encode/fold it again, and that
5760      would e.g., incorrectly lowercase object renaming names like
5761      "R28b" -> "r28b".  */
5762   std::string verbatim = add_angle_brackets (name);
5763
5764   gdb_assert (info != NULL);
5765   *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5766 }
5767
5768 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5769    scope and in global scopes, or NULL if none.  NAME is folded and
5770    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5771    choosing the first symbol if there are multiple choices.  */
5772
5773 struct block_symbol
5774 ada_lookup_symbol (const char *name, const struct block *block0,
5775                    domain_enum domain)
5776 {
5777   std::vector<struct block_symbol> candidates
5778     = ada_lookup_symbol_list (name, block0, domain);
5779
5780   if (candidates.empty ())
5781     return {};
5782
5783   block_symbol info = candidates[0];
5784   info.symbol = fixup_symbol_section (info.symbol, NULL);
5785   return info;
5786 }
5787
5788
5789 /* True iff STR is a possible encoded suffix of a normal Ada name
5790    that is to be ignored for matching purposes.  Suffixes of parallel
5791    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5792    are given by any of the regular expressions:
5793
5794    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5795    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5796    TKB              [subprogram suffix for task bodies]
5797    _E[0-9]+[bs]$    [protected object entry suffixes]
5798    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5799
5800    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5801    match is performed.  This sequence is used to differentiate homonyms,
5802    is an optional part of a valid name suffix.  */
5803
5804 static int
5805 is_name_suffix (const char *str)
5806 {
5807   int k;
5808   const char *matching;
5809   const int len = strlen (str);
5810
5811   /* Skip optional leading __[0-9]+.  */
5812
5813   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5814     {
5815       str += 3;
5816       while (isdigit (str[0]))
5817         str += 1;
5818     }
5819   
5820   /* [.$][0-9]+ */
5821
5822   if (str[0] == '.' || str[0] == '$')
5823     {
5824       matching = str + 1;
5825       while (isdigit (matching[0]))
5826         matching += 1;
5827       if (matching[0] == '\0')
5828         return 1;
5829     }
5830
5831   /* ___[0-9]+ */
5832
5833   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5834     {
5835       matching = str + 3;
5836       while (isdigit (matching[0]))
5837         matching += 1;
5838       if (matching[0] == '\0')
5839         return 1;
5840     }
5841
5842   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
5843
5844   if (strcmp (str, "TKB") == 0)
5845     return 1;
5846
5847 #if 0
5848   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5849      with a N at the end.  Unfortunately, the compiler uses the same
5850      convention for other internal types it creates.  So treating
5851      all entity names that end with an "N" as a name suffix causes
5852      some regressions.  For instance, consider the case of an enumerated
5853      type.  To support the 'Image attribute, it creates an array whose
5854      name ends with N.
5855      Having a single character like this as a suffix carrying some
5856      information is a bit risky.  Perhaps we should change the encoding
5857      to be something like "_N" instead.  In the meantime, do not do
5858      the following check.  */
5859   /* Protected Object Subprograms */
5860   if (len == 1 && str [0] == 'N')
5861     return 1;
5862 #endif
5863
5864   /* _E[0-9]+[bs]$ */
5865   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5866     {
5867       matching = str + 3;
5868       while (isdigit (matching[0]))
5869         matching += 1;
5870       if ((matching[0] == 'b' || matching[0] == 's')
5871           && matching [1] == '\0')
5872         return 1;
5873     }
5874
5875   /* ??? We should not modify STR directly, as we are doing below.  This
5876      is fine in this case, but may become problematic later if we find
5877      that this alternative did not work, and want to try matching
5878      another one from the begining of STR.  Since we modified it, we
5879      won't be able to find the begining of the string anymore!  */
5880   if (str[0] == 'X')
5881     {
5882       str += 1;
5883       while (str[0] != '_' && str[0] != '\0')
5884         {
5885           if (str[0] != 'n' && str[0] != 'b')
5886             return 0;
5887           str += 1;
5888         }
5889     }
5890
5891   if (str[0] == '\000')
5892     return 1;
5893
5894   if (str[0] == '_')
5895     {
5896       if (str[1] != '_' || str[2] == '\000')
5897         return 0;
5898       if (str[2] == '_')
5899         {
5900           if (strcmp (str + 3, "JM") == 0)
5901             return 1;
5902           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5903              the LJM suffix in favor of the JM one.  But we will
5904              still accept LJM as a valid suffix for a reasonable
5905              amount of time, just to allow ourselves to debug programs
5906              compiled using an older version of GNAT.  */
5907           if (strcmp (str + 3, "LJM") == 0)
5908             return 1;
5909           if (str[3] != 'X')
5910             return 0;
5911           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5912               || str[4] == 'U' || str[4] == 'P')
5913             return 1;
5914           if (str[4] == 'R' && str[5] != 'T')
5915             return 1;
5916           return 0;
5917         }
5918       if (!isdigit (str[2]))
5919         return 0;
5920       for (k = 3; str[k] != '\0'; k += 1)
5921         if (!isdigit (str[k]) && str[k] != '_')
5922           return 0;
5923       return 1;
5924     }
5925   if (str[0] == '$' && isdigit (str[1]))
5926     {
5927       for (k = 2; str[k] != '\0'; k += 1)
5928         if (!isdigit (str[k]) && str[k] != '_')
5929           return 0;
5930       return 1;
5931     }
5932   return 0;
5933 }
5934
5935 /* Return non-zero if the string starting at NAME and ending before
5936    NAME_END contains no capital letters.  */
5937
5938 static int
5939 is_valid_name_for_wild_match (const char *name0)
5940 {
5941   std::string decoded_name = ada_decode (name0);
5942   int i;
5943
5944   /* If the decoded name starts with an angle bracket, it means that
5945      NAME0 does not follow the GNAT encoding format.  It should then
5946      not be allowed as a possible wild match.  */
5947   if (decoded_name[0] == '<')
5948     return 0;
5949
5950   for (i=0; decoded_name[i] != '\0'; i++)
5951     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5952       return 0;
5953
5954   return 1;
5955 }
5956
5957 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5958    character which could start a simple name.  Assumes that *NAMEP points
5959    somewhere inside the string beginning at NAME0.  */
5960
5961 static int
5962 advance_wild_match (const char **namep, const char *name0, char target0)
5963 {
5964   const char *name = *namep;
5965
5966   while (1)
5967     {
5968       char t0, t1;
5969
5970       t0 = *name;
5971       if (t0 == '_')
5972         {
5973           t1 = name[1];
5974           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5975             {
5976               name += 1;
5977               if (name == name0 + 5 && startswith (name0, "_ada"))
5978                 break;
5979               else
5980                 name += 1;
5981             }
5982           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5983                                  || name[2] == target0))
5984             {
5985               name += 2;
5986               break;
5987             }
5988           else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
5989             {
5990               /* Names like "pkg__B_N__name", where N is a number, are
5991                  block-local.  We can handle these by simply skipping
5992                  the "B_" here.  */
5993               name += 4;
5994             }
5995           else
5996             return 0;
5997         }
5998       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5999         name += 1;
6000       else
6001         return 0;
6002     }
6003
6004   *namep = name;
6005   return 1;
6006 }
6007
6008 /* Return true iff NAME encodes a name of the form prefix.PATN.
6009    Ignores any informational suffixes of NAME (i.e., for which
6010    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
6011    simple name.  */
6012
6013 static bool
6014 wild_match (const char *name, const char *patn)
6015 {
6016   const char *p;
6017   const char *name0 = name;
6018
6019   while (1)
6020     {
6021       const char *match = name;
6022
6023       if (*name == *patn)
6024         {
6025           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6026             if (*p != *name)
6027               break;
6028           if (*p == '\0' && is_name_suffix (name))
6029             return match == name0 || is_valid_name_for_wild_match (name0);
6030
6031           if (name[-1] == '_')
6032             name -= 1;
6033         }
6034       if (!advance_wild_match (&name, name0, *patn))
6035         return false;
6036     }
6037 }
6038
6039 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
6040    necessary).  OBJFILE is the section containing BLOCK.  */
6041
6042 static void
6043 ada_add_block_symbols (std::vector<struct block_symbol> &result,
6044                        const struct block *block,
6045                        const lookup_name_info &lookup_name,
6046                        domain_enum domain, struct objfile *objfile)
6047 {
6048   struct block_iterator iter;
6049   /* A matching argument symbol, if any.  */
6050   struct symbol *arg_sym;
6051   /* Set true when we find a matching non-argument symbol.  */
6052   bool found_sym;
6053   struct symbol *sym;
6054
6055   arg_sym = NULL;
6056   found_sym = false;
6057   for (sym = block_iter_match_first (block, lookup_name, &iter);
6058        sym != NULL;
6059        sym = block_iter_match_next (lookup_name, &iter))
6060     {
6061       if (symbol_matches_domain (sym->language (), sym->domain (), domain))
6062         {
6063           if (sym->aclass () != LOC_UNRESOLVED)
6064             {
6065               if (sym->is_argument ())
6066                 arg_sym = sym;
6067               else
6068                 {
6069                   found_sym = true;
6070                   add_defn_to_vec (result,
6071                                    fixup_symbol_section (sym, objfile),
6072                                    block);
6073                 }
6074             }
6075         }
6076     }
6077
6078   /* Handle renamings.  */
6079
6080   if (ada_add_block_renamings (result, block, lookup_name, domain))
6081     found_sym = true;
6082
6083   if (!found_sym && arg_sym != NULL)
6084     {
6085       add_defn_to_vec (result,
6086                        fixup_symbol_section (arg_sym, objfile),
6087                        block);
6088     }
6089
6090   if (!lookup_name.ada ().wild_match_p ())
6091     {
6092       arg_sym = NULL;
6093       found_sym = false;
6094       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6095       const char *name = ada_lookup_name.c_str ();
6096       size_t name_len = ada_lookup_name.size ();
6097
6098       ALL_BLOCK_SYMBOLS (block, iter, sym)
6099       {
6100         if (symbol_matches_domain (sym->language (),
6101                                    sym->domain (), domain))
6102           {
6103             int cmp;
6104
6105             cmp = (int) '_' - (int) sym->linkage_name ()[0];
6106             if (cmp == 0)
6107               {
6108                 cmp = !startswith (sym->linkage_name (), "_ada_");
6109                 if (cmp == 0)
6110                   cmp = strncmp (name, sym->linkage_name () + 5,
6111                                  name_len);
6112               }
6113
6114             if (cmp == 0
6115                 && is_name_suffix (sym->linkage_name () + name_len + 5))
6116               {
6117                 if (sym->aclass () != LOC_UNRESOLVED)
6118                   {
6119                     if (sym->is_argument ())
6120                       arg_sym = sym;
6121                     else
6122                       {
6123                         found_sym = true;
6124                         add_defn_to_vec (result,
6125                                          fixup_symbol_section (sym, objfile),
6126                                          block);
6127                       }
6128                   }
6129               }
6130           }
6131       }
6132
6133       /* NOTE: This really shouldn't be needed for _ada_ symbols.
6134          They aren't parameters, right?  */
6135       if (!found_sym && arg_sym != NULL)
6136         {
6137           add_defn_to_vec (result,
6138                            fixup_symbol_section (arg_sym, objfile),
6139                            block);
6140         }
6141     }
6142 }
6143 \f
6144
6145                                 /* Symbol Completion */
6146
6147 /* See symtab.h.  */
6148
6149 bool
6150 ada_lookup_name_info::matches
6151   (const char *sym_name,
6152    symbol_name_match_type match_type,
6153    completion_match_result *comp_match_res) const
6154 {
6155   bool match = false;
6156   const char *text = m_encoded_name.c_str ();
6157   size_t text_len = m_encoded_name.size ();
6158
6159   /* First, test against the fully qualified name of the symbol.  */
6160
6161   if (strncmp (sym_name, text, text_len) == 0)
6162     match = true;
6163
6164   std::string decoded_name = ada_decode (sym_name);
6165   if (match && !m_encoded_p)
6166     {
6167       /* One needed check before declaring a positive match is to verify
6168          that iff we are doing a verbatim match, the decoded version
6169          of the symbol name starts with '<'.  Otherwise, this symbol name
6170          is not a suitable completion.  */
6171
6172       bool has_angle_bracket = (decoded_name[0] == '<');
6173       match = (has_angle_bracket == m_verbatim_p);
6174     }
6175
6176   if (match && !m_verbatim_p)
6177     {
6178       /* When doing non-verbatim match, another check that needs to
6179          be done is to verify that the potentially matching symbol name
6180          does not include capital letters, because the ada-mode would
6181          not be able to understand these symbol names without the
6182          angle bracket notation.  */
6183       const char *tmp;
6184
6185       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6186       if (*tmp != '\0')
6187         match = false;
6188     }
6189
6190   /* Second: Try wild matching...  */
6191
6192   if (!match && m_wild_match_p)
6193     {
6194       /* Since we are doing wild matching, this means that TEXT
6195          may represent an unqualified symbol name.  We therefore must
6196          also compare TEXT against the unqualified name of the symbol.  */
6197       sym_name = ada_unqualified_name (decoded_name.c_str ());
6198
6199       if (strncmp (sym_name, text, text_len) == 0)
6200         match = true;
6201     }
6202
6203   /* Finally: If we found a match, prepare the result to return.  */
6204
6205   if (!match)
6206     return false;
6207
6208   if (comp_match_res != NULL)
6209     {
6210       std::string &match_str = comp_match_res->match.storage ();
6211
6212       if (!m_encoded_p)
6213         match_str = ada_decode (sym_name);
6214       else
6215         {
6216           if (m_verbatim_p)
6217             match_str = add_angle_brackets (sym_name);
6218           else
6219             match_str = sym_name;
6220
6221         }
6222
6223       comp_match_res->set_match (match_str.c_str ());
6224     }
6225
6226   return true;
6227 }
6228
6229                                 /* Field Access */
6230
6231 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6232    for tagged types.  */
6233
6234 static int
6235 ada_is_dispatch_table_ptr_type (struct type *type)
6236 {
6237   const char *name;
6238
6239   if (type->code () != TYPE_CODE_PTR)
6240     return 0;
6241
6242   name = TYPE_TARGET_TYPE (type)->name ();
6243   if (name == NULL)
6244     return 0;
6245
6246   return (strcmp (name, "ada__tags__dispatch_table") == 0);
6247 }
6248
6249 /* Return non-zero if TYPE is an interface tag.  */
6250
6251 static int
6252 ada_is_interface_tag (struct type *type)
6253 {
6254   const char *name = type->name ();
6255
6256   if (name == NULL)
6257     return 0;
6258
6259   return (strcmp (name, "ada__tags__interface_tag") == 0);
6260 }
6261
6262 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6263    to be invisible to users.  */
6264
6265 int
6266 ada_is_ignored_field (struct type *type, int field_num)
6267 {
6268   if (field_num < 0 || field_num > type->num_fields ())
6269     return 1;
6270
6271   /* Check the name of that field.  */
6272   {
6273     const char *name = type->field (field_num).name ();
6274
6275     /* Anonymous field names should not be printed.
6276        brobecker/2007-02-20: I don't think this can actually happen
6277        but we don't want to print the value of anonymous fields anyway.  */
6278     if (name == NULL)
6279       return 1;
6280
6281     /* Normally, fields whose name start with an underscore ("_")
6282        are fields that have been internally generated by the compiler,
6283        and thus should not be printed.  The "_parent" field is special,
6284        however: This is a field internally generated by the compiler
6285        for tagged types, and it contains the components inherited from
6286        the parent type.  This field should not be printed as is, but
6287        should not be ignored either.  */
6288     if (name[0] == '_' && !startswith (name, "_parent"))
6289       return 1;
6290   }
6291
6292   /* If this is the dispatch table of a tagged type or an interface tag,
6293      then ignore.  */
6294   if (ada_is_tagged_type (type, 1)
6295       && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
6296           || ada_is_interface_tag (type->field (field_num).type ())))
6297     return 1;
6298
6299   /* Not a special field, so it should not be ignored.  */
6300   return 0;
6301 }
6302
6303 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
6304    pointer or reference type whose ultimate target has a tag field.  */
6305
6306 int
6307 ada_is_tagged_type (struct type *type, int refok)
6308 {
6309   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6310 }
6311
6312 /* True iff TYPE represents the type of X'Tag */
6313
6314 int
6315 ada_is_tag_type (struct type *type)
6316 {
6317   type = ada_check_typedef (type);
6318
6319   if (type == NULL || type->code () != TYPE_CODE_PTR)
6320     return 0;
6321   else
6322     {
6323       const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6324
6325       return (name != NULL
6326               && strcmp (name, "ada__tags__dispatch_table") == 0);
6327     }
6328 }
6329
6330 /* The type of the tag on VAL.  */
6331
6332 static struct type *
6333 ada_tag_type (struct value *val)
6334 {
6335   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6336 }
6337
6338 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6339    retired at Ada 05).  */
6340
6341 static int
6342 is_ada95_tag (struct value *tag)
6343 {
6344   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6345 }
6346
6347 /* The value of the tag on VAL.  */
6348
6349 static struct value *
6350 ada_value_tag (struct value *val)
6351 {
6352   return ada_value_struct_elt (val, "_tag", 0);
6353 }
6354
6355 /* The value of the tag on the object of type TYPE whose contents are
6356    saved at VALADDR, if it is non-null, or is at memory address
6357    ADDRESS.  */
6358
6359 static struct value *
6360 value_tag_from_contents_and_address (struct type *type,
6361                                      const gdb_byte *valaddr,
6362                                      CORE_ADDR address)
6363 {
6364   int tag_byte_offset;
6365   struct type *tag_type;
6366
6367   gdb::array_view<const gdb_byte> contents;
6368   if (valaddr != nullptr)
6369     contents = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
6370   struct type *resolved_type = resolve_dynamic_type (type, contents, address);
6371   if (find_struct_field ("_tag", resolved_type, 0, &tag_type, &tag_byte_offset,
6372                          NULL, NULL, NULL))
6373     {
6374       const gdb_byte *valaddr1 = ((valaddr == NULL)
6375                                   ? NULL
6376                                   : valaddr + tag_byte_offset);
6377       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6378
6379       return value_from_contents_and_address (tag_type, valaddr1, address1);
6380     }
6381   return NULL;
6382 }
6383
6384 static struct type *
6385 type_from_tag (struct value *tag)
6386 {
6387   gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6388
6389   if (type_name != NULL)
6390     return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6391   return NULL;
6392 }
6393
6394 /* Given a value OBJ of a tagged type, return a value of this
6395    type at the base address of the object.  The base address, as
6396    defined in Ada.Tags, it is the address of the primary tag of
6397    the object, and therefore where the field values of its full
6398    view can be fetched.  */
6399
6400 struct value *
6401 ada_tag_value_at_base_address (struct value *obj)
6402 {
6403   struct value *val;
6404   LONGEST offset_to_top = 0;
6405   struct type *ptr_type, *obj_type;
6406   struct value *tag;
6407   CORE_ADDR base_address;
6408
6409   obj_type = value_type (obj);
6410
6411   /* It is the responsability of the caller to deref pointers.  */
6412
6413   if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6414     return obj;
6415
6416   tag = ada_value_tag (obj);
6417   if (!tag)
6418     return obj;
6419
6420   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6421
6422   if (is_ada95_tag (tag))
6423     return obj;
6424
6425   ptr_type = language_lookup_primitive_type
6426     (language_def (language_ada), target_gdbarch(), "storage_offset");
6427   ptr_type = lookup_pointer_type (ptr_type);
6428   val = value_cast (ptr_type, tag);
6429   if (!val)
6430     return obj;
6431
6432   /* It is perfectly possible that an exception be raised while
6433      trying to determine the base address, just like for the tag;
6434      see ada_tag_name for more details.  We do not print the error
6435      message for the same reason.  */
6436
6437   try
6438     {
6439       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6440     }
6441
6442   catch (const gdb_exception_error &e)
6443     {
6444       return obj;
6445     }
6446
6447   /* If offset is null, nothing to do.  */
6448
6449   if (offset_to_top == 0)
6450     return obj;
6451
6452   /* -1 is a special case in Ada.Tags; however, what should be done
6453      is not quite clear from the documentation.  So do nothing for
6454      now.  */
6455
6456   if (offset_to_top == -1)
6457     return obj;
6458
6459   /* OFFSET_TO_TOP used to be a positive value to be subtracted
6460      from the base address.  This was however incompatible with
6461      C++ dispatch table: C++ uses a *negative* value to *add*
6462      to the base address.  Ada's convention has therefore been
6463      changed in GNAT 19.0w 20171023: since then, C++ and Ada
6464      use the same convention.  Here, we support both cases by
6465      checking the sign of OFFSET_TO_TOP.  */
6466
6467   if (offset_to_top > 0)
6468     offset_to_top = -offset_to_top;
6469
6470   base_address = value_address (obj) + offset_to_top;
6471   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6472
6473   /* Make sure that we have a proper tag at the new address.
6474      Otherwise, offset_to_top is bogus (which can happen when
6475      the object is not initialized yet).  */
6476
6477   if (!tag)
6478     return obj;
6479
6480   obj_type = type_from_tag (tag);
6481
6482   if (!obj_type)
6483     return obj;
6484
6485   return value_from_contents_and_address (obj_type, NULL, base_address);
6486 }
6487
6488 /* Return the "ada__tags__type_specific_data" type.  */
6489
6490 static struct type *
6491 ada_get_tsd_type (struct inferior *inf)
6492 {
6493   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6494
6495   if (data->tsd_type == 0)
6496     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6497   return data->tsd_type;
6498 }
6499
6500 /* Return the TSD (type-specific data) associated to the given TAG.
6501    TAG is assumed to be the tag of a tagged-type entity.
6502
6503    May return NULL if we are unable to get the TSD.  */
6504
6505 static struct value *
6506 ada_get_tsd_from_tag (struct value *tag)
6507 {
6508   struct value *val;
6509   struct type *type;
6510
6511   /* First option: The TSD is simply stored as a field of our TAG.
6512      Only older versions of GNAT would use this format, but we have
6513      to test it first, because there are no visible markers for
6514      the current approach except the absence of that field.  */
6515
6516   val = ada_value_struct_elt (tag, "tsd", 1);
6517   if (val)
6518     return val;
6519
6520   /* Try the second representation for the dispatch table (in which
6521      there is no explicit 'tsd' field in the referent of the tag pointer,
6522      and instead the tsd pointer is stored just before the dispatch
6523      table.  */
6524
6525   type = ada_get_tsd_type (current_inferior());
6526   if (type == NULL)
6527     return NULL;
6528   type = lookup_pointer_type (lookup_pointer_type (type));
6529   val = value_cast (type, tag);
6530   if (val == NULL)
6531     return NULL;
6532   return value_ind (value_ptradd (val, -1));
6533 }
6534
6535 /* Given the TSD of a tag (type-specific data), return a string
6536    containing the name of the associated type.
6537
6538    May return NULL if we are unable to determine the tag name.  */
6539
6540 static gdb::unique_xmalloc_ptr<char>
6541 ada_tag_name_from_tsd (struct value *tsd)
6542 {
6543   struct value *val;
6544
6545   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6546   if (val == NULL)
6547     return NULL;
6548   gdb::unique_xmalloc_ptr<char> buffer
6549     = target_read_string (value_as_address (val), INT_MAX);
6550   if (buffer == nullptr)
6551     return nullptr;
6552
6553   try
6554     {
6555       /* Let this throw an exception on error.  If the data is
6556          uninitialized, we'd rather not have the user see a
6557          warning.  */
6558       const char *folded = ada_fold_name (buffer.get (), true);
6559       return make_unique_xstrdup (folded);
6560     }
6561   catch (const gdb_exception &)
6562     {
6563       return nullptr;
6564     }
6565 }
6566
6567 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6568    a C string.
6569
6570    Return NULL if the TAG is not an Ada tag, or if we were unable to
6571    determine the name of that tag.  */
6572
6573 gdb::unique_xmalloc_ptr<char>
6574 ada_tag_name (struct value *tag)
6575 {
6576   gdb::unique_xmalloc_ptr<char> name;
6577
6578   if (!ada_is_tag_type (value_type (tag)))
6579     return NULL;
6580
6581   /* It is perfectly possible that an exception be raised while trying
6582      to determine the TAG's name, even under normal circumstances:
6583      The associated variable may be uninitialized or corrupted, for
6584      instance. We do not let any exception propagate past this point.
6585      instead we return NULL.
6586
6587      We also do not print the error message either (which often is very
6588      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6589      the caller print a more meaningful message if necessary.  */
6590   try
6591     {
6592       struct value *tsd = ada_get_tsd_from_tag (tag);
6593
6594       if (tsd != NULL)
6595         name = ada_tag_name_from_tsd (tsd);
6596     }
6597   catch (const gdb_exception_error &e)
6598     {
6599     }
6600
6601   return name;
6602 }
6603
6604 /* The parent type of TYPE, or NULL if none.  */
6605
6606 struct type *
6607 ada_parent_type (struct type *type)
6608 {
6609   int i;
6610
6611   type = ada_check_typedef (type);
6612
6613   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6614     return NULL;
6615
6616   for (i = 0; i < type->num_fields (); i += 1)
6617     if (ada_is_parent_field (type, i))
6618       {
6619         struct type *parent_type = type->field (i).type ();
6620
6621         /* If the _parent field is a pointer, then dereference it.  */
6622         if (parent_type->code () == TYPE_CODE_PTR)
6623           parent_type = TYPE_TARGET_TYPE (parent_type);
6624         /* If there is a parallel XVS type, get the actual base type.  */
6625         parent_type = ada_get_base_type (parent_type);
6626
6627         return ada_check_typedef (parent_type);
6628       }
6629
6630   return NULL;
6631 }
6632
6633 /* True iff field number FIELD_NUM of structure type TYPE contains the
6634    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6635    a structure type with at least FIELD_NUM+1 fields.  */
6636
6637 int
6638 ada_is_parent_field (struct type *type, int field_num)
6639 {
6640   const char *name = ada_check_typedef (type)->field (field_num).name ();
6641
6642   return (name != NULL
6643           && (startswith (name, "PARENT")
6644               || startswith (name, "_parent")));
6645 }
6646
6647 /* True iff field number FIELD_NUM of structure type TYPE is a
6648    transparent wrapper field (which should be silently traversed when doing
6649    field selection and flattened when printing).  Assumes TYPE is a
6650    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6651    structures.  */
6652
6653 int
6654 ada_is_wrapper_field (struct type *type, int field_num)
6655 {
6656   const char *name = type->field (field_num).name ();
6657
6658   if (name != NULL && strcmp (name, "RETVAL") == 0)
6659     {
6660       /* This happens in functions with "out" or "in out" parameters
6661          which are passed by copy.  For such functions, GNAT describes
6662          the function's return type as being a struct where the return
6663          value is in a field called RETVAL, and where the other "out"
6664          or "in out" parameters are fields of that struct.  This is not
6665          a wrapper.  */
6666       return 0;
6667     }
6668
6669   return (name != NULL
6670           && (startswith (name, "PARENT")
6671               || strcmp (name, "REP") == 0
6672               || startswith (name, "_parent")
6673               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6674 }
6675
6676 /* True iff field number FIELD_NUM of structure or union type TYPE
6677    is a variant wrapper.  Assumes TYPE is a structure type with at least
6678    FIELD_NUM+1 fields.  */
6679
6680 int
6681 ada_is_variant_part (struct type *type, int field_num)
6682 {
6683   /* Only Ada types are eligible.  */
6684   if (!ADA_TYPE_P (type))
6685     return 0;
6686
6687   struct type *field_type = type->field (field_num).type ();
6688
6689   return (field_type->code () == TYPE_CODE_UNION
6690           || (is_dynamic_field (type, field_num)
6691               && (TYPE_TARGET_TYPE (field_type)->code ()
6692                   == TYPE_CODE_UNION)));
6693 }
6694
6695 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6696    whose discriminants are contained in the record type OUTER_TYPE,
6697    returns the type of the controlling discriminant for the variant.
6698    May return NULL if the type could not be found.  */
6699
6700 struct type *
6701 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6702 {
6703   const char *name = ada_variant_discrim_name (var_type);
6704
6705   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6706 }
6707
6708 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6709    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6710    represents a 'when others' clause; otherwise 0.  */
6711
6712 static int
6713 ada_is_others_clause (struct type *type, int field_num)
6714 {
6715   const char *name = type->field (field_num).name ();
6716
6717   return (name != NULL && name[0] == 'O');
6718 }
6719
6720 /* Assuming that TYPE0 is the type of the variant part of a record,
6721    returns the name of the discriminant controlling the variant.
6722    The value is valid until the next call to ada_variant_discrim_name.  */
6723
6724 const char *
6725 ada_variant_discrim_name (struct type *type0)
6726 {
6727   static std::string result;
6728   struct type *type;
6729   const char *name;
6730   const char *discrim_end;
6731   const char *discrim_start;
6732
6733   if (type0->code () == TYPE_CODE_PTR)
6734     type = TYPE_TARGET_TYPE (type0);
6735   else
6736     type = type0;
6737
6738   name = ada_type_name (type);
6739
6740   if (name == NULL || name[0] == '\000')
6741     return "";
6742
6743   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6744        discrim_end -= 1)
6745     {
6746       if (startswith (discrim_end, "___XVN"))
6747         break;
6748     }
6749   if (discrim_end == name)
6750     return "";
6751
6752   for (discrim_start = discrim_end; discrim_start != name + 3;
6753        discrim_start -= 1)
6754     {
6755       if (discrim_start == name + 1)
6756         return "";
6757       if ((discrim_start > name + 3
6758            && startswith (discrim_start - 3, "___"))
6759           || discrim_start[-1] == '.')
6760         break;
6761     }
6762
6763   result = std::string (discrim_start, discrim_end - discrim_start);
6764   return result.c_str ();
6765 }
6766
6767 /* Scan STR for a subtype-encoded number, beginning at position K.
6768    Put the position of the character just past the number scanned in
6769    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
6770    Return 1 if there was a valid number at the given position, and 0
6771    otherwise.  A "subtype-encoded" number consists of the absolute value
6772    in decimal, followed by the letter 'm' to indicate a negative number.
6773    Assumes 0m does not occur.  */
6774
6775 int
6776 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6777 {
6778   ULONGEST RU;
6779
6780   if (!isdigit (str[k]))
6781     return 0;
6782
6783   /* Do it the hard way so as not to make any assumption about
6784      the relationship of unsigned long (%lu scan format code) and
6785      LONGEST.  */
6786   RU = 0;
6787   while (isdigit (str[k]))
6788     {
6789       RU = RU * 10 + (str[k] - '0');
6790       k += 1;
6791     }
6792
6793   if (str[k] == 'm')
6794     {
6795       if (R != NULL)
6796         *R = (-(LONGEST) (RU - 1)) - 1;
6797       k += 1;
6798     }
6799   else if (R != NULL)
6800     *R = (LONGEST) RU;
6801
6802   /* NOTE on the above: Technically, C does not say what the results of
6803      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6804      number representable as a LONGEST (although either would probably work
6805      in most implementations).  When RU>0, the locution in the then branch
6806      above is always equivalent to the negative of RU.  */
6807
6808   if (new_k != NULL)
6809     *new_k = k;
6810   return 1;
6811 }
6812
6813 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6814    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6815    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
6816
6817 static int
6818 ada_in_variant (LONGEST val, struct type *type, int field_num)
6819 {
6820   const char *name = type->field (field_num).name ();
6821   int p;
6822
6823   p = 0;
6824   while (1)
6825     {
6826       switch (name[p])
6827         {
6828         case '\0':
6829           return 0;
6830         case 'S':
6831           {
6832             LONGEST W;
6833
6834             if (!ada_scan_number (name, p + 1, &W, &p))
6835               return 0;
6836             if (val == W)
6837               return 1;
6838             break;
6839           }
6840         case 'R':
6841           {
6842             LONGEST L, U;
6843
6844             if (!ada_scan_number (name, p + 1, &L, &p)
6845                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6846               return 0;
6847             if (val >= L && val <= U)
6848               return 1;
6849             break;
6850           }
6851         case 'O':
6852           return 1;
6853         default:
6854           return 0;
6855         }
6856     }
6857 }
6858
6859 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
6860
6861 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6862    ARG_TYPE, extract and return the value of one of its (non-static)
6863    fields.  FIELDNO says which field.   Differs from value_primitive_field
6864    only in that it can handle packed values of arbitrary type.  */
6865
6866 struct value *
6867 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6868                            struct type *arg_type)
6869 {
6870   struct type *type;
6871
6872   arg_type = ada_check_typedef (arg_type);
6873   type = arg_type->field (fieldno).type ();
6874
6875   /* Handle packed fields.  It might be that the field is not packed
6876      relative to its containing structure, but the structure itself is
6877      packed; in this case we must take the bit-field path.  */
6878   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6879     {
6880       int bit_pos = arg_type->field (fieldno).loc_bitpos ();
6881       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6882
6883       return ada_value_primitive_packed_val (arg1,
6884                                              value_contents (arg1).data (),
6885                                              offset + bit_pos / 8,
6886                                              bit_pos % 8, bit_size, type);
6887     }
6888   else
6889     return value_primitive_field (arg1, offset, fieldno, arg_type);
6890 }
6891
6892 /* Find field with name NAME in object of type TYPE.  If found, 
6893    set the following for each argument that is non-null:
6894     - *FIELD_TYPE_P to the field's type; 
6895     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
6896       an object of that type;
6897     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
6898     - *BIT_SIZE_P to its size in bits if the field is packed, and 
6899       0 otherwise;
6900    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6901    fields up to but not including the desired field, or by the total
6902    number of fields if not found.   A NULL value of NAME never
6903    matches; the function just counts visible fields in this case.
6904    
6905    Notice that we need to handle when a tagged record hierarchy
6906    has some components with the same name, like in this scenario:
6907
6908       type Top_T is tagged record
6909          N : Integer := 1;
6910          U : Integer := 974;
6911          A : Integer := 48;
6912       end record;
6913
6914       type Middle_T is new Top.Top_T with record
6915          N : Character := 'a';
6916          C : Integer := 3;
6917       end record;
6918
6919      type Bottom_T is new Middle.Middle_T with record
6920         N : Float := 4.0;
6921         C : Character := '5';
6922         X : Integer := 6;
6923         A : Character := 'J';
6924      end record;
6925
6926    Let's say we now have a variable declared and initialized as follow:
6927
6928      TC : Top_A := new Bottom_T;
6929
6930    And then we use this variable to call this function
6931
6932      procedure Assign (Obj: in out Top_T; TV : Integer);
6933
6934    as follow:
6935
6936       Assign (Top_T (B), 12);
6937
6938    Now, we're in the debugger, and we're inside that procedure
6939    then and we want to print the value of obj.c:
6940
6941    Usually, the tagged record or one of the parent type owns the
6942    component to print and there's no issue but in this particular
6943    case, what does it mean to ask for Obj.C? Since the actual
6944    type for object is type Bottom_T, it could mean two things: type
6945    component C from the Middle_T view, but also component C from
6946    Bottom_T.  So in that "undefined" case, when the component is
6947    not found in the non-resolved type (which includes all the
6948    components of the parent type), then resolve it and see if we
6949    get better luck once expanded.
6950
6951    In the case of homonyms in the derived tagged type, we don't
6952    guaranty anything, and pick the one that's easiest for us
6953    to program.
6954
6955    Returns 1 if found, 0 otherwise.  */
6956
6957 static int
6958 find_struct_field (const char *name, struct type *type, int offset,
6959                    struct type **field_type_p,
6960                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6961                    int *index_p)
6962 {
6963   int i;
6964   int parent_offset = -1;
6965
6966   type = ada_check_typedef (type);
6967
6968   if (field_type_p != NULL)
6969     *field_type_p = NULL;
6970   if (byte_offset_p != NULL)
6971     *byte_offset_p = 0;
6972   if (bit_offset_p != NULL)
6973     *bit_offset_p = 0;
6974   if (bit_size_p != NULL)
6975     *bit_size_p = 0;
6976
6977   for (i = 0; i < type->num_fields (); i += 1)
6978     {
6979       /* These can't be computed using TYPE_FIELD_BITPOS for a dynamic
6980          type.  However, we only need the values to be correct when
6981          the caller asks for them.  */
6982       int bit_pos = 0, fld_offset = 0;
6983       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
6984         {
6985           bit_pos = type->field (i).loc_bitpos ();
6986           fld_offset = offset + bit_pos / 8;
6987         }
6988
6989       const char *t_field_name = type->field (i).name ();
6990
6991       if (t_field_name == NULL)
6992         continue;
6993
6994       else if (ada_is_parent_field (type, i))
6995         {
6996           /* This is a field pointing us to the parent type of a tagged
6997              type.  As hinted in this function's documentation, we give
6998              preference to fields in the current record first, so what
6999              we do here is just record the index of this field before
7000              we skip it.  If it turns out we couldn't find our field
7001              in the current record, then we'll get back to it and search
7002              inside it whether the field might exist in the parent.  */
7003
7004           parent_offset = i;
7005           continue;
7006         }
7007
7008       else if (name != NULL && field_name_match (t_field_name, name))
7009         {
7010           int bit_size = TYPE_FIELD_BITSIZE (type, i);
7011
7012           if (field_type_p != NULL)
7013             *field_type_p = type->field (i).type ();
7014           if (byte_offset_p != NULL)
7015             *byte_offset_p = fld_offset;
7016           if (bit_offset_p != NULL)
7017             *bit_offset_p = bit_pos % 8;
7018           if (bit_size_p != NULL)
7019             *bit_size_p = bit_size;
7020           return 1;
7021         }
7022       else if (ada_is_wrapper_field (type, i))
7023         {
7024           if (find_struct_field (name, type->field (i).type (), fld_offset,
7025                                  field_type_p, byte_offset_p, bit_offset_p,
7026                                  bit_size_p, index_p))
7027             return 1;
7028         }
7029       else if (ada_is_variant_part (type, i))
7030         {
7031           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
7032              fixed type?? */
7033           int j;
7034           struct type *field_type
7035             = ada_check_typedef (type->field (i).type ());
7036
7037           for (j = 0; j < field_type->num_fields (); j += 1)
7038             {
7039               if (find_struct_field (name, field_type->field (j).type (),
7040                                      fld_offset
7041                                      + field_type->field (j).loc_bitpos () / 8,
7042                                      field_type_p, byte_offset_p,
7043                                      bit_offset_p, bit_size_p, index_p))
7044                 return 1;
7045             }
7046         }
7047       else if (index_p != NULL)
7048         *index_p += 1;
7049     }
7050
7051   /* Field not found so far.  If this is a tagged type which
7052      has a parent, try finding that field in the parent now.  */
7053
7054   if (parent_offset != -1)
7055     {
7056       /* As above, only compute the offset when truly needed.  */
7057       int fld_offset = offset;
7058       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7059         {
7060           int bit_pos = type->field (parent_offset).loc_bitpos ();
7061           fld_offset += bit_pos / 8;
7062         }
7063
7064       if (find_struct_field (name, type->field (parent_offset).type (),
7065                              fld_offset, field_type_p, byte_offset_p,
7066                              bit_offset_p, bit_size_p, index_p))
7067         return 1;
7068     }
7069
7070   return 0;
7071 }
7072
7073 /* Number of user-visible fields in record type TYPE.  */
7074
7075 static int
7076 num_visible_fields (struct type *type)
7077 {
7078   int n;
7079
7080   n = 0;
7081   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7082   return n;
7083 }
7084
7085 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
7086    and search in it assuming it has (class) type TYPE.
7087    If found, return value, else return NULL.
7088
7089    Searches recursively through wrapper fields (e.g., '_parent').
7090
7091    In the case of homonyms in the tagged types, please refer to the
7092    long explanation in find_struct_field's function documentation.  */
7093
7094 static struct value *
7095 ada_search_struct_field (const char *name, struct value *arg, int offset,
7096                          struct type *type)
7097 {
7098   int i;
7099   int parent_offset = -1;
7100
7101   type = ada_check_typedef (type);
7102   for (i = 0; i < type->num_fields (); i += 1)
7103     {
7104       const char *t_field_name = type->field (i).name ();
7105
7106       if (t_field_name == NULL)
7107         continue;
7108
7109       else if (ada_is_parent_field (type, i))
7110         {
7111           /* This is a field pointing us to the parent type of a tagged
7112              type.  As hinted in this function's documentation, we give
7113              preference to fields in the current record first, so what
7114              we do here is just record the index of this field before
7115              we skip it.  If it turns out we couldn't find our field
7116              in the current record, then we'll get back to it and search
7117              inside it whether the field might exist in the parent.  */
7118
7119           parent_offset = i;
7120           continue;
7121         }
7122
7123       else if (field_name_match (t_field_name, name))
7124         return ada_value_primitive_field (arg, offset, i, type);
7125
7126       else if (ada_is_wrapper_field (type, i))
7127         {
7128           struct value *v =     /* Do not let indent join lines here.  */
7129             ada_search_struct_field (name, arg,
7130                                      offset + type->field (i).loc_bitpos () / 8,
7131                                      type->field (i).type ());
7132
7133           if (v != NULL)
7134             return v;
7135         }
7136
7137       else if (ada_is_variant_part (type, i))
7138         {
7139           /* PNH: Do we ever get here?  See find_struct_field.  */
7140           int j;
7141           struct type *field_type = ada_check_typedef (type->field (i).type ());
7142           int var_offset = offset + type->field (i).loc_bitpos () / 8;
7143
7144           for (j = 0; j < field_type->num_fields (); j += 1)
7145             {
7146               struct value *v = ada_search_struct_field /* Force line
7147                                                            break.  */
7148                 (name, arg,
7149                  var_offset + field_type->field (j).loc_bitpos () / 8,
7150                  field_type->field (j).type ());
7151
7152               if (v != NULL)
7153                 return v;
7154             }
7155         }
7156     }
7157
7158   /* Field not found so far.  If this is a tagged type which
7159      has a parent, try finding that field in the parent now.  */
7160
7161   if (parent_offset != -1)
7162     {
7163       struct value *v = ada_search_struct_field (
7164         name, arg, offset + type->field (parent_offset).loc_bitpos () / 8,
7165         type->field (parent_offset).type ());
7166
7167       if (v != NULL)
7168         return v;
7169     }
7170
7171   return NULL;
7172 }
7173
7174 static struct value *ada_index_struct_field_1 (int *, struct value *,
7175                                                int, struct type *);
7176
7177
7178 /* Return field #INDEX in ARG, where the index is that returned by
7179  * find_struct_field through its INDEX_P argument.  Adjust the address
7180  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7181  * If found, return value, else return NULL.  */
7182
7183 static struct value *
7184 ada_index_struct_field (int index, struct value *arg, int offset,
7185                         struct type *type)
7186 {
7187   return ada_index_struct_field_1 (&index, arg, offset, type);
7188 }
7189
7190
7191 /* Auxiliary function for ada_index_struct_field.  Like
7192  * ada_index_struct_field, but takes index from *INDEX_P and modifies
7193  * *INDEX_P.  */
7194
7195 static struct value *
7196 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7197                           struct type *type)
7198 {
7199   int i;
7200   type = ada_check_typedef (type);
7201
7202   for (i = 0; i < type->num_fields (); i += 1)
7203     {
7204       if (type->field (i).name () == NULL)
7205         continue;
7206       else if (ada_is_wrapper_field (type, i))
7207         {
7208           struct value *v =     /* Do not let indent join lines here.  */
7209             ada_index_struct_field_1 (index_p, arg,
7210                                       offset + type->field (i).loc_bitpos () / 8,
7211                                       type->field (i).type ());
7212
7213           if (v != NULL)
7214             return v;
7215         }
7216
7217       else if (ada_is_variant_part (type, i))
7218         {
7219           /* PNH: Do we ever get here?  See ada_search_struct_field,
7220              find_struct_field.  */
7221           error (_("Cannot assign this kind of variant record"));
7222         }
7223       else if (*index_p == 0)
7224         return ada_value_primitive_field (arg, offset, i, type);
7225       else
7226         *index_p -= 1;
7227     }
7228   return NULL;
7229 }
7230
7231 /* Return a string representation of type TYPE.  */
7232
7233 static std::string
7234 type_as_string (struct type *type)
7235 {
7236   string_file tmp_stream;
7237
7238   type_print (type, "", &tmp_stream, -1);
7239
7240   return tmp_stream.release ();
7241 }
7242
7243 /* Given a type TYPE, look up the type of the component of type named NAME.
7244    If DISPP is non-null, add its byte displacement from the beginning of a
7245    structure (pointed to by a value) of type TYPE to *DISPP (does not
7246    work for packed fields).
7247
7248    Matches any field whose name has NAME as a prefix, possibly
7249    followed by "___".
7250
7251    TYPE can be either a struct or union.  If REFOK, TYPE may also 
7252    be a (pointer or reference)+ to a struct or union, and the
7253    ultimate target type will be searched.
7254
7255    Looks recursively into variant clauses and parent types.
7256
7257    In the case of homonyms in the tagged types, please refer to the
7258    long explanation in find_struct_field's function documentation.
7259
7260    If NOERR is nonzero, return NULL if NAME is not suitably defined or
7261    TYPE is not a type of the right kind.  */
7262
7263 static struct type *
7264 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7265                             int noerr)
7266 {
7267   int i;
7268   int parent_offset = -1;
7269
7270   if (name == NULL)
7271     goto BadName;
7272
7273   if (refok && type != NULL)
7274     while (1)
7275       {
7276         type = ada_check_typedef (type);
7277         if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
7278           break;
7279         type = TYPE_TARGET_TYPE (type);
7280       }
7281
7282   if (type == NULL
7283       || (type->code () != TYPE_CODE_STRUCT
7284           && type->code () != TYPE_CODE_UNION))
7285     {
7286       if (noerr)
7287         return NULL;
7288
7289       error (_("Type %s is not a structure or union type"),
7290              type != NULL ? type_as_string (type).c_str () : _("(null)"));
7291     }
7292
7293   type = to_static_fixed_type (type);
7294
7295   for (i = 0; i < type->num_fields (); i += 1)
7296     {
7297       const char *t_field_name = type->field (i).name ();
7298       struct type *t;
7299
7300       if (t_field_name == NULL)
7301         continue;
7302
7303       else if (ada_is_parent_field (type, i))
7304         {
7305           /* This is a field pointing us to the parent type of a tagged
7306              type.  As hinted in this function's documentation, we give
7307              preference to fields in the current record first, so what
7308              we do here is just record the index of this field before
7309              we skip it.  If it turns out we couldn't find our field
7310              in the current record, then we'll get back to it and search
7311              inside it whether the field might exist in the parent.  */
7312
7313           parent_offset = i;
7314           continue;
7315         }
7316
7317       else if (field_name_match (t_field_name, name))
7318         return type->field (i).type ();
7319
7320       else if (ada_is_wrapper_field (type, i))
7321         {
7322           t = ada_lookup_struct_elt_type (type->field (i).type (), name,
7323                                           0, 1);
7324           if (t != NULL)
7325             return t;
7326         }
7327
7328       else if (ada_is_variant_part (type, i))
7329         {
7330           int j;
7331           struct type *field_type = ada_check_typedef (type->field (i).type ());
7332
7333           for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
7334             {
7335               /* FIXME pnh 2008/01/26: We check for a field that is
7336                  NOT wrapped in a struct, since the compiler sometimes
7337                  generates these for unchecked variant types.  Revisit
7338                  if the compiler changes this practice.  */
7339               const char *v_field_name = field_type->field (j).name ();
7340
7341               if (v_field_name != NULL 
7342                   && field_name_match (v_field_name, name))
7343                 t = field_type->field (j).type ();
7344               else
7345                 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
7346                                                 name, 0, 1);
7347
7348               if (t != NULL)
7349                 return t;
7350             }
7351         }
7352
7353     }
7354
7355     /* Field not found so far.  If this is a tagged type which
7356        has a parent, try finding that field in the parent now.  */
7357
7358     if (parent_offset != -1)
7359       {
7360         struct type *t;
7361
7362         t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
7363                                         name, 0, 1);
7364         if (t != NULL)
7365           return t;
7366       }
7367
7368 BadName:
7369   if (!noerr)
7370     {
7371       const char *name_str = name != NULL ? name : _("<null>");
7372
7373       error (_("Type %s has no component named %s"),
7374              type_as_string (type).c_str (), name_str);
7375     }
7376
7377   return NULL;
7378 }
7379
7380 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7381    within a value of type OUTER_TYPE, return true iff VAR_TYPE
7382    represents an unchecked union (that is, the variant part of a
7383    record that is named in an Unchecked_Union pragma).  */
7384
7385 static int
7386 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7387 {
7388   const char *discrim_name = ada_variant_discrim_name (var_type);
7389
7390   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7391 }
7392
7393
7394 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7395    within OUTER, determine which variant clause (field number in VAR_TYPE,
7396    numbering from 0) is applicable.  Returns -1 if none are.  */
7397
7398 int
7399 ada_which_variant_applies (struct type *var_type, struct value *outer)
7400 {
7401   int others_clause;
7402   int i;
7403   const char *discrim_name = ada_variant_discrim_name (var_type);
7404   struct value *discrim;
7405   LONGEST discrim_val;
7406
7407   /* Using plain value_from_contents_and_address here causes problems
7408      because we will end up trying to resolve a type that is currently
7409      being constructed.  */
7410   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7411   if (discrim == NULL)
7412     return -1;
7413   discrim_val = value_as_long (discrim);
7414
7415   others_clause = -1;
7416   for (i = 0; i < var_type->num_fields (); i += 1)
7417     {
7418       if (ada_is_others_clause (var_type, i))
7419         others_clause = i;
7420       else if (ada_in_variant (discrim_val, var_type, i))
7421         return i;
7422     }
7423
7424   return others_clause;
7425 }
7426 \f
7427
7428
7429                                 /* Dynamic-Sized Records */
7430
7431 /* Strategy: The type ostensibly attached to a value with dynamic size
7432    (i.e., a size that is not statically recorded in the debugging
7433    data) does not accurately reflect the size or layout of the value.
7434    Our strategy is to convert these values to values with accurate,
7435    conventional types that are constructed on the fly.  */
7436
7437 /* There is a subtle and tricky problem here.  In general, we cannot
7438    determine the size of dynamic records without its data.  However,
7439    the 'struct value' data structure, which GDB uses to represent
7440    quantities in the inferior process (the target), requires the size
7441    of the type at the time of its allocation in order to reserve space
7442    for GDB's internal copy of the data.  That's why the
7443    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7444    rather than struct value*s.
7445
7446    However, GDB's internal history variables ($1, $2, etc.) are
7447    struct value*s containing internal copies of the data that are not, in
7448    general, the same as the data at their corresponding addresses in
7449    the target.  Fortunately, the types we give to these values are all
7450    conventional, fixed-size types (as per the strategy described
7451    above), so that we don't usually have to perform the
7452    'to_fixed_xxx_type' conversions to look at their values.
7453    Unfortunately, there is one exception: if one of the internal
7454    history variables is an array whose elements are unconstrained
7455    records, then we will need to create distinct fixed types for each
7456    element selected.  */
7457
7458 /* The upshot of all of this is that many routines take a (type, host
7459    address, target address) triple as arguments to represent a value.
7460    The host address, if non-null, is supposed to contain an internal
7461    copy of the relevant data; otherwise, the program is to consult the
7462    target at the target address.  */
7463
7464 /* Assuming that VAL0 represents a pointer value, the result of
7465    dereferencing it.  Differs from value_ind in its treatment of
7466    dynamic-sized types.  */
7467
7468 struct value *
7469 ada_value_ind (struct value *val0)
7470 {
7471   struct value *val = value_ind (val0);
7472
7473   if (ada_is_tagged_type (value_type (val), 0))
7474     val = ada_tag_value_at_base_address (val);
7475
7476   return ada_to_fixed_value (val);
7477 }
7478
7479 /* The value resulting from dereferencing any "reference to"
7480    qualifiers on VAL0.  */
7481
7482 static struct value *
7483 ada_coerce_ref (struct value *val0)
7484 {
7485   if (value_type (val0)->code () == TYPE_CODE_REF)
7486     {
7487       struct value *val = val0;
7488
7489       val = coerce_ref (val);
7490
7491       if (ada_is_tagged_type (value_type (val), 0))
7492         val = ada_tag_value_at_base_address (val);
7493
7494       return ada_to_fixed_value (val);
7495     }
7496   else
7497     return val0;
7498 }
7499
7500 /* Return the bit alignment required for field #F of template type TYPE.  */
7501
7502 static unsigned int
7503 field_alignment (struct type *type, int f)
7504 {
7505   const char *name = type->field (f).name ();
7506   int len;
7507   int align_offset;
7508
7509   /* The field name should never be null, unless the debugging information
7510      is somehow malformed.  In this case, we assume the field does not
7511      require any alignment.  */
7512   if (name == NULL)
7513     return 1;
7514
7515   len = strlen (name);
7516
7517   if (!isdigit (name[len - 1]))
7518     return 1;
7519
7520   if (isdigit (name[len - 2]))
7521     align_offset = len - 2;
7522   else
7523     align_offset = len - 1;
7524
7525   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7526     return TARGET_CHAR_BIT;
7527
7528   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7529 }
7530
7531 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7532
7533 static struct symbol *
7534 ada_find_any_type_symbol (const char *name)
7535 {
7536   struct symbol *sym;
7537
7538   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7539   if (sym != NULL && sym->aclass () == LOC_TYPEDEF)
7540     return sym;
7541
7542   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7543   return sym;
7544 }
7545
7546 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7547    solely for types defined by debug info, it will not search the GDB
7548    primitive types.  */
7549
7550 static struct type *
7551 ada_find_any_type (const char *name)
7552 {
7553   struct symbol *sym = ada_find_any_type_symbol (name);
7554
7555   if (sym != NULL)
7556     return sym->type ();
7557
7558   return NULL;
7559 }
7560
7561 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7562    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
7563    symbol, in which case it is returned.  Otherwise, this looks for
7564    symbols whose name is that of NAME_SYM suffixed with  "___XR".
7565    Return symbol if found, and NULL otherwise.  */
7566
7567 static bool
7568 ada_is_renaming_symbol (struct symbol *name_sym)
7569 {
7570   const char *name = name_sym->linkage_name ();
7571   return strstr (name, "___XR") != NULL;
7572 }
7573
7574 /* Because of GNAT encoding conventions, several GDB symbols may match a
7575    given type name.  If the type denoted by TYPE0 is to be preferred to
7576    that of TYPE1 for purposes of type printing, return non-zero;
7577    otherwise return 0.  */
7578
7579 int
7580 ada_prefer_type (struct type *type0, struct type *type1)
7581 {
7582   if (type1 == NULL)
7583     return 1;
7584   else if (type0 == NULL)
7585     return 0;
7586   else if (type1->code () == TYPE_CODE_VOID)
7587     return 1;
7588   else if (type0->code () == TYPE_CODE_VOID)
7589     return 0;
7590   else if (type1->name () == NULL && type0->name () != NULL)
7591     return 1;
7592   else if (ada_is_constrained_packed_array_type (type0))
7593     return 1;
7594   else if (ada_is_array_descriptor_type (type0)
7595            && !ada_is_array_descriptor_type (type1))
7596     return 1;
7597   else
7598     {
7599       const char *type0_name = type0->name ();
7600       const char *type1_name = type1->name ();
7601
7602       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7603           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7604         return 1;
7605     }
7606   return 0;
7607 }
7608
7609 /* The name of TYPE, which is its TYPE_NAME.  Null if TYPE is
7610    null.  */
7611
7612 const char *
7613 ada_type_name (struct type *type)
7614 {
7615   if (type == NULL)
7616     return NULL;
7617   return type->name ();
7618 }
7619
7620 /* Search the list of "descriptive" types associated to TYPE for a type
7621    whose name is NAME.  */
7622
7623 static struct type *
7624 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7625 {
7626   struct type *result, *tmp;
7627
7628   if (ada_ignore_descriptive_types_p)
7629     return NULL;
7630
7631   /* If there no descriptive-type info, then there is no parallel type
7632      to be found.  */
7633   if (!HAVE_GNAT_AUX_INFO (type))
7634     return NULL;
7635
7636   result = TYPE_DESCRIPTIVE_TYPE (type);
7637   while (result != NULL)
7638     {
7639       const char *result_name = ada_type_name (result);
7640
7641       if (result_name == NULL)
7642         {
7643           warning (_("unexpected null name on descriptive type"));
7644           return NULL;
7645         }
7646
7647       /* If the names match, stop.  */
7648       if (strcmp (result_name, name) == 0)
7649         break;
7650
7651       /* Otherwise, look at the next item on the list, if any.  */
7652       if (HAVE_GNAT_AUX_INFO (result))
7653         tmp = TYPE_DESCRIPTIVE_TYPE (result);
7654       else
7655         tmp = NULL;
7656
7657       /* If not found either, try after having resolved the typedef.  */
7658       if (tmp != NULL)
7659         result = tmp;
7660       else
7661         {
7662           result = check_typedef (result);
7663           if (HAVE_GNAT_AUX_INFO (result))
7664             result = TYPE_DESCRIPTIVE_TYPE (result);
7665           else
7666             result = NULL;
7667         }
7668     }
7669
7670   /* If we didn't find a match, see whether this is a packed array.  With
7671      older compilers, the descriptive type information is either absent or
7672      irrelevant when it comes to packed arrays so the above lookup fails.
7673      Fall back to using a parallel lookup by name in this case.  */
7674   if (result == NULL && ada_is_constrained_packed_array_type (type))
7675     return ada_find_any_type (name);
7676
7677   return result;
7678 }
7679
7680 /* Find a parallel type to TYPE with the specified NAME, using the
7681    descriptive type taken from the debugging information, if available,
7682    and otherwise using the (slower) name-based method.  */
7683
7684 static struct type *
7685 ada_find_parallel_type_with_name (struct type *type, const char *name)
7686 {
7687   struct type *result = NULL;
7688
7689   if (HAVE_GNAT_AUX_INFO (type))
7690     result = find_parallel_type_by_descriptive_type (type, name);
7691   else
7692     result = ada_find_any_type (name);
7693
7694   return result;
7695 }
7696
7697 /* Same as above, but specify the name of the parallel type by appending
7698    SUFFIX to the name of TYPE.  */
7699
7700 struct type *
7701 ada_find_parallel_type (struct type *type, const char *suffix)
7702 {
7703   char *name;
7704   const char *type_name = ada_type_name (type);
7705   int len;
7706
7707   if (type_name == NULL)
7708     return NULL;
7709
7710   len = strlen (type_name);
7711
7712   name = (char *) alloca (len + strlen (suffix) + 1);
7713
7714   strcpy (name, type_name);
7715   strcpy (name + len, suffix);
7716
7717   return ada_find_parallel_type_with_name (type, name);
7718 }
7719
7720 /* If TYPE is a variable-size record type, return the corresponding template
7721    type describing its fields.  Otherwise, return NULL.  */
7722
7723 static struct type *
7724 dynamic_template_type (struct type *type)
7725 {
7726   type = ada_check_typedef (type);
7727
7728   if (type == NULL || type->code () != TYPE_CODE_STRUCT
7729       || ada_type_name (type) == NULL)
7730     return NULL;
7731   else
7732     {
7733       int len = strlen (ada_type_name (type));
7734
7735       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7736         return type;
7737       else
7738         return ada_find_parallel_type (type, "___XVE");
7739     }
7740 }
7741
7742 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7743    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
7744
7745 static int
7746 is_dynamic_field (struct type *templ_type, int field_num)
7747 {
7748   const char *name = templ_type->field (field_num).name ();
7749
7750   return name != NULL
7751     && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7752     && strstr (name, "___XVL") != NULL;
7753 }
7754
7755 /* The index of the variant field of TYPE, or -1 if TYPE does not
7756    represent a variant record type.  */
7757
7758 static int
7759 variant_field_index (struct type *type)
7760 {
7761   int f;
7762
7763   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7764     return -1;
7765
7766   for (f = 0; f < type->num_fields (); f += 1)
7767     {
7768       if (ada_is_variant_part (type, f))
7769         return f;
7770     }
7771   return -1;
7772 }
7773
7774 /* A record type with no fields.  */
7775
7776 static struct type *
7777 empty_record (struct type *templ)
7778 {
7779   struct type *type = alloc_type_copy (templ);
7780
7781   type->set_code (TYPE_CODE_STRUCT);
7782   INIT_NONE_SPECIFIC (type);
7783   type->set_name ("<empty>");
7784   TYPE_LENGTH (type) = 0;
7785   return type;
7786 }
7787
7788 /* An ordinary record type (with fixed-length fields) that describes
7789    the value of type TYPE at VALADDR or ADDRESS (see comments at
7790    the beginning of this section) VAL according to GNAT conventions.
7791    DVAL0 should describe the (portion of a) record that contains any
7792    necessary discriminants.  It should be NULL if value_type (VAL) is
7793    an outer-level type (i.e., as opposed to a branch of a variant.)  A
7794    variant field (unless unchecked) is replaced by a particular branch
7795    of the variant.
7796
7797    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7798    length are not statically known are discarded.  As a consequence,
7799    VALADDR, ADDRESS and DVAL0 are ignored.
7800
7801    NOTE: Limitations: For now, we assume that dynamic fields and
7802    variants occupy whole numbers of bytes.  However, they need not be
7803    byte-aligned.  */
7804
7805 struct type *
7806 ada_template_to_fixed_record_type_1 (struct type *type,
7807                                      const gdb_byte *valaddr,
7808                                      CORE_ADDR address, struct value *dval0,
7809                                      int keep_dynamic_fields)
7810 {
7811   struct value *mark = value_mark ();
7812   struct value *dval;
7813   struct type *rtype;
7814   int nfields, bit_len;
7815   int variant_field;
7816   long off;
7817   int fld_bit_len;
7818   int f;
7819
7820   /* Compute the number of fields in this record type that are going
7821      to be processed: unless keep_dynamic_fields, this includes only
7822      fields whose position and length are static will be processed.  */
7823   if (keep_dynamic_fields)
7824     nfields = type->num_fields ();
7825   else
7826     {
7827       nfields = 0;
7828       while (nfields < type->num_fields ()
7829              && !ada_is_variant_part (type, nfields)
7830              && !is_dynamic_field (type, nfields))
7831         nfields++;
7832     }
7833
7834   rtype = alloc_type_copy (type);
7835   rtype->set_code (TYPE_CODE_STRUCT);
7836   INIT_NONE_SPECIFIC (rtype);
7837   rtype->set_num_fields (nfields);
7838   rtype->set_fields
7839    ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7840   rtype->set_name (ada_type_name (type));
7841   rtype->set_is_fixed_instance (true);
7842
7843   off = 0;
7844   bit_len = 0;
7845   variant_field = -1;
7846
7847   for (f = 0; f < nfields; f += 1)
7848     {
7849       off = align_up (off, field_alignment (type, f))
7850         + type->field (f).loc_bitpos ();
7851       rtype->field (f).set_loc_bitpos (off);
7852       TYPE_FIELD_BITSIZE (rtype, f) = 0;
7853
7854       if (ada_is_variant_part (type, f))
7855         {
7856           variant_field = f;
7857           fld_bit_len = 0;
7858         }
7859       else if (is_dynamic_field (type, f))
7860         {
7861           const gdb_byte *field_valaddr = valaddr;
7862           CORE_ADDR field_address = address;
7863           struct type *field_type =
7864             TYPE_TARGET_TYPE (type->field (f).type ());
7865
7866           if (dval0 == NULL)
7867             {
7868               /* Using plain value_from_contents_and_address here
7869                  causes problems because we will end up trying to
7870                  resolve a type that is currently being
7871                  constructed.  */
7872               dval = value_from_contents_and_address_unresolved (rtype,
7873                                                                  valaddr,
7874                                                                  address);
7875               rtype = value_type (dval);
7876             }
7877           else
7878             dval = dval0;
7879
7880           /* If the type referenced by this field is an aligner type, we need
7881              to unwrap that aligner type, because its size might not be set.
7882              Keeping the aligner type would cause us to compute the wrong
7883              size for this field, impacting the offset of the all the fields
7884              that follow this one.  */
7885           if (ada_is_aligner_type (field_type))
7886             {
7887               long field_offset = type->field (f).loc_bitpos ();
7888
7889               field_valaddr = cond_offset_host (field_valaddr, field_offset);
7890               field_address = cond_offset_target (field_address, field_offset);
7891               field_type = ada_aligned_type (field_type);
7892             }
7893
7894           field_valaddr = cond_offset_host (field_valaddr,
7895                                             off / TARGET_CHAR_BIT);
7896           field_address = cond_offset_target (field_address,
7897                                               off / TARGET_CHAR_BIT);
7898
7899           /* Get the fixed type of the field.  Note that, in this case,
7900              we do not want to get the real type out of the tag: if
7901              the current field is the parent part of a tagged record,
7902              we will get the tag of the object.  Clearly wrong: the real
7903              type of the parent is not the real type of the child.  We
7904              would end up in an infinite loop.  */
7905           field_type = ada_get_base_type (field_type);
7906           field_type = ada_to_fixed_type (field_type, field_valaddr,
7907                                           field_address, dval, 0);
7908
7909           rtype->field (f).set_type (field_type);
7910           rtype->field (f).set_name (type->field (f).name ());
7911           /* The multiplication can potentially overflow.  But because
7912              the field length has been size-checked just above, and
7913              assuming that the maximum size is a reasonable value,
7914              an overflow should not happen in practice.  So rather than
7915              adding overflow recovery code to this already complex code,
7916              we just assume that it's not going to happen.  */
7917           fld_bit_len =
7918             TYPE_LENGTH (rtype->field (f).type ()) * TARGET_CHAR_BIT;
7919         }
7920       else
7921         {
7922           /* Note: If this field's type is a typedef, it is important
7923              to preserve the typedef layer.
7924
7925              Otherwise, we might be transforming a typedef to a fat
7926              pointer (encoding a pointer to an unconstrained array),
7927              into a basic fat pointer (encoding an unconstrained
7928              array).  As both types are implemented using the same
7929              structure, the typedef is the only clue which allows us
7930              to distinguish between the two options.  Stripping it
7931              would prevent us from printing this field appropriately.  */
7932           rtype->field (f).set_type (type->field (f).type ());
7933           rtype->field (f).set_name (type->field (f).name ());
7934           if (TYPE_FIELD_BITSIZE (type, f) > 0)
7935             fld_bit_len =
7936               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7937           else
7938             {
7939               struct type *field_type = type->field (f).type ();
7940
7941               /* We need to be careful of typedefs when computing
7942                  the length of our field.  If this is a typedef,
7943                  get the length of the target type, not the length
7944                  of the typedef.  */
7945               if (field_type->code () == TYPE_CODE_TYPEDEF)
7946                 field_type = ada_typedef_target_type (field_type);
7947
7948               fld_bit_len =
7949                 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7950             }
7951         }
7952       if (off + fld_bit_len > bit_len)
7953         bit_len = off + fld_bit_len;
7954       off += fld_bit_len;
7955       TYPE_LENGTH (rtype) =
7956         align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7957     }
7958
7959   /* We handle the variant part, if any, at the end because of certain
7960      odd cases in which it is re-ordered so as NOT to be the last field of
7961      the record.  This can happen in the presence of representation
7962      clauses.  */
7963   if (variant_field >= 0)
7964     {
7965       struct type *branch_type;
7966
7967       off = rtype->field (variant_field).loc_bitpos ();
7968
7969       if (dval0 == NULL)
7970         {
7971           /* Using plain value_from_contents_and_address here causes
7972              problems because we will end up trying to resolve a type
7973              that is currently being constructed.  */
7974           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
7975                                                              address);
7976           rtype = value_type (dval);
7977         }
7978       else
7979         dval = dval0;
7980
7981       branch_type =
7982         to_fixed_variant_branch_type
7983         (type->field (variant_field).type (),
7984          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7985          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7986       if (branch_type == NULL)
7987         {
7988           for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
7989             rtype->field (f - 1) = rtype->field (f);
7990           rtype->set_num_fields (rtype->num_fields () - 1);
7991         }
7992       else
7993         {
7994           rtype->field (variant_field).set_type (branch_type);
7995           rtype->field (variant_field).set_name ("S");
7996           fld_bit_len =
7997             TYPE_LENGTH (rtype->field (variant_field).type ()) *
7998             TARGET_CHAR_BIT;
7999           if (off + fld_bit_len > bit_len)
8000             bit_len = off + fld_bit_len;
8001           TYPE_LENGTH (rtype) =
8002             align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8003         }
8004     }
8005
8006   /* According to exp_dbug.ads, the size of TYPE for variable-size records
8007      should contain the alignment of that record, which should be a strictly
8008      positive value.  If null or negative, then something is wrong, most
8009      probably in the debug info.  In that case, we don't round up the size
8010      of the resulting type.  If this record is not part of another structure,
8011      the current RTYPE length might be good enough for our purposes.  */
8012   if (TYPE_LENGTH (type) <= 0)
8013     {
8014       if (rtype->name ())
8015         warning (_("Invalid type size for `%s' detected: %s."),
8016                  rtype->name (), pulongest (TYPE_LENGTH (type)));
8017       else
8018         warning (_("Invalid type size for <unnamed> detected: %s."),
8019                  pulongest (TYPE_LENGTH (type)));
8020     }
8021   else
8022     {
8023       TYPE_LENGTH (rtype) = align_up (TYPE_LENGTH (rtype),
8024                                       TYPE_LENGTH (type));
8025     }
8026
8027   value_free_to_mark (mark);
8028   return rtype;
8029 }
8030
8031 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8032    of 1.  */
8033
8034 static struct type *
8035 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8036                                CORE_ADDR address, struct value *dval0)
8037 {
8038   return ada_template_to_fixed_record_type_1 (type, valaddr,
8039                                               address, dval0, 1);
8040 }
8041
8042 /* An ordinary record type in which ___XVL-convention fields and
8043    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8044    static approximations, containing all possible fields.  Uses
8045    no runtime values.  Useless for use in values, but that's OK,
8046    since the results are used only for type determinations.   Works on both
8047    structs and unions.  Representation note: to save space, we memorize
8048    the result of this function in the TYPE_TARGET_TYPE of the
8049    template type.  */
8050
8051 static struct type *
8052 template_to_static_fixed_type (struct type *type0)
8053 {
8054   struct type *type;
8055   int nfields;
8056   int f;
8057
8058   /* No need no do anything if the input type is already fixed.  */
8059   if (type0->is_fixed_instance ())
8060     return type0;
8061
8062   /* Likewise if we already have computed the static approximation.  */
8063   if (TYPE_TARGET_TYPE (type0) != NULL)
8064     return TYPE_TARGET_TYPE (type0);
8065
8066   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
8067   type = type0;
8068   nfields = type0->num_fields ();
8069
8070   /* Whether or not we cloned TYPE0, cache the result so that we don't do
8071      recompute all over next time.  */
8072   TYPE_TARGET_TYPE (type0) = type;
8073
8074   for (f = 0; f < nfields; f += 1)
8075     {
8076       struct type *field_type = type0->field (f).type ();
8077       struct type *new_type;
8078
8079       if (is_dynamic_field (type0, f))
8080         {
8081           field_type = ada_check_typedef (field_type);
8082           new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8083         }
8084       else
8085         new_type = static_unwrap_type (field_type);
8086
8087       if (new_type != field_type)
8088         {
8089           /* Clone TYPE0 only the first time we get a new field type.  */
8090           if (type == type0)
8091             {
8092               TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8093               type->set_code (type0->code ());
8094               INIT_NONE_SPECIFIC (type);
8095               type->set_num_fields (nfields);
8096
8097               field *fields =
8098                 ((struct field *)
8099                  TYPE_ALLOC (type, nfields * sizeof (struct field)));
8100               memcpy (fields, type0->fields (),
8101                       sizeof (struct field) * nfields);
8102               type->set_fields (fields);
8103
8104               type->set_name (ada_type_name (type0));
8105               type->set_is_fixed_instance (true);
8106               TYPE_LENGTH (type) = 0;
8107             }
8108           type->field (f).set_type (new_type);
8109           type->field (f).set_name (type0->field (f).name ());
8110         }
8111     }
8112
8113   return type;
8114 }
8115
8116 /* Given an object of type TYPE whose contents are at VALADDR and
8117    whose address in memory is ADDRESS, returns a revision of TYPE,
8118    which should be a non-dynamic-sized record, in which the variant
8119    part, if any, is replaced with the appropriate branch.  Looks
8120    for discriminant values in DVAL0, which can be NULL if the record
8121    contains the necessary discriminant values.  */
8122
8123 static struct type *
8124 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8125                                    CORE_ADDR address, struct value *dval0)
8126 {
8127   struct value *mark = value_mark ();
8128   struct value *dval;
8129   struct type *rtype;
8130   struct type *branch_type;
8131   int nfields = type->num_fields ();
8132   int variant_field = variant_field_index (type);
8133
8134   if (variant_field == -1)
8135     return type;
8136
8137   if (dval0 == NULL)
8138     {
8139       dval = value_from_contents_and_address (type, valaddr, address);
8140       type = value_type (dval);
8141     }
8142   else
8143     dval = dval0;
8144
8145   rtype = alloc_type_copy (type);
8146   rtype->set_code (TYPE_CODE_STRUCT);
8147   INIT_NONE_SPECIFIC (rtype);
8148   rtype->set_num_fields (nfields);
8149
8150   field *fields =
8151     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8152   memcpy (fields, type->fields (), sizeof (struct field) * nfields);
8153   rtype->set_fields (fields);
8154
8155   rtype->set_name (ada_type_name (type));
8156   rtype->set_is_fixed_instance (true);
8157   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8158
8159   branch_type = to_fixed_variant_branch_type
8160     (type->field (variant_field).type (),
8161      cond_offset_host (valaddr,
8162                        type->field (variant_field).loc_bitpos ()
8163                        / TARGET_CHAR_BIT),
8164      cond_offset_target (address,
8165                          type->field (variant_field).loc_bitpos ()
8166                          / TARGET_CHAR_BIT), dval);
8167   if (branch_type == NULL)
8168     {
8169       int f;
8170
8171       for (f = variant_field + 1; f < nfields; f += 1)
8172         rtype->field (f - 1) = rtype->field (f);
8173       rtype->set_num_fields (rtype->num_fields () - 1);
8174     }
8175   else
8176     {
8177       rtype->field (variant_field).set_type (branch_type);
8178       rtype->field (variant_field).set_name ("S");
8179       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8180       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8181     }
8182   TYPE_LENGTH (rtype) -= TYPE_LENGTH (type->field (variant_field).type ());
8183
8184   value_free_to_mark (mark);
8185   return rtype;
8186 }
8187
8188 /* An ordinary record type (with fixed-length fields) that describes
8189    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8190    beginning of this section].   Any necessary discriminants' values
8191    should be in DVAL, a record value; it may be NULL if the object
8192    at ADDR itself contains any necessary discriminant values.
8193    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8194    values from the record are needed.  Except in the case that DVAL,
8195    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8196    unchecked) is replaced by a particular branch of the variant.
8197
8198    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8199    is questionable and may be removed.  It can arise during the
8200    processing of an unconstrained-array-of-record type where all the
8201    variant branches have exactly the same size.  This is because in
8202    such cases, the compiler does not bother to use the XVS convention
8203    when encoding the record.  I am currently dubious of this
8204    shortcut and suspect the compiler should be altered.  FIXME.  */
8205
8206 static struct type *
8207 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8208                       CORE_ADDR address, struct value *dval)
8209 {
8210   struct type *templ_type;
8211
8212   if (type0->is_fixed_instance ())
8213     return type0;
8214
8215   templ_type = dynamic_template_type (type0);
8216
8217   if (templ_type != NULL)
8218     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8219   else if (variant_field_index (type0) >= 0)
8220     {
8221       if (dval == NULL && valaddr == NULL && address == 0)
8222         return type0;
8223       return to_record_with_fixed_variant_part (type0, valaddr, address,
8224                                                 dval);
8225     }
8226   else
8227     {
8228       type0->set_is_fixed_instance (true);
8229       return type0;
8230     }
8231
8232 }
8233
8234 /* An ordinary record type (with fixed-length fields) that describes
8235    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8236    union type.  Any necessary discriminants' values should be in DVAL,
8237    a record value.  That is, this routine selects the appropriate
8238    branch of the union at ADDR according to the discriminant value
8239    indicated in the union's type name.  Returns VAR_TYPE0 itself if
8240    it represents a variant subject to a pragma Unchecked_Union.  */
8241
8242 static struct type *
8243 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8244                               CORE_ADDR address, struct value *dval)
8245 {
8246   int which;
8247   struct type *templ_type;
8248   struct type *var_type;
8249
8250   if (var_type0->code () == TYPE_CODE_PTR)
8251     var_type = TYPE_TARGET_TYPE (var_type0);
8252   else
8253     var_type = var_type0;
8254
8255   templ_type = ada_find_parallel_type (var_type, "___XVU");
8256
8257   if (templ_type != NULL)
8258     var_type = templ_type;
8259
8260   if (is_unchecked_variant (var_type, value_type (dval)))
8261       return var_type0;
8262   which = ada_which_variant_applies (var_type, dval);
8263
8264   if (which < 0)
8265     return empty_record (var_type);
8266   else if (is_dynamic_field (var_type, which))
8267     return to_fixed_record_type
8268       (TYPE_TARGET_TYPE (var_type->field (which).type ()),
8269        valaddr, address, dval);
8270   else if (variant_field_index (var_type->field (which).type ()) >= 0)
8271     return
8272       to_fixed_record_type
8273       (var_type->field (which).type (), valaddr, address, dval);
8274   else
8275     return var_type->field (which).type ();
8276 }
8277
8278 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8279    ENCODING_TYPE, a type following the GNAT conventions for discrete
8280    type encodings, only carries redundant information.  */
8281
8282 static int
8283 ada_is_redundant_range_encoding (struct type *range_type,
8284                                  struct type *encoding_type)
8285 {
8286   const char *bounds_str;
8287   int n;
8288   LONGEST lo, hi;
8289
8290   gdb_assert (range_type->code () == TYPE_CODE_RANGE);
8291
8292   if (get_base_type (range_type)->code ()
8293       != get_base_type (encoding_type)->code ())
8294     {
8295       /* The compiler probably used a simple base type to describe
8296          the range type instead of the range's actual base type,
8297          expecting us to get the real base type from the encoding
8298          anyway.  In this situation, the encoding cannot be ignored
8299          as redundant.  */
8300       return 0;
8301     }
8302
8303   if (is_dynamic_type (range_type))
8304     return 0;
8305
8306   if (encoding_type->name () == NULL)
8307     return 0;
8308
8309   bounds_str = strstr (encoding_type->name (), "___XDLU_");
8310   if (bounds_str == NULL)
8311     return 0;
8312
8313   n = 8; /* Skip "___XDLU_".  */
8314   if (!ada_scan_number (bounds_str, n, &lo, &n))
8315     return 0;
8316   if (range_type->bounds ()->low.const_val () != lo)
8317     return 0;
8318
8319   n += 2; /* Skip the "__" separator between the two bounds.  */
8320   if (!ada_scan_number (bounds_str, n, &hi, &n))
8321     return 0;
8322   if (range_type->bounds ()->high.const_val () != hi)
8323     return 0;
8324
8325   return 1;
8326 }
8327
8328 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8329    a type following the GNAT encoding for describing array type
8330    indices, only carries redundant information.  */
8331
8332 static int
8333 ada_is_redundant_index_type_desc (struct type *array_type,
8334                                   struct type *desc_type)
8335 {
8336   struct type *this_layer = check_typedef (array_type);
8337   int i;
8338
8339   for (i = 0; i < desc_type->num_fields (); i++)
8340     {
8341       if (!ada_is_redundant_range_encoding (this_layer->index_type (),
8342                                             desc_type->field (i).type ()))
8343         return 0;
8344       this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8345     }
8346
8347   return 1;
8348 }
8349
8350 /* Assuming that TYPE0 is an array type describing the type of a value
8351    at ADDR, and that DVAL describes a record containing any
8352    discriminants used in TYPE0, returns a type for the value that
8353    contains no dynamic components (that is, no components whose sizes
8354    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
8355    true, gives an error message if the resulting type's size is over
8356    varsize_limit.  */
8357
8358 static struct type *
8359 to_fixed_array_type (struct type *type0, struct value *dval,
8360                      int ignore_too_big)
8361 {
8362   struct type *index_type_desc;
8363   struct type *result;
8364   int constrained_packed_array_p;
8365   static const char *xa_suffix = "___XA";
8366
8367   type0 = ada_check_typedef (type0);
8368   if (type0->is_fixed_instance ())
8369     return type0;
8370
8371   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8372   if (constrained_packed_array_p)
8373     {
8374       type0 = decode_constrained_packed_array_type (type0);
8375       if (type0 == nullptr)
8376         error (_("could not decode constrained packed array type"));
8377     }
8378
8379   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8380
8381   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8382      encoding suffixed with 'P' may still be generated.  If so,
8383      it should be used to find the XA type.  */
8384
8385   if (index_type_desc == NULL)
8386     {
8387       const char *type_name = ada_type_name (type0);
8388
8389       if (type_name != NULL)
8390         {
8391           const int len = strlen (type_name);
8392           char *name = (char *) alloca (len + strlen (xa_suffix));
8393
8394           if (type_name[len - 1] == 'P')
8395             {
8396               strcpy (name, type_name);
8397               strcpy (name + len - 1, xa_suffix);
8398               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8399             }
8400         }
8401     }
8402
8403   ada_fixup_array_indexes_type (index_type_desc);
8404   if (index_type_desc != NULL
8405       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8406     {
8407       /* Ignore this ___XA parallel type, as it does not bring any
8408          useful information.  This allows us to avoid creating fixed
8409          versions of the array's index types, which would be identical
8410          to the original ones.  This, in turn, can also help avoid
8411          the creation of fixed versions of the array itself.  */
8412       index_type_desc = NULL;
8413     }
8414
8415   if (index_type_desc == NULL)
8416     {
8417       struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8418
8419       /* NOTE: elt_type---the fixed version of elt_type0---should never
8420          depend on the contents of the array in properly constructed
8421          debugging data.  */
8422       /* Create a fixed version of the array element type.
8423          We're not providing the address of an element here,
8424          and thus the actual object value cannot be inspected to do
8425          the conversion.  This should not be a problem, since arrays of
8426          unconstrained objects are not allowed.  In particular, all
8427          the elements of an array of a tagged type should all be of
8428          the same type specified in the debugging info.  No need to
8429          consult the object tag.  */
8430       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8431
8432       /* Make sure we always create a new array type when dealing with
8433          packed array types, since we're going to fix-up the array
8434          type length and element bitsize a little further down.  */
8435       if (elt_type0 == elt_type && !constrained_packed_array_p)
8436         result = type0;
8437       else
8438         result = create_array_type (alloc_type_copy (type0),
8439                                     elt_type, type0->index_type ());
8440     }
8441   else
8442     {
8443       int i;
8444       struct type *elt_type0;
8445
8446       elt_type0 = type0;
8447       for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8448         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8449
8450       /* NOTE: result---the fixed version of elt_type0---should never
8451          depend on the contents of the array in properly constructed
8452          debugging data.  */
8453       /* Create a fixed version of the array element type.
8454          We're not providing the address of an element here,
8455          and thus the actual object value cannot be inspected to do
8456          the conversion.  This should not be a problem, since arrays of
8457          unconstrained objects are not allowed.  In particular, all
8458          the elements of an array of a tagged type should all be of
8459          the same type specified in the debugging info.  No need to
8460          consult the object tag.  */
8461       result =
8462         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8463
8464       elt_type0 = type0;
8465       for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8466         {
8467           struct type *range_type =
8468             to_fixed_range_type (index_type_desc->field (i).type (), dval);
8469
8470           result = create_array_type (alloc_type_copy (elt_type0),
8471                                       result, range_type);
8472           elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8473         }
8474     }
8475
8476   /* We want to preserve the type name.  This can be useful when
8477      trying to get the type name of a value that has already been
8478      printed (for instance, if the user did "print VAR; whatis $".  */
8479   result->set_name (type0->name ());
8480
8481   if (constrained_packed_array_p)
8482     {
8483       /* So far, the resulting type has been created as if the original
8484          type was a regular (non-packed) array type.  As a result, the
8485          bitsize of the array elements needs to be set again, and the array
8486          length needs to be recomputed based on that bitsize.  */
8487       int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8488       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8489
8490       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8491       TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8492       if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8493         TYPE_LENGTH (result)++;
8494     }
8495
8496   result->set_is_fixed_instance (true);
8497   return result;
8498 }
8499
8500
8501 /* A standard type (containing no dynamically sized components)
8502    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8503    DVAL describes a record containing any discriminants used in TYPE0,
8504    and may be NULL if there are none, or if the object of type TYPE at
8505    ADDRESS or in VALADDR contains these discriminants.
8506    
8507    If CHECK_TAG is not null, in the case of tagged types, this function
8508    attempts to locate the object's tag and use it to compute the actual
8509    type.  However, when ADDRESS is null, we cannot use it to determine the
8510    location of the tag, and therefore compute the tagged type's actual type.
8511    So we return the tagged type without consulting the tag.  */
8512    
8513 static struct type *
8514 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8515                    CORE_ADDR address, struct value *dval, int check_tag)
8516 {
8517   type = ada_check_typedef (type);
8518
8519   /* Only un-fixed types need to be handled here.  */
8520   if (!HAVE_GNAT_AUX_INFO (type))
8521     return type;
8522
8523   switch (type->code ())
8524     {
8525     default:
8526       return type;
8527     case TYPE_CODE_STRUCT:
8528       {
8529         struct type *static_type = to_static_fixed_type (type);
8530         struct type *fixed_record_type =
8531           to_fixed_record_type (type, valaddr, address, NULL);
8532
8533         /* If STATIC_TYPE is a tagged type and we know the object's address,
8534            then we can determine its tag, and compute the object's actual
8535            type from there.  Note that we have to use the fixed record
8536            type (the parent part of the record may have dynamic fields
8537            and the way the location of _tag is expressed may depend on
8538            them).  */
8539
8540         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8541           {
8542             struct value *tag =
8543               value_tag_from_contents_and_address
8544               (fixed_record_type,
8545                valaddr,
8546                address);
8547             struct type *real_type = type_from_tag (tag);
8548             struct value *obj =
8549               value_from_contents_and_address (fixed_record_type,
8550                                                valaddr,
8551                                                address);
8552             fixed_record_type = value_type (obj);
8553             if (real_type != NULL)
8554               return to_fixed_record_type
8555                 (real_type, NULL,
8556                  value_address (ada_tag_value_at_base_address (obj)), NULL);
8557           }
8558
8559         /* Check to see if there is a parallel ___XVZ variable.
8560            If there is, then it provides the actual size of our type.  */
8561         else if (ada_type_name (fixed_record_type) != NULL)
8562           {
8563             const char *name = ada_type_name (fixed_record_type);
8564             char *xvz_name
8565               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8566             bool xvz_found = false;
8567             LONGEST size;
8568
8569             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8570             try
8571               {
8572                 xvz_found = get_int_var_value (xvz_name, size);
8573               }
8574             catch (const gdb_exception_error &except)
8575               {
8576                 /* We found the variable, but somehow failed to read
8577                    its value.  Rethrow the same error, but with a little
8578                    bit more information, to help the user understand
8579                    what went wrong (Eg: the variable might have been
8580                    optimized out).  */
8581                 throw_error (except.error,
8582                              _("unable to read value of %s (%s)"),
8583                              xvz_name, except.what ());
8584               }
8585
8586             if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8587               {
8588                 fixed_record_type = copy_type (fixed_record_type);
8589                 TYPE_LENGTH (fixed_record_type) = size;
8590
8591                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
8592                    observed this when the debugging info is STABS, and
8593                    apparently it is something that is hard to fix.
8594
8595                    In practice, we don't need the actual type definition
8596                    at all, because the presence of the XVZ variable allows us
8597                    to assume that there must be a XVS type as well, which we
8598                    should be able to use later, when we need the actual type
8599                    definition.
8600
8601                    In the meantime, pretend that the "fixed" type we are
8602                    returning is NOT a stub, because this can cause trouble
8603                    when using this type to create new types targeting it.
8604                    Indeed, the associated creation routines often check
8605                    whether the target type is a stub and will try to replace
8606                    it, thus using a type with the wrong size.  This, in turn,
8607                    might cause the new type to have the wrong size too.
8608                    Consider the case of an array, for instance, where the size
8609                    of the array is computed from the number of elements in
8610                    our array multiplied by the size of its element.  */
8611                 fixed_record_type->set_is_stub (false);
8612               }
8613           }
8614         return fixed_record_type;
8615       }
8616     case TYPE_CODE_ARRAY:
8617       return to_fixed_array_type (type, dval, 1);
8618     case TYPE_CODE_UNION:
8619       if (dval == NULL)
8620         return type;
8621       else
8622         return to_fixed_variant_branch_type (type, valaddr, address, dval);
8623     }
8624 }
8625
8626 /* The same as ada_to_fixed_type_1, except that it preserves the type
8627    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8628
8629    The typedef layer needs be preserved in order to differentiate between
8630    arrays and array pointers when both types are implemented using the same
8631    fat pointer.  In the array pointer case, the pointer is encoded as
8632    a typedef of the pointer type.  For instance, considering:
8633
8634           type String_Access is access String;
8635           S1 : String_Access := null;
8636
8637    To the debugger, S1 is defined as a typedef of type String.  But
8638    to the user, it is a pointer.  So if the user tries to print S1,
8639    we should not dereference the array, but print the array address
8640    instead.
8641
8642    If we didn't preserve the typedef layer, we would lose the fact that
8643    the type is to be presented as a pointer (needs de-reference before
8644    being printed).  And we would also use the source-level type name.  */
8645
8646 struct type *
8647 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8648                    CORE_ADDR address, struct value *dval, int check_tag)
8649
8650 {
8651   struct type *fixed_type =
8652     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8653
8654   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8655       then preserve the typedef layer.
8656
8657       Implementation note: We can only check the main-type portion of
8658       the TYPE and FIXED_TYPE, because eliminating the typedef layer
8659       from TYPE now returns a type that has the same instance flags
8660       as TYPE.  For instance, if TYPE is a "typedef const", and its
8661       target type is a "struct", then the typedef elimination will return
8662       a "const" version of the target type.  See check_typedef for more
8663       details about how the typedef layer elimination is done.
8664
8665       brobecker/2010-11-19: It seems to me that the only case where it is
8666       useful to preserve the typedef layer is when dealing with fat pointers.
8667       Perhaps, we could add a check for that and preserve the typedef layer
8668       only in that situation.  But this seems unnecessary so far, probably
8669       because we call check_typedef/ada_check_typedef pretty much everywhere.
8670       */
8671   if (type->code () == TYPE_CODE_TYPEDEF
8672       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8673           == TYPE_MAIN_TYPE (fixed_type)))
8674     return type;
8675
8676   return fixed_type;
8677 }
8678
8679 /* A standard (static-sized) type corresponding as well as possible to
8680    TYPE0, but based on no runtime data.  */
8681
8682 static struct type *
8683 to_static_fixed_type (struct type *type0)
8684 {
8685   struct type *type;
8686
8687   if (type0 == NULL)
8688     return NULL;
8689
8690   if (type0->is_fixed_instance ())
8691     return type0;
8692
8693   type0 = ada_check_typedef (type0);
8694
8695   switch (type0->code ())
8696     {
8697     default:
8698       return type0;
8699     case TYPE_CODE_STRUCT:
8700       type = dynamic_template_type (type0);
8701       if (type != NULL)
8702         return template_to_static_fixed_type (type);
8703       else
8704         return template_to_static_fixed_type (type0);
8705     case TYPE_CODE_UNION:
8706       type = ada_find_parallel_type (type0, "___XVU");
8707       if (type != NULL)
8708         return template_to_static_fixed_type (type);
8709       else
8710         return template_to_static_fixed_type (type0);
8711     }
8712 }
8713
8714 /* A static approximation of TYPE with all type wrappers removed.  */
8715
8716 static struct type *
8717 static_unwrap_type (struct type *type)
8718 {
8719   if (ada_is_aligner_type (type))
8720     {
8721       struct type *type1 = ada_check_typedef (type)->field (0).type ();
8722       if (ada_type_name (type1) == NULL)
8723         type1->set_name (ada_type_name (type));
8724
8725       return static_unwrap_type (type1);
8726     }
8727   else
8728     {
8729       struct type *raw_real_type = ada_get_base_type (type);
8730
8731       if (raw_real_type == type)
8732         return type;
8733       else
8734         return to_static_fixed_type (raw_real_type);
8735     }
8736 }
8737
8738 /* In some cases, incomplete and private types require
8739    cross-references that are not resolved as records (for example,
8740       type Foo;
8741       type FooP is access Foo;
8742       V: FooP;
8743       type Foo is array ...;
8744    ).  In these cases, since there is no mechanism for producing
8745    cross-references to such types, we instead substitute for FooP a
8746    stub enumeration type that is nowhere resolved, and whose tag is
8747    the name of the actual type.  Call these types "non-record stubs".  */
8748
8749 /* A type equivalent to TYPE that is not a non-record stub, if one
8750    exists, otherwise TYPE.  */
8751
8752 struct type *
8753 ada_check_typedef (struct type *type)
8754 {
8755   if (type == NULL)
8756     return NULL;
8757
8758   /* If our type is an access to an unconstrained array, which is encoded
8759      as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8760      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8761      what allows us to distinguish between fat pointers that represent
8762      array types, and fat pointers that represent array access types
8763      (in both cases, the compiler implements them as fat pointers).  */
8764   if (ada_is_access_to_unconstrained_array (type))
8765     return type;
8766
8767   type = check_typedef (type);
8768   if (type == NULL || type->code () != TYPE_CODE_ENUM
8769       || !type->is_stub ()
8770       || type->name () == NULL)
8771     return type;
8772   else
8773     {
8774       const char *name = type->name ();
8775       struct type *type1 = ada_find_any_type (name);
8776
8777       if (type1 == NULL)
8778         return type;
8779
8780       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8781          stubs pointing to arrays, as we don't create symbols for array
8782          types, only for the typedef-to-array types).  If that's the case,
8783          strip the typedef layer.  */
8784       if (type1->code () == TYPE_CODE_TYPEDEF)
8785         type1 = ada_check_typedef (type1);
8786
8787       return type1;
8788     }
8789 }
8790
8791 /* A value representing the data at VALADDR/ADDRESS as described by
8792    type TYPE0, but with a standard (static-sized) type that correctly
8793    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
8794    type, then return VAL0 [this feature is simply to avoid redundant
8795    creation of struct values].  */
8796
8797 static struct value *
8798 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8799                            struct value *val0)
8800 {
8801   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8802
8803   if (type == type0 && val0 != NULL)
8804     return val0;
8805
8806   if (VALUE_LVAL (val0) != lval_memory)
8807     {
8808       /* Our value does not live in memory; it could be a convenience
8809          variable, for instance.  Create a not_lval value using val0's
8810          contents.  */
8811       return value_from_contents (type, value_contents (val0).data ());
8812     }
8813
8814   return value_from_contents_and_address (type, 0, address);
8815 }
8816
8817 /* A value representing VAL, but with a standard (static-sized) type
8818    that correctly describes it.  Does not necessarily create a new
8819    value.  */
8820
8821 struct value *
8822 ada_to_fixed_value (struct value *val)
8823 {
8824   val = unwrap_value (val);
8825   val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8826   return val;
8827 }
8828 \f
8829
8830 /* Attributes */
8831
8832 /* Table mapping attribute numbers to names.
8833    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
8834
8835 static const char * const attribute_names[] = {
8836   "<?>",
8837
8838   "first",
8839   "last",
8840   "length",
8841   "image",
8842   "max",
8843   "min",
8844   "modulus",
8845   "pos",
8846   "size",
8847   "tag",
8848   "val",
8849   0
8850 };
8851
8852 static const char *
8853 ada_attribute_name (enum exp_opcode n)
8854 {
8855   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8856     return attribute_names[n - OP_ATR_FIRST + 1];
8857   else
8858     return attribute_names[0];
8859 }
8860
8861 /* Evaluate the 'POS attribute applied to ARG.  */
8862
8863 static LONGEST
8864 pos_atr (struct value *arg)
8865 {
8866   struct value *val = coerce_ref (arg);
8867   struct type *type = value_type (val);
8868
8869   if (!discrete_type_p (type))
8870     error (_("'POS only defined on discrete types"));
8871
8872   gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8873   if (!result.has_value ())
8874     error (_("enumeration value is invalid: can't find 'POS"));
8875
8876   return *result;
8877 }
8878
8879 struct value *
8880 ada_pos_atr (struct type *expect_type,
8881              struct expression *exp,
8882              enum noside noside, enum exp_opcode op,
8883              struct value *arg)
8884 {
8885   struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8886   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8887     return value_zero (type, not_lval);
8888   return value_from_longest (type, pos_atr (arg));
8889 }
8890
8891 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
8892
8893 static struct value *
8894 val_atr (struct type *type, LONGEST val)
8895 {
8896   gdb_assert (discrete_type_p (type));
8897   if (type->code () == TYPE_CODE_RANGE)
8898     type = TYPE_TARGET_TYPE (type);
8899   if (type->code () == TYPE_CODE_ENUM)
8900     {
8901       if (val < 0 || val >= type->num_fields ())
8902         error (_("argument to 'VAL out of range"));
8903       val = type->field (val).loc_enumval ();
8904     }
8905   return value_from_longest (type, val);
8906 }
8907
8908 struct value *
8909 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8910 {
8911   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8912     return value_zero (type, not_lval);
8913
8914   if (!discrete_type_p (type))
8915     error (_("'VAL only defined on discrete types"));
8916   if (!integer_type_p (value_type (arg)))
8917     error (_("'VAL requires integral argument"));
8918
8919   return val_atr (type, value_as_long (arg));
8920 }
8921 \f
8922
8923                                 /* Evaluation */
8924
8925 /* True if TYPE appears to be an Ada character type.
8926    [At the moment, this is true only for Character and Wide_Character;
8927    It is a heuristic test that could stand improvement].  */
8928
8929 bool
8930 ada_is_character_type (struct type *type)
8931 {
8932   const char *name;
8933
8934   /* If the type code says it's a character, then assume it really is,
8935      and don't check any further.  */
8936   if (type->code () == TYPE_CODE_CHAR)
8937     return true;
8938   
8939   /* Otherwise, assume it's a character type iff it is a discrete type
8940      with a known character type name.  */
8941   name = ada_type_name (type);
8942   return (name != NULL
8943           && (type->code () == TYPE_CODE_INT
8944               || type->code () == TYPE_CODE_RANGE)
8945           && (strcmp (name, "character") == 0
8946               || strcmp (name, "wide_character") == 0
8947               || strcmp (name, "wide_wide_character") == 0
8948               || strcmp (name, "unsigned char") == 0));
8949 }
8950
8951 /* True if TYPE appears to be an Ada string type.  */
8952
8953 bool
8954 ada_is_string_type (struct type *type)
8955 {
8956   type = ada_check_typedef (type);
8957   if (type != NULL
8958       && type->code () != TYPE_CODE_PTR
8959       && (ada_is_simple_array_type (type)
8960           || ada_is_array_descriptor_type (type))
8961       && ada_array_arity (type) == 1)
8962     {
8963       struct type *elttype = ada_array_element_type (type, 1);
8964
8965       return ada_is_character_type (elttype);
8966     }
8967   else
8968     return false;
8969 }
8970
8971 /* The compiler sometimes provides a parallel XVS type for a given
8972    PAD type.  Normally, it is safe to follow the PAD type directly,
8973    but older versions of the compiler have a bug that causes the offset
8974    of its "F" field to be wrong.  Following that field in that case
8975    would lead to incorrect results, but this can be worked around
8976    by ignoring the PAD type and using the associated XVS type instead.
8977
8978    Set to True if the debugger should trust the contents of PAD types.
8979    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
8980 static bool trust_pad_over_xvs = true;
8981
8982 /* True if TYPE is a struct type introduced by the compiler to force the
8983    alignment of a value.  Such types have a single field with a
8984    distinctive name.  */
8985
8986 int
8987 ada_is_aligner_type (struct type *type)
8988 {
8989   type = ada_check_typedef (type);
8990
8991   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
8992     return 0;
8993
8994   return (type->code () == TYPE_CODE_STRUCT
8995           && type->num_fields () == 1
8996           && strcmp (type->field (0).name (), "F") == 0);
8997 }
8998
8999 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9000    the parallel type.  */
9001
9002 struct type *
9003 ada_get_base_type (struct type *raw_type)
9004 {
9005   struct type *real_type_namer;
9006   struct type *raw_real_type;
9007
9008   if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
9009     return raw_type;
9010
9011   if (ada_is_aligner_type (raw_type))
9012     /* The encoding specifies that we should always use the aligner type.
9013        So, even if this aligner type has an associated XVS type, we should
9014        simply ignore it.
9015
9016        According to the compiler gurus, an XVS type parallel to an aligner
9017        type may exist because of a stabs limitation.  In stabs, aligner
9018        types are empty because the field has a variable-sized type, and
9019        thus cannot actually be used as an aligner type.  As a result,
9020        we need the associated parallel XVS type to decode the type.
9021        Since the policy in the compiler is to not change the internal
9022        representation based on the debugging info format, we sometimes
9023        end up having a redundant XVS type parallel to the aligner type.  */
9024     return raw_type;
9025
9026   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9027   if (real_type_namer == NULL
9028       || real_type_namer->code () != TYPE_CODE_STRUCT
9029       || real_type_namer->num_fields () != 1)
9030     return raw_type;
9031
9032   if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
9033     {
9034       /* This is an older encoding form where the base type needs to be
9035          looked up by name.  We prefer the newer encoding because it is
9036          more efficient.  */
9037       raw_real_type = ada_find_any_type (real_type_namer->field (0).name ());
9038       if (raw_real_type == NULL)
9039         return raw_type;
9040       else
9041         return raw_real_type;
9042     }
9043
9044   /* The field in our XVS type is a reference to the base type.  */
9045   return TYPE_TARGET_TYPE (real_type_namer->field (0).type ());
9046 }
9047
9048 /* The type of value designated by TYPE, with all aligners removed.  */
9049
9050 struct type *
9051 ada_aligned_type (struct type *type)
9052 {
9053   if (ada_is_aligner_type (type))
9054     return ada_aligned_type (type->field (0).type ());
9055   else
9056     return ada_get_base_type (type);
9057 }
9058
9059
9060 /* The address of the aligned value in an object at address VALADDR
9061    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
9062
9063 const gdb_byte *
9064 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9065 {
9066   if (ada_is_aligner_type (type))
9067     return ada_aligned_value_addr
9068       (type->field (0).type (),
9069        valaddr + type->field (0).loc_bitpos () / TARGET_CHAR_BIT);
9070   else
9071     return valaddr;
9072 }
9073
9074
9075
9076 /* The printed representation of an enumeration literal with encoded
9077    name NAME.  The value is good to the next call of ada_enum_name.  */
9078 const char *
9079 ada_enum_name (const char *name)
9080 {
9081   static std::string storage;
9082   const char *tmp;
9083
9084   /* First, unqualify the enumeration name:
9085      1. Search for the last '.' character.  If we find one, then skip
9086      all the preceding characters, the unqualified name starts
9087      right after that dot.
9088      2. Otherwise, we may be debugging on a target where the compiler
9089      translates dots into "__".  Search forward for double underscores,
9090      but stop searching when we hit an overloading suffix, which is
9091      of the form "__" followed by digits.  */
9092
9093   tmp = strrchr (name, '.');
9094   if (tmp != NULL)
9095     name = tmp + 1;
9096   else
9097     {
9098       while ((tmp = strstr (name, "__")) != NULL)
9099         {
9100           if (isdigit (tmp[2]))
9101             break;
9102           else
9103             name = tmp + 2;
9104         }
9105     }
9106
9107   if (name[0] == 'Q')
9108     {
9109       int v;
9110
9111       if (name[1] == 'U' || name[1] == 'W')
9112         {
9113           int offset = 2;
9114           if (name[1] == 'W' && name[2] == 'W')
9115             {
9116               /* Also handle the QWW case.  */
9117               ++offset;
9118             }
9119           if (sscanf (name + offset, "%x", &v) != 1)
9120             return name;
9121         }
9122       else if (((name[1] >= '0' && name[1] <= '9')
9123                 || (name[1] >= 'a' && name[1] <= 'z'))
9124                && name[2] == '\0')
9125         {
9126           storage = string_printf ("'%c'", name[1]);
9127           return storage.c_str ();
9128         }
9129       else
9130         return name;
9131
9132       if (isascii (v) && isprint (v))
9133         storage = string_printf ("'%c'", v);
9134       else if (name[1] == 'U')
9135         storage = string_printf ("'[\"%02x\"]'", v);
9136       else if (name[2] != 'W')
9137         storage = string_printf ("'[\"%04x\"]'", v);
9138       else
9139         storage = string_printf ("'[\"%06x\"]'", v);
9140
9141       return storage.c_str ();
9142     }
9143   else
9144     {
9145       tmp = strstr (name, "__");
9146       if (tmp == NULL)
9147         tmp = strstr (name, "$");
9148       if (tmp != NULL)
9149         {
9150           storage = std::string (name, tmp - name);
9151           return storage.c_str ();
9152         }
9153
9154       return name;
9155     }
9156 }
9157
9158 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9159    value it wraps.  */
9160
9161 static struct value *
9162 unwrap_value (struct value *val)
9163 {
9164   struct type *type = ada_check_typedef (value_type (val));
9165
9166   if (ada_is_aligner_type (type))
9167     {
9168       struct value *v = ada_value_struct_elt (val, "F", 0);
9169       struct type *val_type = ada_check_typedef (value_type (v));
9170
9171       if (ada_type_name (val_type) == NULL)
9172         val_type->set_name (ada_type_name (type));
9173
9174       return unwrap_value (v);
9175     }
9176   else
9177     {
9178       struct type *raw_real_type =
9179         ada_check_typedef (ada_get_base_type (type));
9180
9181       /* If there is no parallel XVS or XVE type, then the value is
9182          already unwrapped.  Return it without further modification.  */
9183       if ((type == raw_real_type)
9184           && ada_find_parallel_type (type, "___XVE") == NULL)
9185         return val;
9186
9187       return
9188         coerce_unspec_val_to_type
9189         (val, ada_to_fixed_type (raw_real_type, 0,
9190                                  value_address (val),
9191                                  NULL, 1));
9192     }
9193 }
9194
9195 /* Given two array types T1 and T2, return nonzero iff both arrays
9196    contain the same number of elements.  */
9197
9198 static int
9199 ada_same_array_size_p (struct type *t1, struct type *t2)
9200 {
9201   LONGEST lo1, hi1, lo2, hi2;
9202
9203   /* Get the array bounds in order to verify that the size of
9204      the two arrays match.  */
9205   if (!get_array_bounds (t1, &lo1, &hi1)
9206       || !get_array_bounds (t2, &lo2, &hi2))
9207     error (_("unable to determine array bounds"));
9208
9209   /* To make things easier for size comparison, normalize a bit
9210      the case of empty arrays by making sure that the difference
9211      between upper bound and lower bound is always -1.  */
9212   if (lo1 > hi1)
9213     hi1 = lo1 - 1;
9214   if (lo2 > hi2)
9215     hi2 = lo2 - 1;
9216
9217   return (hi1 - lo1 == hi2 - lo2);
9218 }
9219
9220 /* Assuming that VAL is an array of integrals, and TYPE represents
9221    an array with the same number of elements, but with wider integral
9222    elements, return an array "casted" to TYPE.  In practice, this
9223    means that the returned array is built by casting each element
9224    of the original array into TYPE's (wider) element type.  */
9225
9226 static struct value *
9227 ada_promote_array_of_integrals (struct type *type, struct value *val)
9228 {
9229   struct type *elt_type = TYPE_TARGET_TYPE (type);
9230   LONGEST lo, hi;
9231   LONGEST i;
9232
9233   /* Verify that both val and type are arrays of scalars, and
9234      that the size of val's elements is smaller than the size
9235      of type's element.  */
9236   gdb_assert (type->code () == TYPE_CODE_ARRAY);
9237   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9238   gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
9239   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9240   gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9241               > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9242
9243   if (!get_array_bounds (type, &lo, &hi))
9244     error (_("unable to determine array bounds"));
9245
9246   value *res = allocate_value (type);
9247   gdb::array_view<gdb_byte> res_contents = value_contents_writeable (res);
9248
9249   /* Promote each array element.  */
9250   for (i = 0; i < hi - lo + 1; i++)
9251     {
9252       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9253       int elt_len = TYPE_LENGTH (elt_type);
9254
9255       copy (value_contents_all (elt), res_contents.slice (elt_len * i, elt_len));
9256     }
9257
9258   return res;
9259 }
9260
9261 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9262    return the converted value.  */
9263
9264 static struct value *
9265 coerce_for_assign (struct type *type, struct value *val)
9266 {
9267   struct type *type2 = value_type (val);
9268
9269   if (type == type2)
9270     return val;
9271
9272   type2 = ada_check_typedef (type2);
9273   type = ada_check_typedef (type);
9274
9275   if (type2->code () == TYPE_CODE_PTR
9276       && type->code () == TYPE_CODE_ARRAY)
9277     {
9278       val = ada_value_ind (val);
9279       type2 = value_type (val);
9280     }
9281
9282   if (type2->code () == TYPE_CODE_ARRAY
9283       && type->code () == TYPE_CODE_ARRAY)
9284     {
9285       if (!ada_same_array_size_p (type, type2))
9286         error (_("cannot assign arrays of different length"));
9287
9288       if (is_integral_type (TYPE_TARGET_TYPE (type))
9289           && is_integral_type (TYPE_TARGET_TYPE (type2))
9290           && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9291                < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9292         {
9293           /* Allow implicit promotion of the array elements to
9294              a wider type.  */
9295           return ada_promote_array_of_integrals (type, val);
9296         }
9297
9298       if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9299           != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9300         error (_("Incompatible types in assignment"));
9301       deprecated_set_value_type (val, type);
9302     }
9303   return val;
9304 }
9305
9306 static struct value *
9307 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9308 {
9309   struct value *val;
9310   struct type *type1, *type2;
9311   LONGEST v, v1, v2;
9312
9313   arg1 = coerce_ref (arg1);
9314   arg2 = coerce_ref (arg2);
9315   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9316   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9317
9318   if (type1->code () != TYPE_CODE_INT
9319       || type2->code () != TYPE_CODE_INT)
9320     return value_binop (arg1, arg2, op);
9321
9322   switch (op)
9323     {
9324     case BINOP_MOD:
9325     case BINOP_DIV:
9326     case BINOP_REM:
9327       break;
9328     default:
9329       return value_binop (arg1, arg2, op);
9330     }
9331
9332   v2 = value_as_long (arg2);
9333   if (v2 == 0)
9334     {
9335       const char *name;
9336       if (op == BINOP_MOD)
9337         name = "mod";
9338       else if (op == BINOP_DIV)
9339         name = "/";
9340       else
9341         {
9342           gdb_assert (op == BINOP_REM);
9343           name = "rem";
9344         }
9345
9346       error (_("second operand of %s must not be zero."), name);
9347     }
9348
9349   if (type1->is_unsigned () || op == BINOP_MOD)
9350     return value_binop (arg1, arg2, op);
9351
9352   v1 = value_as_long (arg1);
9353   switch (op)
9354     {
9355     case BINOP_DIV:
9356       v = v1 / v2;
9357       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9358         v += v > 0 ? -1 : 1;
9359       break;
9360     case BINOP_REM:
9361       v = v1 % v2;
9362       if (v * v1 < 0)
9363         v -= v2;
9364       break;
9365     default:
9366       /* Should not reach this point.  */
9367       v = 0;
9368     }
9369
9370   val = allocate_value (type1);
9371   store_unsigned_integer (value_contents_raw (val).data (),
9372                           TYPE_LENGTH (value_type (val)),
9373                           type_byte_order (type1), v);
9374   return val;
9375 }
9376
9377 static int
9378 ada_value_equal (struct value *arg1, struct value *arg2)
9379 {
9380   if (ada_is_direct_array_type (value_type (arg1))
9381       || ada_is_direct_array_type (value_type (arg2)))
9382     {
9383       struct type *arg1_type, *arg2_type;
9384
9385       /* Automatically dereference any array reference before
9386          we attempt to perform the comparison.  */
9387       arg1 = ada_coerce_ref (arg1);
9388       arg2 = ada_coerce_ref (arg2);
9389
9390       arg1 = ada_coerce_to_simple_array (arg1);
9391       arg2 = ada_coerce_to_simple_array (arg2);
9392
9393       arg1_type = ada_check_typedef (value_type (arg1));
9394       arg2_type = ada_check_typedef (value_type (arg2));
9395
9396       if (arg1_type->code () != TYPE_CODE_ARRAY
9397           || arg2_type->code () != TYPE_CODE_ARRAY)
9398         error (_("Attempt to compare array with non-array"));
9399       /* FIXME: The following works only for types whose
9400          representations use all bits (no padding or undefined bits)
9401          and do not have user-defined equality.  */
9402       return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9403               && memcmp (value_contents (arg1).data (),
9404                          value_contents (arg2).data (),
9405                          TYPE_LENGTH (arg1_type)) == 0);
9406     }
9407   return value_equal (arg1, arg2);
9408 }
9409
9410 namespace expr
9411 {
9412
9413 bool
9414 check_objfile (const std::unique_ptr<ada_component> &comp,
9415                struct objfile *objfile)
9416 {
9417   return comp->uses_objfile (objfile);
9418 }
9419
9420 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9421    component of LHS (a simple array or a record).  Does not modify the
9422    inferior's memory, nor does it modify LHS (unless LHS ==
9423    CONTAINER).  */
9424
9425 static void
9426 assign_component (struct value *container, struct value *lhs, LONGEST index,
9427                   struct expression *exp, operation_up &arg)
9428 {
9429   scoped_value_mark mark;
9430
9431   struct value *elt;
9432   struct type *lhs_type = check_typedef (value_type (lhs));
9433
9434   if (lhs_type->code () == TYPE_CODE_ARRAY)
9435     {
9436       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9437       struct value *index_val = value_from_longest (index_type, index);
9438
9439       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9440     }
9441   else
9442     {
9443       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9444       elt = ada_to_fixed_value (elt);
9445     }
9446
9447   ada_aggregate_operation *ag_op
9448     = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9449   if (ag_op != nullptr)
9450     ag_op->assign_aggregate (container, elt, exp);
9451   else
9452     value_assign_to_component (container, elt,
9453                                arg->evaluate (nullptr, exp,
9454                                               EVAL_NORMAL));
9455 }
9456
9457 bool
9458 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9459 {
9460   for (const auto &item : m_components)
9461     if (item->uses_objfile (objfile))
9462       return true;
9463   return false;
9464 }
9465
9466 void
9467 ada_aggregate_component::dump (ui_file *stream, int depth)
9468 {
9469   fprintf_filtered (stream, _("%*sAggregate\n"), depth, "");
9470   for (const auto &item : m_components)
9471     item->dump (stream, depth + 1);
9472 }
9473
9474 void
9475 ada_aggregate_component::assign (struct value *container,
9476                                  struct value *lhs, struct expression *exp,
9477                                  std::vector<LONGEST> &indices,
9478                                  LONGEST low, LONGEST high)
9479 {
9480   for (auto &item : m_components)
9481     item->assign (container, lhs, exp, indices, low, high);
9482 }
9483
9484 /* See ada-exp.h.  */
9485
9486 value *
9487 ada_aggregate_operation::assign_aggregate (struct value *container,
9488                                            struct value *lhs,
9489                                            struct expression *exp)
9490 {
9491   struct type *lhs_type;
9492   LONGEST low_index, high_index;
9493
9494   container = ada_coerce_ref (container);
9495   if (ada_is_direct_array_type (value_type (container)))
9496     container = ada_coerce_to_simple_array (container);
9497   lhs = ada_coerce_ref (lhs);
9498   if (!deprecated_value_modifiable (lhs))
9499     error (_("Left operand of assignment is not a modifiable lvalue."));
9500
9501   lhs_type = check_typedef (value_type (lhs));
9502   if (ada_is_direct_array_type (lhs_type))
9503     {
9504       lhs = ada_coerce_to_simple_array (lhs);
9505       lhs_type = check_typedef (value_type (lhs));
9506       low_index = lhs_type->bounds ()->low.const_val ();
9507       high_index = lhs_type->bounds ()->high.const_val ();
9508     }
9509   else if (lhs_type->code () == TYPE_CODE_STRUCT)
9510     {
9511       low_index = 0;
9512       high_index = num_visible_fields (lhs_type) - 1;
9513     }
9514   else
9515     error (_("Left-hand side must be array or record."));
9516
9517   std::vector<LONGEST> indices (4);
9518   indices[0] = indices[1] = low_index - 1;
9519   indices[2] = indices[3] = high_index + 1;
9520
9521   std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9522                                    low_index, high_index);
9523
9524   return container;
9525 }
9526
9527 bool
9528 ada_positional_component::uses_objfile (struct objfile *objfile)
9529 {
9530   return m_op->uses_objfile (objfile);
9531 }
9532
9533 void
9534 ada_positional_component::dump (ui_file *stream, int depth)
9535 {
9536   fprintf_filtered (stream, _("%*sPositional, index = %d\n"),
9537                     depth, "", m_index);
9538   m_op->dump (stream, depth + 1);
9539 }
9540
9541 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9542    construct, given that the positions are relative to lower bound
9543    LOW, where HIGH is the upper bound.  Record the position in
9544    INDICES.  CONTAINER is as for assign_aggregate.  */
9545 void
9546 ada_positional_component::assign (struct value *container,
9547                                   struct value *lhs, struct expression *exp,
9548                                   std::vector<LONGEST> &indices,
9549                                   LONGEST low, LONGEST high)
9550 {
9551   LONGEST ind = m_index + low;
9552
9553   if (ind - 1 == high)
9554     warning (_("Extra components in aggregate ignored."));
9555   if (ind <= high)
9556     {
9557       add_component_interval (ind, ind, indices);
9558       assign_component (container, lhs, ind, exp, m_op);
9559     }
9560 }
9561
9562 bool
9563 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9564 {
9565   return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9566 }
9567
9568 void
9569 ada_discrete_range_association::dump (ui_file *stream, int depth)
9570 {
9571   fprintf_filtered (stream, _("%*sDiscrete range:\n"), depth, "");
9572   m_low->dump (stream, depth + 1);
9573   m_high->dump (stream, depth + 1);
9574 }
9575
9576 void
9577 ada_discrete_range_association::assign (struct value *container,
9578                                         struct value *lhs,
9579                                         struct expression *exp,
9580                                         std::vector<LONGEST> &indices,
9581                                         LONGEST low, LONGEST high,
9582                                         operation_up &op)
9583 {
9584   LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9585   LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9586
9587   if (lower <= upper && (lower < low || upper > high))
9588     error (_("Index in component association out of bounds."));
9589
9590   add_component_interval (lower, upper, indices);
9591   while (lower <= upper)
9592     {
9593       assign_component (container, lhs, lower, exp, op);
9594       lower += 1;
9595     }
9596 }
9597
9598 bool
9599 ada_name_association::uses_objfile (struct objfile *objfile)
9600 {
9601   return m_val->uses_objfile (objfile);
9602 }
9603
9604 void
9605 ada_name_association::dump (ui_file *stream, int depth)
9606 {
9607   fprintf_filtered (stream, _("%*sName:\n"), depth, "");
9608   m_val->dump (stream, depth + 1);
9609 }
9610
9611 void
9612 ada_name_association::assign (struct value *container,
9613                               struct value *lhs,
9614                               struct expression *exp,
9615                               std::vector<LONGEST> &indices,
9616                               LONGEST low, LONGEST high,
9617                               operation_up &op)
9618 {
9619   int index;
9620
9621   if (ada_is_direct_array_type (value_type (lhs)))
9622     index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9623                                                             EVAL_NORMAL)));
9624   else
9625     {
9626       ada_string_operation *strop
9627         = dynamic_cast<ada_string_operation *> (m_val.get ());
9628
9629       const char *name;
9630       if (strop != nullptr)
9631         name = strop->get_name ();
9632       else
9633         {
9634           ada_var_value_operation *vvo
9635             = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9636           if (vvo != nullptr)
9637             error (_("Invalid record component association."));
9638           name = vvo->get_symbol ()->natural_name ();
9639         }
9640
9641       index = 0;
9642       if (! find_struct_field (name, value_type (lhs), 0,
9643                                NULL, NULL, NULL, NULL, &index))
9644         error (_("Unknown component name: %s."), name);
9645     }
9646
9647   add_component_interval (index, index, indices);
9648   assign_component (container, lhs, index, exp, op);
9649 }
9650
9651 bool
9652 ada_choices_component::uses_objfile (struct objfile *objfile)
9653 {
9654   if (m_op->uses_objfile (objfile))
9655     return true;
9656   for (const auto &item : m_assocs)
9657     if (item->uses_objfile (objfile))
9658       return true;
9659   return false;
9660 }
9661
9662 void
9663 ada_choices_component::dump (ui_file *stream, int depth)
9664 {
9665   fprintf_filtered (stream, _("%*sChoices:\n"), depth, "");
9666   m_op->dump (stream, depth + 1);
9667   for (const auto &item : m_assocs)
9668     item->dump (stream, depth + 1);
9669 }
9670
9671 /* Assign into the components of LHS indexed by the OP_CHOICES
9672    construct at *POS, updating *POS past the construct, given that
9673    the allowable indices are LOW..HIGH.  Record the indices assigned
9674    to in INDICES.  CONTAINER is as for assign_aggregate.  */
9675 void
9676 ada_choices_component::assign (struct value *container,
9677                                struct value *lhs, struct expression *exp,
9678                                std::vector<LONGEST> &indices,
9679                                LONGEST low, LONGEST high)
9680 {
9681   for (auto &item : m_assocs)
9682     item->assign (container, lhs, exp, indices, low, high, m_op);
9683 }
9684
9685 bool
9686 ada_others_component::uses_objfile (struct objfile *objfile)
9687 {
9688   return m_op->uses_objfile (objfile);
9689 }
9690
9691 void
9692 ada_others_component::dump (ui_file *stream, int depth)
9693 {
9694   fprintf_filtered (stream, _("%*sOthers:\n"), depth, "");
9695   m_op->dump (stream, depth + 1);
9696 }
9697
9698 /* Assign the value of the expression in the OP_OTHERS construct in
9699    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9700    have not been previously assigned.  The index intervals already assigned
9701    are in INDICES.  CONTAINER is as for assign_aggregate.  */
9702 void
9703 ada_others_component::assign (struct value *container,
9704                               struct value *lhs, struct expression *exp,
9705                               std::vector<LONGEST> &indices,
9706                               LONGEST low, LONGEST high)
9707 {
9708   int num_indices = indices.size ();
9709   for (int i = 0; i < num_indices - 2; i += 2)
9710     {
9711       for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9712         assign_component (container, lhs, ind, exp, m_op);
9713     }
9714 }
9715
9716 struct value *
9717 ada_assign_operation::evaluate (struct type *expect_type,
9718                                 struct expression *exp,
9719                                 enum noside noside)
9720 {
9721   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9722
9723   ada_aggregate_operation *ag_op
9724     = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9725   if (ag_op != nullptr)
9726     {
9727       if (noside != EVAL_NORMAL)
9728         return arg1;
9729
9730       arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9731       return ada_value_assign (arg1, arg1);
9732     }
9733   /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9734      except if the lhs of our assignment is a convenience variable.
9735      In the case of assigning to a convenience variable, the lhs
9736      should be exactly the result of the evaluation of the rhs.  */
9737   struct type *type = value_type (arg1);
9738   if (VALUE_LVAL (arg1) == lval_internalvar)
9739     type = NULL;
9740   value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9741   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9742     return arg1;
9743   if (VALUE_LVAL (arg1) == lval_internalvar)
9744     {
9745       /* Nothing.  */
9746     }
9747   else
9748     arg2 = coerce_for_assign (value_type (arg1), arg2);
9749   return ada_value_assign (arg1, arg2);
9750 }
9751
9752 } /* namespace expr */
9753
9754 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9755    [ INDICES[0] .. INDICES[1] ],...  The resulting intervals do not
9756    overlap.  */
9757 static void
9758 add_component_interval (LONGEST low, LONGEST high, 
9759                         std::vector<LONGEST> &indices)
9760 {
9761   int i, j;
9762
9763   int size = indices.size ();
9764   for (i = 0; i < size; i += 2) {
9765     if (high >= indices[i] && low <= indices[i + 1])
9766       {
9767         int kh;
9768
9769         for (kh = i + 2; kh < size; kh += 2)
9770           if (high < indices[kh])
9771             break;
9772         if (low < indices[i])
9773           indices[i] = low;
9774         indices[i + 1] = indices[kh - 1];
9775         if (high > indices[i + 1])
9776           indices[i + 1] = high;
9777         memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9778         indices.resize (kh - i - 2);
9779         return;
9780       }
9781     else if (high < indices[i])
9782       break;
9783   }
9784         
9785   indices.resize (indices.size () + 2);
9786   for (j = indices.size () - 1; j >= i + 2; j -= 1)
9787     indices[j] = indices[j - 2];
9788   indices[i] = low;
9789   indices[i + 1] = high;
9790 }
9791
9792 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9793    is different.  */
9794
9795 static struct value *
9796 ada_value_cast (struct type *type, struct value *arg2)
9797 {
9798   if (type == ada_check_typedef (value_type (arg2)))
9799     return arg2;
9800
9801   return value_cast (type, arg2);
9802 }
9803
9804 /*  Evaluating Ada expressions, and printing their result.
9805     ------------------------------------------------------
9806
9807     1. Introduction:
9808     ----------------
9809
9810     We usually evaluate an Ada expression in order to print its value.
9811     We also evaluate an expression in order to print its type, which
9812     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9813     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
9814     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9815     the evaluation compared to the EVAL_NORMAL, but is otherwise very
9816     similar.
9817
9818     Evaluating expressions is a little more complicated for Ada entities
9819     than it is for entities in languages such as C.  The main reason for
9820     this is that Ada provides types whose definition might be dynamic.
9821     One example of such types is variant records.  Or another example
9822     would be an array whose bounds can only be known at run time.
9823
9824     The following description is a general guide as to what should be
9825     done (and what should NOT be done) in order to evaluate an expression
9826     involving such types, and when.  This does not cover how the semantic
9827     information is encoded by GNAT as this is covered separatly.  For the
9828     document used as the reference for the GNAT encoding, see exp_dbug.ads
9829     in the GNAT sources.
9830
9831     Ideally, we should embed each part of this description next to its
9832     associated code.  Unfortunately, the amount of code is so vast right
9833     now that it's hard to see whether the code handling a particular
9834     situation might be duplicated or not.  One day, when the code is
9835     cleaned up, this guide might become redundant with the comments
9836     inserted in the code, and we might want to remove it.
9837
9838     2. ``Fixing'' an Entity, the Simple Case:
9839     -----------------------------------------
9840
9841     When evaluating Ada expressions, the tricky issue is that they may
9842     reference entities whose type contents and size are not statically
9843     known.  Consider for instance a variant record:
9844
9845        type Rec (Empty : Boolean := True) is record
9846           case Empty is
9847              when True => null;
9848              when False => Value : Integer;
9849           end case;
9850        end record;
9851        Yes : Rec := (Empty => False, Value => 1);
9852        No  : Rec := (empty => True);
9853
9854     The size and contents of that record depends on the value of the
9855     descriminant (Rec.Empty).  At this point, neither the debugging
9856     information nor the associated type structure in GDB are able to
9857     express such dynamic types.  So what the debugger does is to create
9858     "fixed" versions of the type that applies to the specific object.
9859     We also informally refer to this operation as "fixing" an object,
9860     which means creating its associated fixed type.
9861
9862     Example: when printing the value of variable "Yes" above, its fixed
9863     type would look like this:
9864
9865        type Rec is record
9866           Empty : Boolean;
9867           Value : Integer;
9868        end record;
9869
9870     On the other hand, if we printed the value of "No", its fixed type
9871     would become:
9872
9873        type Rec is record
9874           Empty : Boolean;
9875        end record;
9876
9877     Things become a little more complicated when trying to fix an entity
9878     with a dynamic type that directly contains another dynamic type,
9879     such as an array of variant records, for instance.  There are
9880     two possible cases: Arrays, and records.
9881
9882     3. ``Fixing'' Arrays:
9883     ---------------------
9884
9885     The type structure in GDB describes an array in terms of its bounds,
9886     and the type of its elements.  By design, all elements in the array
9887     have the same type and we cannot represent an array of variant elements
9888     using the current type structure in GDB.  When fixing an array,
9889     we cannot fix the array element, as we would potentially need one
9890     fixed type per element of the array.  As a result, the best we can do
9891     when fixing an array is to produce an array whose bounds and size
9892     are correct (allowing us to read it from memory), but without having
9893     touched its element type.  Fixing each element will be done later,
9894     when (if) necessary.
9895
9896     Arrays are a little simpler to handle than records, because the same
9897     amount of memory is allocated for each element of the array, even if
9898     the amount of space actually used by each element differs from element
9899     to element.  Consider for instance the following array of type Rec:
9900
9901        type Rec_Array is array (1 .. 2) of Rec;
9902
9903     The actual amount of memory occupied by each element might be different
9904     from element to element, depending on the value of their discriminant.
9905     But the amount of space reserved for each element in the array remains
9906     fixed regardless.  So we simply need to compute that size using
9907     the debugging information available, from which we can then determine
9908     the array size (we multiply the number of elements of the array by
9909     the size of each element).
9910
9911     The simplest case is when we have an array of a constrained element
9912     type. For instance, consider the following type declarations:
9913
9914         type Bounded_String (Max_Size : Integer) is
9915            Length : Integer;
9916            Buffer : String (1 .. Max_Size);
9917         end record;
9918         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9919
9920     In this case, the compiler describes the array as an array of
9921     variable-size elements (identified by its XVS suffix) for which
9922     the size can be read in the parallel XVZ variable.
9923
9924     In the case of an array of an unconstrained element type, the compiler
9925     wraps the array element inside a private PAD type.  This type should not
9926     be shown to the user, and must be "unwrap"'ed before printing.  Note
9927     that we also use the adjective "aligner" in our code to designate
9928     these wrapper types.
9929
9930     In some cases, the size allocated for each element is statically
9931     known.  In that case, the PAD type already has the correct size,
9932     and the array element should remain unfixed.
9933
9934     But there are cases when this size is not statically known.
9935     For instance, assuming that "Five" is an integer variable:
9936
9937         type Dynamic is array (1 .. Five) of Integer;
9938         type Wrapper (Has_Length : Boolean := False) is record
9939            Data : Dynamic;
9940            case Has_Length is
9941               when True => Length : Integer;
9942               when False => null;
9943            end case;
9944         end record;
9945         type Wrapper_Array is array (1 .. 2) of Wrapper;
9946
9947         Hello : Wrapper_Array := (others => (Has_Length => True,
9948                                              Data => (others => 17),
9949                                              Length => 1));
9950
9951
9952     The debugging info would describe variable Hello as being an
9953     array of a PAD type.  The size of that PAD type is not statically
9954     known, but can be determined using a parallel XVZ variable.
9955     In that case, a copy of the PAD type with the correct size should
9956     be used for the fixed array.
9957
9958     3. ``Fixing'' record type objects:
9959     ----------------------------------
9960
9961     Things are slightly different from arrays in the case of dynamic
9962     record types.  In this case, in order to compute the associated
9963     fixed type, we need to determine the size and offset of each of
9964     its components.  This, in turn, requires us to compute the fixed
9965     type of each of these components.
9966
9967     Consider for instance the example:
9968
9969         type Bounded_String (Max_Size : Natural) is record
9970            Str : String (1 .. Max_Size);
9971            Length : Natural;
9972         end record;
9973         My_String : Bounded_String (Max_Size => 10);
9974
9975     In that case, the position of field "Length" depends on the size
9976     of field Str, which itself depends on the value of the Max_Size
9977     discriminant.  In order to fix the type of variable My_String,
9978     we need to fix the type of field Str.  Therefore, fixing a variant
9979     record requires us to fix each of its components.
9980
9981     However, if a component does not have a dynamic size, the component
9982     should not be fixed.  In particular, fields that use a PAD type
9983     should not fixed.  Here is an example where this might happen
9984     (assuming type Rec above):
9985
9986        type Container (Big : Boolean) is record
9987           First : Rec;
9988           After : Integer;
9989           case Big is
9990              when True => Another : Integer;
9991              when False => null;
9992           end case;
9993        end record;
9994        My_Container : Container := (Big => False,
9995                                     First => (Empty => True),
9996                                     After => 42);
9997
9998     In that example, the compiler creates a PAD type for component First,
9999     whose size is constant, and then positions the component After just
10000     right after it.  The offset of component After is therefore constant
10001     in this case.
10002
10003     The debugger computes the position of each field based on an algorithm
10004     that uses, among other things, the actual position and size of the field
10005     preceding it.  Let's now imagine that the user is trying to print
10006     the value of My_Container.  If the type fixing was recursive, we would
10007     end up computing the offset of field After based on the size of the
10008     fixed version of field First.  And since in our example First has
10009     only one actual field, the size of the fixed type is actually smaller
10010     than the amount of space allocated to that field, and thus we would
10011     compute the wrong offset of field After.
10012
10013     To make things more complicated, we need to watch out for dynamic
10014     components of variant records (identified by the ___XVL suffix in
10015     the component name).  Even if the target type is a PAD type, the size
10016     of that type might not be statically known.  So the PAD type needs
10017     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
10018     we might end up with the wrong size for our component.  This can be
10019     observed with the following type declarations:
10020
10021         type Octal is new Integer range 0 .. 7;
10022         type Octal_Array is array (Positive range <>) of Octal;
10023         pragma Pack (Octal_Array);
10024
10025         type Octal_Buffer (Size : Positive) is record
10026            Buffer : Octal_Array (1 .. Size);
10027            Length : Integer;
10028         end record;
10029
10030     In that case, Buffer is a PAD type whose size is unset and needs
10031     to be computed by fixing the unwrapped type.
10032
10033     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10034     ----------------------------------------------------------
10035
10036     Lastly, when should the sub-elements of an entity that remained unfixed
10037     thus far, be actually fixed?
10038
10039     The answer is: Only when referencing that element.  For instance
10040     when selecting one component of a record, this specific component
10041     should be fixed at that point in time.  Or when printing the value
10042     of a record, each component should be fixed before its value gets
10043     printed.  Similarly for arrays, the element of the array should be
10044     fixed when printing each element of the array, or when extracting
10045     one element out of that array.  On the other hand, fixing should
10046     not be performed on the elements when taking a slice of an array!
10047
10048     Note that one of the side effects of miscomputing the offset and
10049     size of each field is that we end up also miscomputing the size
10050     of the containing type.  This can have adverse results when computing
10051     the value of an entity.  GDB fetches the value of an entity based
10052     on the size of its type, and thus a wrong size causes GDB to fetch
10053     the wrong amount of memory.  In the case where the computed size is
10054     too small, GDB fetches too little data to print the value of our
10055     entity.  Results in this case are unpredictable, as we usually read
10056     past the buffer containing the data =:-o.  */
10057
10058 /* A helper function for TERNOP_IN_RANGE.  */
10059
10060 static value *
10061 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
10062                       enum noside noside,
10063                       value *arg1, value *arg2, value *arg3)
10064 {
10065   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10066   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10067   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10068   return
10069     value_from_longest (type,
10070                         (value_less (arg1, arg3)
10071                          || value_equal (arg1, arg3))
10072                         && (value_less (arg2, arg1)
10073                             || value_equal (arg2, arg1)));
10074 }
10075
10076 /* A helper function for UNOP_NEG.  */
10077
10078 value *
10079 ada_unop_neg (struct type *expect_type,
10080               struct expression *exp,
10081               enum noside noside, enum exp_opcode op,
10082               struct value *arg1)
10083 {
10084   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10085   return value_neg (arg1);
10086 }
10087
10088 /* A helper function for UNOP_IN_RANGE.  */
10089
10090 value *
10091 ada_unop_in_range (struct type *expect_type,
10092                    struct expression *exp,
10093                    enum noside noside, enum exp_opcode op,
10094                    struct value *arg1, struct type *type)
10095 {
10096   struct value *arg2, *arg3;
10097   switch (type->code ())
10098     {
10099     default:
10100       lim_warning (_("Membership test incompletely implemented; "
10101                      "always returns true"));
10102       type = language_bool_type (exp->language_defn, exp->gdbarch);
10103       return value_from_longest (type, (LONGEST) 1);
10104
10105     case TYPE_CODE_RANGE:
10106       arg2 = value_from_longest (type,
10107                                  type->bounds ()->low.const_val ());
10108       arg3 = value_from_longest (type,
10109                                  type->bounds ()->high.const_val ());
10110       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10111       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10112       type = language_bool_type (exp->language_defn, exp->gdbarch);
10113       return
10114         value_from_longest (type,
10115                             (value_less (arg1, arg3)
10116                              || value_equal (arg1, arg3))
10117                             && (value_less (arg2, arg1)
10118                                 || value_equal (arg2, arg1)));
10119     }
10120 }
10121
10122 /* A helper function for OP_ATR_TAG.  */
10123
10124 value *
10125 ada_atr_tag (struct type *expect_type,
10126              struct expression *exp,
10127              enum noside noside, enum exp_opcode op,
10128              struct value *arg1)
10129 {
10130   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10131     return value_zero (ada_tag_type (arg1), not_lval);
10132
10133   return ada_value_tag (arg1);
10134 }
10135
10136 /* A helper function for OP_ATR_SIZE.  */
10137
10138 value *
10139 ada_atr_size (struct type *expect_type,
10140               struct expression *exp,
10141               enum noside noside, enum exp_opcode op,
10142               struct value *arg1)
10143 {
10144   struct type *type = value_type (arg1);
10145
10146   /* If the argument is a reference, then dereference its type, since
10147      the user is really asking for the size of the actual object,
10148      not the size of the pointer.  */
10149   if (type->code () == TYPE_CODE_REF)
10150     type = TYPE_TARGET_TYPE (type);
10151
10152   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10153     return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
10154   else
10155     return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
10156                                TARGET_CHAR_BIT * TYPE_LENGTH (type));
10157 }
10158
10159 /* A helper function for UNOP_ABS.  */
10160
10161 value *
10162 ada_abs (struct type *expect_type,
10163          struct expression *exp,
10164          enum noside noside, enum exp_opcode op,
10165          struct value *arg1)
10166 {
10167   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10168   if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
10169     return value_neg (arg1);
10170   else
10171     return arg1;
10172 }
10173
10174 /* A helper function for BINOP_MUL.  */
10175
10176 value *
10177 ada_mult_binop (struct type *expect_type,
10178                 struct expression *exp,
10179                 enum noside noside, enum exp_opcode op,
10180                 struct value *arg1, struct value *arg2)
10181 {
10182   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10183     {
10184       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10185       return value_zero (value_type (arg1), not_lval);
10186     }
10187   else
10188     {
10189       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10190       return ada_value_binop (arg1, arg2, op);
10191     }
10192 }
10193
10194 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL.  */
10195
10196 value *
10197 ada_equal_binop (struct type *expect_type,
10198                  struct expression *exp,
10199                  enum noside noside, enum exp_opcode op,
10200                  struct value *arg1, struct value *arg2)
10201 {
10202   int tem;
10203   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10204     tem = 0;
10205   else
10206     {
10207       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10208       tem = ada_value_equal (arg1, arg2);
10209     }
10210   if (op == BINOP_NOTEQUAL)
10211     tem = !tem;
10212   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10213   return value_from_longest (type, (LONGEST) tem);
10214 }
10215
10216 /* A helper function for TERNOP_SLICE.  */
10217
10218 value *
10219 ada_ternop_slice (struct expression *exp,
10220                   enum noside noside,
10221                   struct value *array, struct value *low_bound_val,
10222                   struct value *high_bound_val)
10223 {
10224   LONGEST low_bound;
10225   LONGEST high_bound;
10226
10227   low_bound_val = coerce_ref (low_bound_val);
10228   high_bound_val = coerce_ref (high_bound_val);
10229   low_bound = value_as_long (low_bound_val);
10230   high_bound = value_as_long (high_bound_val);
10231
10232   /* If this is a reference to an aligner type, then remove all
10233      the aligners.  */
10234   if (value_type (array)->code () == TYPE_CODE_REF
10235       && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10236     TYPE_TARGET_TYPE (value_type (array)) =
10237       ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
10238
10239   if (ada_is_any_packed_array_type (value_type (array)))
10240     error (_("cannot slice a packed array"));
10241
10242   /* If this is a reference to an array or an array lvalue,
10243      convert to a pointer.  */
10244   if (value_type (array)->code () == TYPE_CODE_REF
10245       || (value_type (array)->code () == TYPE_CODE_ARRAY
10246           && VALUE_LVAL (array) == lval_memory))
10247     array = value_addr (array);
10248
10249   if (noside == EVAL_AVOID_SIDE_EFFECTS
10250       && ada_is_array_descriptor_type (ada_check_typedef
10251                                        (value_type (array))))
10252     return empty_array (ada_type_of_array (array, 0), low_bound,
10253                         high_bound);
10254
10255   array = ada_coerce_to_simple_array_ptr (array);
10256
10257   /* If we have more than one level of pointer indirection,
10258      dereference the value until we get only one level.  */
10259   while (value_type (array)->code () == TYPE_CODE_PTR
10260          && (TYPE_TARGET_TYPE (value_type (array))->code ()
10261              == TYPE_CODE_PTR))
10262     array = value_ind (array);
10263
10264   /* Make sure we really do have an array type before going further,
10265      to avoid a SEGV when trying to get the index type or the target
10266      type later down the road if the debug info generated by
10267      the compiler is incorrect or incomplete.  */
10268   if (!ada_is_simple_array_type (value_type (array)))
10269     error (_("cannot take slice of non-array"));
10270
10271   if (ada_check_typedef (value_type (array))->code ()
10272       == TYPE_CODE_PTR)
10273     {
10274       struct type *type0 = ada_check_typedef (value_type (array));
10275
10276       if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10277         return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
10278       else
10279         {
10280           struct type *arr_type0 =
10281             to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
10282
10283           return ada_value_slice_from_ptr (array, arr_type0,
10284                                            longest_to_int (low_bound),
10285                                            longest_to_int (high_bound));
10286         }
10287     }
10288   else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10289     return array;
10290   else if (high_bound < low_bound)
10291     return empty_array (value_type (array), low_bound, high_bound);
10292   else
10293     return ada_value_slice (array, longest_to_int (low_bound),
10294                             longest_to_int (high_bound));
10295 }
10296
10297 /* A helper function for BINOP_IN_BOUNDS.  */
10298
10299 value *
10300 ada_binop_in_bounds (struct expression *exp, enum noside noside,
10301                      struct value *arg1, struct value *arg2, int n)
10302 {
10303   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10304     {
10305       struct type *type = language_bool_type (exp->language_defn,
10306                                               exp->gdbarch);
10307       return value_zero (type, not_lval);
10308     }
10309
10310   struct type *type = ada_index_type (value_type (arg2), n, "range");
10311   if (!type)
10312     type = value_type (arg1);
10313
10314   value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
10315   arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
10316
10317   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10318   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10319   type = language_bool_type (exp->language_defn, exp->gdbarch);
10320   return value_from_longest (type,
10321                              (value_less (arg1, arg3)
10322                               || value_equal (arg1, arg3))
10323                              && (value_less (arg2, arg1)
10324                                  || value_equal (arg2, arg1)));
10325 }
10326
10327 /* A helper function for some attribute operations.  */
10328
10329 static value *
10330 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
10331               struct value *arg1, struct type *type_arg, int tem)
10332 {
10333   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10334     {
10335       if (type_arg == NULL)
10336         type_arg = value_type (arg1);
10337
10338       if (ada_is_constrained_packed_array_type (type_arg))
10339         type_arg = decode_constrained_packed_array_type (type_arg);
10340
10341       if (!discrete_type_p (type_arg))
10342         {
10343           switch (op)
10344             {
10345             default:          /* Should never happen.  */
10346               error (_("unexpected attribute encountered"));
10347             case OP_ATR_FIRST:
10348             case OP_ATR_LAST:
10349               type_arg = ada_index_type (type_arg, tem,
10350                                          ada_attribute_name (op));
10351               break;
10352             case OP_ATR_LENGTH:
10353               type_arg = builtin_type (exp->gdbarch)->builtin_int;
10354               break;
10355             }
10356         }
10357
10358       return value_zero (type_arg, not_lval);
10359     }
10360   else if (type_arg == NULL)
10361     {
10362       arg1 = ada_coerce_ref (arg1);
10363
10364       if (ada_is_constrained_packed_array_type (value_type (arg1)))
10365         arg1 = ada_coerce_to_simple_array (arg1);
10366
10367       struct type *type;
10368       if (op == OP_ATR_LENGTH)
10369         type = builtin_type (exp->gdbarch)->builtin_int;
10370       else
10371         {
10372           type = ada_index_type (value_type (arg1), tem,
10373                                  ada_attribute_name (op));
10374           if (type == NULL)
10375             type = builtin_type (exp->gdbarch)->builtin_int;
10376         }
10377
10378       switch (op)
10379         {
10380         default:          /* Should never happen.  */
10381           error (_("unexpected attribute encountered"));
10382         case OP_ATR_FIRST:
10383           return value_from_longest
10384             (type, ada_array_bound (arg1, tem, 0));
10385         case OP_ATR_LAST:
10386           return value_from_longest
10387             (type, ada_array_bound (arg1, tem, 1));
10388         case OP_ATR_LENGTH:
10389           return value_from_longest
10390             (type, ada_array_length (arg1, tem));
10391         }
10392     }
10393   else if (discrete_type_p (type_arg))
10394     {
10395       struct type *range_type;
10396       const char *name = ada_type_name (type_arg);
10397
10398       range_type = NULL;
10399       if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10400         range_type = to_fixed_range_type (type_arg, NULL);
10401       if (range_type == NULL)
10402         range_type = type_arg;
10403       switch (op)
10404         {
10405         default:
10406           error (_("unexpected attribute encountered"));
10407         case OP_ATR_FIRST:
10408           return value_from_longest 
10409             (range_type, ada_discrete_type_low_bound (range_type));
10410         case OP_ATR_LAST:
10411           return value_from_longest
10412             (range_type, ada_discrete_type_high_bound (range_type));
10413         case OP_ATR_LENGTH:
10414           error (_("the 'length attribute applies only to array types"));
10415         }
10416     }
10417   else if (type_arg->code () == TYPE_CODE_FLT)
10418     error (_("unimplemented type attribute"));
10419   else
10420     {
10421       LONGEST low, high;
10422
10423       if (ada_is_constrained_packed_array_type (type_arg))
10424         type_arg = decode_constrained_packed_array_type (type_arg);
10425
10426       struct type *type;
10427       if (op == OP_ATR_LENGTH)
10428         type = builtin_type (exp->gdbarch)->builtin_int;
10429       else
10430         {
10431           type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10432           if (type == NULL)
10433             type = builtin_type (exp->gdbarch)->builtin_int;
10434         }
10435
10436       switch (op)
10437         {
10438         default:
10439           error (_("unexpected attribute encountered"));
10440         case OP_ATR_FIRST:
10441           low = ada_array_bound_from_type (type_arg, tem, 0);
10442           return value_from_longest (type, low);
10443         case OP_ATR_LAST:
10444           high = ada_array_bound_from_type (type_arg, tem, 1);
10445           return value_from_longest (type, high);
10446         case OP_ATR_LENGTH:
10447           low = ada_array_bound_from_type (type_arg, tem, 0);
10448           high = ada_array_bound_from_type (type_arg, tem, 1);
10449           return value_from_longest (type, high - low + 1);
10450         }
10451     }
10452 }
10453
10454 /* A helper function for OP_ATR_MIN and OP_ATR_MAX.  */
10455
10456 struct value *
10457 ada_binop_minmax (struct type *expect_type,
10458                   struct expression *exp,
10459                   enum noside noside, enum exp_opcode op,
10460                   struct value *arg1, struct value *arg2)
10461 {
10462   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10463     return value_zero (value_type (arg1), not_lval);
10464   else
10465     {
10466       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10467       return value_binop (arg1, arg2, op);
10468     }
10469 }
10470
10471 /* A helper function for BINOP_EXP.  */
10472
10473 struct value *
10474 ada_binop_exp (struct type *expect_type,
10475                struct expression *exp,
10476                enum noside noside, enum exp_opcode op,
10477                struct value *arg1, struct value *arg2)
10478 {
10479   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10480     return value_zero (value_type (arg1), not_lval);
10481   else
10482     {
10483       /* For integer exponentiation operations,
10484          only promote the first argument.  */
10485       if (is_integral_type (value_type (arg2)))
10486         unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10487       else
10488         binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10489
10490       return value_binop (arg1, arg2, op);
10491     }
10492 }
10493
10494 namespace expr
10495 {
10496
10497 /* See ada-exp.h.  */
10498
10499 operation_up
10500 ada_resolvable::replace (operation_up &&owner,
10501                          struct expression *exp,
10502                          bool deprocedure_p,
10503                          bool parse_completion,
10504                          innermost_block_tracker *tracker,
10505                          struct type *context_type)
10506 {
10507   if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10508     return (make_operation<ada_funcall_operation>
10509             (std::move (owner),
10510              std::vector<operation_up> ()));
10511   return std::move (owner);
10512 }
10513
10514 /* Convert the character literal whose value would be VAL to the
10515    appropriate value of type TYPE, if there is a translation.
10516    Otherwise return VAL.  Hence, in an enumeration type ('A', 'B'),
10517    the literal 'A' (VAL == 65), returns 0.  */
10518
10519 static LONGEST
10520 convert_char_literal (struct type *type, LONGEST val)
10521 {
10522   char name[12];
10523   int f;
10524
10525   if (type == NULL)
10526     return val;
10527   type = check_typedef (type);
10528   if (type->code () != TYPE_CODE_ENUM)
10529     return val;
10530
10531   if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10532     xsnprintf (name, sizeof (name), "Q%c", (int) val);
10533   else if (val >= 0 && val < 256)
10534     xsnprintf (name, sizeof (name), "QU%02x", (unsigned) val);
10535   else if (val >= 0 && val < 0x10000)
10536     xsnprintf (name, sizeof (name), "QW%04x", (unsigned) val);
10537   else
10538     xsnprintf (name, sizeof (name), "QWW%08lx", (unsigned long) val);
10539   size_t len = strlen (name);
10540   for (f = 0; f < type->num_fields (); f += 1)
10541     {
10542       /* Check the suffix because an enum constant in a package will
10543          have a name like "pkg__QUxx".  This is safe enough because we
10544          already have the correct type, and because mangling means
10545          there can't be clashes.  */
10546       const char *ename = type->field (f).name ();
10547       size_t elen = strlen (ename);
10548
10549       if (elen >= len && strcmp (name, ename + elen - len) == 0)
10550         return type->field (f).loc_enumval ();
10551     }
10552   return val;
10553 }
10554
10555 /* See ada-exp.h.  */
10556
10557 operation_up
10558 ada_char_operation::replace (operation_up &&owner,
10559                              struct expression *exp,
10560                              bool deprocedure_p,
10561                              bool parse_completion,
10562                              innermost_block_tracker *tracker,
10563                              struct type *context_type)
10564 {
10565   operation_up result = std::move (owner);
10566
10567   if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10568     {
10569       gdb_assert (result.get () == this);
10570       std::get<0> (m_storage) = context_type;
10571       std::get<1> (m_storage)
10572         = convert_char_literal (context_type, std::get<1> (m_storage));
10573     }
10574
10575   return make_operation<ada_wrapped_operation> (std::move (result));
10576 }
10577
10578 value *
10579 ada_wrapped_operation::evaluate (struct type *expect_type,
10580                                  struct expression *exp,
10581                                  enum noside noside)
10582 {
10583   value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10584   if (noside == EVAL_NORMAL)
10585     result = unwrap_value (result);
10586
10587   /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10588      then we need to perform the conversion manually, because
10589      evaluate_subexp_standard doesn't do it.  This conversion is
10590      necessary in Ada because the different kinds of float/fixed
10591      types in Ada have different representations.
10592
10593      Similarly, we need to perform the conversion from OP_LONG
10594      ourselves.  */
10595   if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10596     result = ada_value_cast (expect_type, result);
10597
10598   return result;
10599 }
10600
10601 value *
10602 ada_string_operation::evaluate (struct type *expect_type,
10603                                 struct expression *exp,
10604                                 enum noside noside)
10605 {
10606   struct type *char_type;
10607   if (expect_type != nullptr && ada_is_string_type (expect_type))
10608     char_type = ada_array_element_type (expect_type, 1);
10609   else
10610     char_type = language_string_char_type (exp->language_defn, exp->gdbarch);
10611
10612   const std::string &str = std::get<0> (m_storage);
10613   const char *encoding;
10614   switch (TYPE_LENGTH (char_type))
10615     {
10616     case 1:
10617       {
10618         /* Simply copy over the data -- this isn't perhaps strictly
10619            correct according to the encodings, but it is gdb's
10620            historical behavior.  */
10621         struct type *stringtype
10622           = lookup_array_range_type (char_type, 1, str.length ());
10623         struct value *val = allocate_value (stringtype);
10624         memcpy (value_contents_raw (val).data (), str.c_str (),
10625                 str.length ());
10626         return val;
10627       }
10628
10629     case 2:
10630       if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10631         encoding = "UTF-16BE";
10632       else
10633         encoding = "UTF-16LE";
10634       break;
10635
10636     case 4:
10637       if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10638         encoding = "UTF-32BE";
10639       else
10640         encoding = "UTF-32LE";
10641       break;
10642
10643     default:
10644       error (_("unexpected character type size %s"),
10645              pulongest (TYPE_LENGTH (char_type)));
10646     }
10647
10648   auto_obstack converted;
10649   convert_between_encodings (host_charset (), encoding,
10650                              (const gdb_byte *) str.c_str (),
10651                              str.length (), 1,
10652                              &converted, translit_none);
10653
10654   struct type *stringtype
10655     = lookup_array_range_type (char_type, 1,
10656                                obstack_object_size (&converted)
10657                                / TYPE_LENGTH (char_type));
10658   struct value *val = allocate_value (stringtype);
10659   memcpy (value_contents_raw (val).data (),
10660           obstack_base (&converted),
10661           obstack_object_size (&converted));
10662   return val;
10663 }
10664
10665 value *
10666 ada_qual_operation::evaluate (struct type *expect_type,
10667                               struct expression *exp,
10668                               enum noside noside)
10669 {
10670   struct type *type = std::get<1> (m_storage);
10671   return std::get<0> (m_storage)->evaluate (type, exp, noside);
10672 }
10673
10674 value *
10675 ada_ternop_range_operation::evaluate (struct type *expect_type,
10676                                       struct expression *exp,
10677                                       enum noside noside)
10678 {
10679   value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10680   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10681   value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10682   return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10683 }
10684
10685 value *
10686 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10687                                       struct expression *exp,
10688                                       enum noside noside)
10689 {
10690   value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10691   value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10692
10693   auto do_op = [=] (LONGEST x, LONGEST y)
10694     {
10695       if (std::get<0> (m_storage) == BINOP_ADD)
10696         return x + y;
10697       return x - y;
10698     };
10699
10700   if (value_type (arg1)->code () == TYPE_CODE_PTR)
10701     return (value_from_longest
10702             (value_type (arg1),
10703              do_op (value_as_long (arg1), value_as_long (arg2))));
10704   if (value_type (arg2)->code () == TYPE_CODE_PTR)
10705     return (value_from_longest
10706             (value_type (arg2),
10707              do_op (value_as_long (arg1), value_as_long (arg2))));
10708   /* Preserve the original type for use by the range case below.
10709      We cannot cast the result to a reference type, so if ARG1 is
10710      a reference type, find its underlying type.  */
10711   struct type *type = value_type (arg1);
10712   while (type->code () == TYPE_CODE_REF)
10713     type = TYPE_TARGET_TYPE (type);
10714   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10715   arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10716   /* We need to special-case the result with a range.
10717      This is done for the benefit of "ptype".  gdb's Ada support
10718      historically used the LHS to set the result type here, so
10719      preserve this behavior.  */
10720   if (type->code () == TYPE_CODE_RANGE)
10721     arg1 = value_cast (type, arg1);
10722   return arg1;
10723 }
10724
10725 value *
10726 ada_unop_atr_operation::evaluate (struct type *expect_type,
10727                                   struct expression *exp,
10728                                   enum noside noside)
10729 {
10730   struct type *type_arg = nullptr;
10731   value *val = nullptr;
10732
10733   if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10734     {
10735       value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10736                                                       EVAL_AVOID_SIDE_EFFECTS);
10737       type_arg = value_type (tem);
10738     }
10739   else
10740     val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10741
10742   return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10743                        val, type_arg, std::get<2> (m_storage));
10744 }
10745
10746 value *
10747 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10748                                                  struct expression *exp,
10749                                                  enum noside noside)
10750 {
10751   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10752     return value_zero (expect_type, not_lval);
10753
10754   const bound_minimal_symbol &b = std::get<0> (m_storage);
10755   value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10756
10757   val = ada_value_cast (expect_type, val);
10758
10759   /* Follow the Ada language semantics that do not allow taking
10760      an address of the result of a cast (view conversion in Ada).  */
10761   if (VALUE_LVAL (val) == lval_memory)
10762     {
10763       if (value_lazy (val))
10764         value_fetch_lazy (val);
10765       VALUE_LVAL (val) = not_lval;
10766     }
10767   return val;
10768 }
10769
10770 value *
10771 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10772                                             struct expression *exp,
10773                                             enum noside noside)
10774 {
10775   value *val = evaluate_var_value (noside,
10776                                    std::get<0> (m_storage).block,
10777                                    std::get<0> (m_storage).symbol);
10778
10779   val = ada_value_cast (expect_type, val);
10780
10781   /* Follow the Ada language semantics that do not allow taking
10782      an address of the result of a cast (view conversion in Ada).  */
10783   if (VALUE_LVAL (val) == lval_memory)
10784     {
10785       if (value_lazy (val))
10786         value_fetch_lazy (val);
10787       VALUE_LVAL (val) = not_lval;
10788     }
10789   return val;
10790 }
10791
10792 value *
10793 ada_var_value_operation::evaluate (struct type *expect_type,
10794                                    struct expression *exp,
10795                                    enum noside noside)
10796 {
10797   symbol *sym = std::get<0> (m_storage).symbol;
10798
10799   if (sym->domain () == UNDEF_DOMAIN)
10800     /* Only encountered when an unresolved symbol occurs in a
10801        context other than a function call, in which case, it is
10802        invalid.  */
10803     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10804            sym->print_name ());
10805
10806   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10807     {
10808       struct type *type = static_unwrap_type (sym->type ());
10809       /* Check to see if this is a tagged type.  We also need to handle
10810          the case where the type is a reference to a tagged type, but
10811          we have to be careful to exclude pointers to tagged types.
10812          The latter should be shown as usual (as a pointer), whereas
10813          a reference should mostly be transparent to the user.  */
10814       if (ada_is_tagged_type (type, 0)
10815           || (type->code () == TYPE_CODE_REF
10816               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10817         {
10818           /* Tagged types are a little special in the fact that the real
10819              type is dynamic and can only be determined by inspecting the
10820              object's tag.  This means that we need to get the object's
10821              value first (EVAL_NORMAL) and then extract the actual object
10822              type from its tag.
10823
10824              Note that we cannot skip the final step where we extract
10825              the object type from its tag, because the EVAL_NORMAL phase
10826              results in dynamic components being resolved into fixed ones.
10827              This can cause problems when trying to print the type
10828              description of tagged types whose parent has a dynamic size:
10829              We use the type name of the "_parent" component in order
10830              to print the name of the ancestor type in the type description.
10831              If that component had a dynamic size, the resolution into
10832              a fixed type would result in the loss of that type name,
10833              thus preventing us from printing the name of the ancestor
10834              type in the type description.  */
10835           value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10836
10837           if (type->code () != TYPE_CODE_REF)
10838             {
10839               struct type *actual_type;
10840
10841               actual_type = type_from_tag (ada_value_tag (arg1));
10842               if (actual_type == NULL)
10843                 /* If, for some reason, we were unable to determine
10844                    the actual type from the tag, then use the static
10845                    approximation that we just computed as a fallback.
10846                    This can happen if the debugging information is
10847                    incomplete, for instance.  */
10848                 actual_type = type;
10849               return value_zero (actual_type, not_lval);
10850             }
10851           else
10852             {
10853               /* In the case of a ref, ada_coerce_ref takes care
10854                  of determining the actual type.  But the evaluation
10855                  should return a ref as it should be valid to ask
10856                  for its address; so rebuild a ref after coerce.  */
10857               arg1 = ada_coerce_ref (arg1);
10858               return value_ref (arg1, TYPE_CODE_REF);
10859             }
10860         }
10861
10862       /* Records and unions for which GNAT encodings have been
10863          generated need to be statically fixed as well.
10864          Otherwise, non-static fixing produces a type where
10865          all dynamic properties are removed, which prevents "ptype"
10866          from being able to completely describe the type.
10867          For instance, a case statement in a variant record would be
10868          replaced by the relevant components based on the actual
10869          value of the discriminants.  */
10870       if ((type->code () == TYPE_CODE_STRUCT
10871            && dynamic_template_type (type) != NULL)
10872           || (type->code () == TYPE_CODE_UNION
10873               && ada_find_parallel_type (type, "___XVU") != NULL))
10874         return value_zero (to_static_fixed_type (type), not_lval);
10875     }
10876
10877   value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10878   return ada_to_fixed_value (arg1);
10879 }
10880
10881 bool
10882 ada_var_value_operation::resolve (struct expression *exp,
10883                                   bool deprocedure_p,
10884                                   bool parse_completion,
10885                                   innermost_block_tracker *tracker,
10886                                   struct type *context_type)
10887 {
10888   symbol *sym = std::get<0> (m_storage).symbol;
10889   if (sym->domain () == UNDEF_DOMAIN)
10890     {
10891       block_symbol resolved
10892         = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10893                                 context_type, parse_completion,
10894                                 deprocedure_p, tracker);
10895       std::get<0> (m_storage) = resolved;
10896     }
10897
10898   if (deprocedure_p
10899       && (std::get<0> (m_storage).symbol->type ()->code ()
10900           == TYPE_CODE_FUNC))
10901     return true;
10902
10903   return false;
10904 }
10905
10906 value *
10907 ada_atr_val_operation::evaluate (struct type *expect_type,
10908                                  struct expression *exp,
10909                                  enum noside noside)
10910 {
10911   value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10912   return ada_val_atr (noside, std::get<0> (m_storage), arg);
10913 }
10914
10915 value *
10916 ada_unop_ind_operation::evaluate (struct type *expect_type,
10917                                   struct expression *exp,
10918                                   enum noside noside)
10919 {
10920   value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10921
10922   struct type *type = ada_check_typedef (value_type (arg1));
10923   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10924     {
10925       if (ada_is_array_descriptor_type (type))
10926         /* GDB allows dereferencing GNAT array descriptors.  */
10927         {
10928           struct type *arrType = ada_type_of_array (arg1, 0);
10929
10930           if (arrType == NULL)
10931             error (_("Attempt to dereference null array pointer."));
10932           return value_at_lazy (arrType, 0);
10933         }
10934       else if (type->code () == TYPE_CODE_PTR
10935                || type->code () == TYPE_CODE_REF
10936                /* In C you can dereference an array to get the 1st elt.  */
10937                || type->code () == TYPE_CODE_ARRAY)
10938         {
10939           /* As mentioned in the OP_VAR_VALUE case, tagged types can
10940              only be determined by inspecting the object's tag.
10941              This means that we need to evaluate completely the
10942              expression in order to get its type.  */
10943
10944           if ((type->code () == TYPE_CODE_REF
10945                || type->code () == TYPE_CODE_PTR)
10946               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
10947             {
10948               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
10949                                                         EVAL_NORMAL);
10950               type = value_type (ada_value_ind (arg1));
10951             }
10952           else
10953             {
10954               type = to_static_fixed_type
10955                 (ada_aligned_type
10956                  (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10957             }
10958           return value_zero (type, lval_memory);
10959         }
10960       else if (type->code () == TYPE_CODE_INT)
10961         {
10962           /* GDB allows dereferencing an int.  */
10963           if (expect_type == NULL)
10964             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10965                                lval_memory);
10966           else
10967             {
10968               expect_type =
10969                 to_static_fixed_type (ada_aligned_type (expect_type));
10970               return value_zero (expect_type, lval_memory);
10971             }
10972         }
10973       else
10974         error (_("Attempt to take contents of a non-pointer value."));
10975     }
10976   arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
10977   type = ada_check_typedef (value_type (arg1));
10978
10979   if (type->code () == TYPE_CODE_INT)
10980     /* GDB allows dereferencing an int.  If we were given
10981        the expect_type, then use that as the target type.
10982        Otherwise, assume that the target type is an int.  */
10983     {
10984       if (expect_type != NULL)
10985         return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10986                                           arg1));
10987       else
10988         return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10989                               (CORE_ADDR) value_as_address (arg1));
10990     }
10991
10992   if (ada_is_array_descriptor_type (type))
10993     /* GDB allows dereferencing GNAT array descriptors.  */
10994     return ada_coerce_to_simple_array (arg1);
10995   else
10996     return ada_value_ind (arg1);
10997 }
10998
10999 value *
11000 ada_structop_operation::evaluate (struct type *expect_type,
11001                                   struct expression *exp,
11002                                   enum noside noside)
11003 {
11004   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
11005   const char *str = std::get<1> (m_storage).c_str ();
11006   if (noside == EVAL_AVOID_SIDE_EFFECTS)
11007     {
11008       struct type *type;
11009       struct type *type1 = value_type (arg1);
11010
11011       if (ada_is_tagged_type (type1, 1))
11012         {
11013           type = ada_lookup_struct_elt_type (type1, str, 1, 1);
11014
11015           /* If the field is not found, check if it exists in the
11016              extension of this object's type. This means that we
11017              need to evaluate completely the expression.  */
11018
11019           if (type == NULL)
11020             {
11021               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11022                                                         EVAL_NORMAL);
11023               arg1 = ada_value_struct_elt (arg1, str, 0);
11024               arg1 = unwrap_value (arg1);
11025               type = value_type (ada_to_fixed_value (arg1));
11026             }
11027         }
11028       else
11029         type = ada_lookup_struct_elt_type (type1, str, 1, 0);
11030
11031       return value_zero (ada_aligned_type (type), lval_memory);
11032     }
11033   else
11034     {
11035       arg1 = ada_value_struct_elt (arg1, str, 0);
11036       arg1 = unwrap_value (arg1);
11037       return ada_to_fixed_value (arg1);
11038     }
11039 }
11040
11041 value *
11042 ada_funcall_operation::evaluate (struct type *expect_type,
11043                                  struct expression *exp,
11044                                  enum noside noside)
11045 {
11046   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11047   int nargs = args_up.size ();
11048   std::vector<value *> argvec (nargs);
11049   operation_up &callee_op = std::get<0> (m_storage);
11050
11051   ada_var_value_operation *avv
11052     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11053   if (avv != nullptr
11054       && avv->get_symbol ()->domain () == UNDEF_DOMAIN)
11055     error (_("Unexpected unresolved symbol, %s, during evaluation"),
11056            avv->get_symbol ()->print_name ());
11057
11058   value *callee = callee_op->evaluate (nullptr, exp, noside);
11059   for (int i = 0; i < args_up.size (); ++i)
11060     argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
11061
11062   if (ada_is_constrained_packed_array_type
11063       (desc_base_type (value_type (callee))))
11064     callee = ada_coerce_to_simple_array (callee);
11065   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11066            && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
11067     /* This is a packed array that has already been fixed, and
11068        therefore already coerced to a simple array.  Nothing further
11069        to do.  */
11070     ;
11071   else if (value_type (callee)->code () == TYPE_CODE_REF)
11072     {
11073       /* Make sure we dereference references so that all the code below
11074          feels like it's really handling the referenced value.  Wrapping
11075          types (for alignment) may be there, so make sure we strip them as
11076          well.  */
11077       callee = ada_to_fixed_value (coerce_ref (callee));
11078     }
11079   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11080            && VALUE_LVAL (callee) == lval_memory)
11081     callee = value_addr (callee);
11082
11083   struct type *type = ada_check_typedef (value_type (callee));
11084
11085   /* Ada allows us to implicitly dereference arrays when subscripting
11086      them.  So, if this is an array typedef (encoding use for array
11087      access types encoded as fat pointers), strip it now.  */
11088   if (type->code () == TYPE_CODE_TYPEDEF)
11089     type = ada_typedef_target_type (type);
11090
11091   if (type->code () == TYPE_CODE_PTR)
11092     {
11093       switch (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ())
11094         {
11095         case TYPE_CODE_FUNC:
11096           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
11097           break;
11098         case TYPE_CODE_ARRAY:
11099           break;
11100         case TYPE_CODE_STRUCT:
11101           if (noside != EVAL_AVOID_SIDE_EFFECTS)
11102             callee = ada_value_ind (callee);
11103           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
11104           break;
11105         default:
11106           error (_("cannot subscript or call something of type `%s'"),
11107                  ada_type_name (value_type (callee)));
11108           break;
11109         }
11110     }
11111
11112   switch (type->code ())
11113     {
11114     case TYPE_CODE_FUNC:
11115       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11116         {
11117           if (TYPE_TARGET_TYPE (type) == NULL)
11118             error_call_unknown_return_type (NULL);
11119           return allocate_value (TYPE_TARGET_TYPE (type));
11120         }
11121       return call_function_by_hand (callee, NULL, argvec);
11122     case TYPE_CODE_INTERNAL_FUNCTION:
11123       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11124         /* We don't know anything about what the internal
11125            function might return, but we have to return
11126            something.  */
11127         return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11128                            not_lval);
11129       else
11130         return call_internal_function (exp->gdbarch, exp->language_defn,
11131                                        callee, nargs,
11132                                        argvec.data ());
11133
11134     case TYPE_CODE_STRUCT:
11135       {
11136         int arity;
11137
11138         arity = ada_array_arity (type);
11139         type = ada_array_element_type (type, nargs);
11140         if (type == NULL)
11141           error (_("cannot subscript or call a record"));
11142         if (arity != nargs)
11143           error (_("wrong number of subscripts; expecting %d"), arity);
11144         if (noside == EVAL_AVOID_SIDE_EFFECTS)
11145           return value_zero (ada_aligned_type (type), lval_memory);
11146         return
11147           unwrap_value (ada_value_subscript
11148                         (callee, nargs, argvec.data ()));
11149       }
11150     case TYPE_CODE_ARRAY:
11151       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11152         {
11153           type = ada_array_element_type (type, nargs);
11154           if (type == NULL)
11155             error (_("element type of array unknown"));
11156           else
11157             return value_zero (ada_aligned_type (type), lval_memory);
11158         }
11159       return
11160         unwrap_value (ada_value_subscript
11161                       (ada_coerce_to_simple_array (callee),
11162                        nargs, argvec.data ()));
11163     case TYPE_CODE_PTR:     /* Pointer to array */
11164       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11165         {
11166           type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
11167           type = ada_array_element_type (type, nargs);
11168           if (type == NULL)
11169             error (_("element type of array unknown"));
11170           else
11171             return value_zero (ada_aligned_type (type), lval_memory);
11172         }
11173       return
11174         unwrap_value (ada_value_ptr_subscript (callee, nargs,
11175                                                argvec.data ()));
11176
11177     default:
11178       error (_("Attempt to index or call something other than an "
11179                "array or function"));
11180     }
11181 }
11182
11183 bool
11184 ada_funcall_operation::resolve (struct expression *exp,
11185                                 bool deprocedure_p,
11186                                 bool parse_completion,
11187                                 innermost_block_tracker *tracker,
11188                                 struct type *context_type)
11189 {
11190   operation_up &callee_op = std::get<0> (m_storage);
11191
11192   ada_var_value_operation *avv
11193     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11194   if (avv == nullptr)
11195     return false;
11196
11197   symbol *sym = avv->get_symbol ();
11198   if (sym->domain () != UNDEF_DOMAIN)
11199     return false;
11200
11201   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11202   int nargs = args_up.size ();
11203   std::vector<value *> argvec (nargs);
11204
11205   for (int i = 0; i < args_up.size (); ++i)
11206     argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
11207
11208   const block *block = avv->get_block ();
11209   block_symbol resolved
11210     = ada_resolve_funcall (sym, block,
11211                            context_type, parse_completion,
11212                            nargs, argvec.data (),
11213                            tracker);
11214
11215   std::get<0> (m_storage)
11216     = make_operation<ada_var_value_operation> (resolved);
11217   return false;
11218 }
11219
11220 bool
11221 ada_ternop_slice_operation::resolve (struct expression *exp,
11222                                      bool deprocedure_p,
11223                                      bool parse_completion,
11224                                      innermost_block_tracker *tracker,
11225                                      struct type *context_type)
11226 {
11227   /* Historically this check was done during resolution, so we
11228      continue that here.  */
11229   value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
11230                                                 EVAL_AVOID_SIDE_EFFECTS);
11231   if (ada_is_any_packed_array_type (value_type (v)))
11232     error (_("cannot slice a packed array"));
11233   return false;
11234 }
11235
11236 }
11237
11238 \f
11239
11240 /* Return non-zero iff TYPE represents a System.Address type.  */
11241
11242 int
11243 ada_is_system_address_type (struct type *type)
11244 {
11245   return (type->name () && strcmp (type->name (), "system__address") == 0);
11246 }
11247
11248 \f
11249
11250                                 /* Range types */
11251
11252 /* Scan STR beginning at position K for a discriminant name, and
11253    return the value of that discriminant field of DVAL in *PX.  If
11254    PNEW_K is not null, put the position of the character beyond the
11255    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
11256    not alter *PX and *PNEW_K if unsuccessful.  */
11257
11258 static int
11259 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11260                     int *pnew_k)
11261 {
11262   static std::string storage;
11263   const char *pstart, *pend, *bound;
11264   struct value *bound_val;
11265
11266   if (dval == NULL || str == NULL || str[k] == '\0')
11267     return 0;
11268
11269   pstart = str + k;
11270   pend = strstr (pstart, "__");
11271   if (pend == NULL)
11272     {
11273       bound = pstart;
11274       k += strlen (bound);
11275     }
11276   else
11277     {
11278       int len = pend - pstart;
11279
11280       /* Strip __ and beyond.  */
11281       storage = std::string (pstart, len);
11282       bound = storage.c_str ();
11283       k = pend - str;
11284     }
11285
11286   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11287   if (bound_val == NULL)
11288     return 0;
11289
11290   *px = value_as_long (bound_val);
11291   if (pnew_k != NULL)
11292     *pnew_k = k;
11293   return 1;
11294 }
11295
11296 /* Value of variable named NAME.  Only exact matches are considered.
11297    If no such variable found, then if ERR_MSG is null, returns 0, and
11298    otherwise causes an error with message ERR_MSG.  */
11299
11300 static struct value *
11301 get_var_value (const char *name, const char *err_msg)
11302 {
11303   std::string quoted_name = add_angle_brackets (name);
11304
11305   lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
11306
11307   std::vector<struct block_symbol> syms
11308     = ada_lookup_symbol_list_worker (lookup_name,
11309                                      get_selected_block (0),
11310                                      VAR_DOMAIN, 1);
11311
11312   if (syms.size () != 1)
11313     {
11314       if (err_msg == NULL)
11315         return 0;
11316       else
11317         error (("%s"), err_msg);
11318     }
11319
11320   return value_of_variable (syms[0].symbol, syms[0].block);
11321 }
11322
11323 /* Value of integer variable named NAME in the current environment.
11324    If no such variable is found, returns false.  Otherwise, sets VALUE
11325    to the variable's value and returns true.  */
11326
11327 bool
11328 get_int_var_value (const char *name, LONGEST &value)
11329 {
11330   struct value *var_val = get_var_value (name, 0);
11331
11332   if (var_val == 0)
11333     return false;
11334
11335   value = value_as_long (var_val);
11336   return true;
11337 }
11338
11339
11340 /* Return a range type whose base type is that of the range type named
11341    NAME in the current environment, and whose bounds are calculated
11342    from NAME according to the GNAT range encoding conventions.
11343    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
11344    corresponding range type from debug information; fall back to using it
11345    if symbol lookup fails.  If a new type must be created, allocate it
11346    like ORIG_TYPE was.  The bounds information, in general, is encoded
11347    in NAME, the base type given in the named range type.  */
11348
11349 static struct type *
11350 to_fixed_range_type (struct type *raw_type, struct value *dval)
11351 {
11352   const char *name;
11353   struct type *base_type;
11354   const char *subtype_info;
11355
11356   gdb_assert (raw_type != NULL);
11357   gdb_assert (raw_type->name () != NULL);
11358
11359   if (raw_type->code () == TYPE_CODE_RANGE)
11360     base_type = TYPE_TARGET_TYPE (raw_type);
11361   else
11362     base_type = raw_type;
11363
11364   name = raw_type->name ();
11365   subtype_info = strstr (name, "___XD");
11366   if (subtype_info == NULL)
11367     {
11368       LONGEST L = ada_discrete_type_low_bound (raw_type);
11369       LONGEST U = ada_discrete_type_high_bound (raw_type);
11370
11371       if (L < INT_MIN || U > INT_MAX)
11372         return raw_type;
11373       else
11374         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11375                                          L, U);
11376     }
11377   else
11378     {
11379       int prefix_len = subtype_info - name;
11380       LONGEST L, U;
11381       struct type *type;
11382       const char *bounds_str;
11383       int n;
11384
11385       subtype_info += 5;
11386       bounds_str = strchr (subtype_info, '_');
11387       n = 1;
11388
11389       if (*subtype_info == 'L')
11390         {
11391           if (!ada_scan_number (bounds_str, n, &L, &n)
11392               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11393             return raw_type;
11394           if (bounds_str[n] == '_')
11395             n += 2;
11396           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
11397             n += 1;
11398           subtype_info += 1;
11399         }
11400       else
11401         {
11402           std::string name_buf = std::string (name, prefix_len) + "___L";
11403           if (!get_int_var_value (name_buf.c_str (), L))
11404             {
11405               lim_warning (_("Unknown lower bound, using 1."));
11406               L = 1;
11407             }
11408         }
11409
11410       if (*subtype_info == 'U')
11411         {
11412           if (!ada_scan_number (bounds_str, n, &U, &n)
11413               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11414             return raw_type;
11415         }
11416       else
11417         {
11418           std::string name_buf = std::string (name, prefix_len) + "___U";
11419           if (!get_int_var_value (name_buf.c_str (), U))
11420             {
11421               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11422               U = L;
11423             }
11424         }
11425
11426       type = create_static_range_type (alloc_type_copy (raw_type),
11427                                        base_type, L, U);
11428       /* create_static_range_type alters the resulting type's length
11429          to match the size of the base_type, which is not what we want.
11430          Set it back to the original range type's length.  */
11431       TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11432       type->set_name (name);
11433       return type;
11434     }
11435 }
11436
11437 /* True iff NAME is the name of a range type.  */
11438
11439 int
11440 ada_is_range_type_name (const char *name)
11441 {
11442   return (name != NULL && strstr (name, "___XD"));
11443 }
11444 \f
11445
11446                                 /* Modular types */
11447
11448 /* True iff TYPE is an Ada modular type.  */
11449
11450 int
11451 ada_is_modular_type (struct type *type)
11452 {
11453   struct type *subranged_type = get_base_type (type);
11454
11455   return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11456           && subranged_type->code () == TYPE_CODE_INT
11457           && subranged_type->is_unsigned ());
11458 }
11459
11460 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
11461
11462 ULONGEST
11463 ada_modulus (struct type *type)
11464 {
11465   const dynamic_prop &high = type->bounds ()->high;
11466
11467   if (high.kind () == PROP_CONST)
11468     return (ULONGEST) high.const_val () + 1;
11469
11470   /* If TYPE is unresolved, the high bound might be a location list.  Return
11471      0, for lack of a better value to return.  */
11472   return 0;
11473 }
11474 \f
11475
11476 /* Ada exception catchpoint support:
11477    ---------------------------------
11478
11479    We support 3 kinds of exception catchpoints:
11480      . catchpoints on Ada exceptions
11481      . catchpoints on unhandled Ada exceptions
11482      . catchpoints on failed assertions
11483
11484    Exceptions raised during failed assertions, or unhandled exceptions
11485    could perfectly be caught with the general catchpoint on Ada exceptions.
11486    However, we can easily differentiate these two special cases, and having
11487    the option to distinguish these two cases from the rest can be useful
11488    to zero-in on certain situations.
11489
11490    Exception catchpoints are a specialized form of breakpoint,
11491    since they rely on inserting breakpoints inside known routines
11492    of the GNAT runtime.  The implementation therefore uses a standard
11493    breakpoint structure of the BP_BREAKPOINT type, but with its own set
11494    of breakpoint_ops.
11495
11496    Support in the runtime for exception catchpoints have been changed
11497    a few times already, and these changes affect the implementation
11498    of these catchpoints.  In order to be able to support several
11499    variants of the runtime, we use a sniffer that will determine
11500    the runtime variant used by the program being debugged.  */
11501
11502 /* Ada's standard exceptions.
11503
11504    The Ada 83 standard also defined Numeric_Error.  But there so many
11505    situations where it was unclear from the Ada 83 Reference Manual
11506    (RM) whether Constraint_Error or Numeric_Error should be raised,
11507    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11508    Interpretation saying that anytime the RM says that Numeric_Error
11509    should be raised, the implementation may raise Constraint_Error.
11510    Ada 95 went one step further and pretty much removed Numeric_Error
11511    from the list of standard exceptions (it made it a renaming of
11512    Constraint_Error, to help preserve compatibility when compiling
11513    an Ada83 compiler). As such, we do not include Numeric_Error from
11514    this list of standard exceptions.  */
11515
11516 static const char * const standard_exc[] = {
11517   "constraint_error",
11518   "program_error",
11519   "storage_error",
11520   "tasking_error"
11521 };
11522
11523 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11524
11525 /* A structure that describes how to support exception catchpoints
11526    for a given executable.  */
11527
11528 struct exception_support_info
11529 {
11530    /* The name of the symbol to break on in order to insert
11531       a catchpoint on exceptions.  */
11532    const char *catch_exception_sym;
11533
11534    /* The name of the symbol to break on in order to insert
11535       a catchpoint on unhandled exceptions.  */
11536    const char *catch_exception_unhandled_sym;
11537
11538    /* The name of the symbol to break on in order to insert
11539       a catchpoint on failed assertions.  */
11540    const char *catch_assert_sym;
11541
11542    /* The name of the symbol to break on in order to insert
11543       a catchpoint on exception handling.  */
11544    const char *catch_handlers_sym;
11545
11546    /* Assuming that the inferior just triggered an unhandled exception
11547       catchpoint, this function is responsible for returning the address
11548       in inferior memory where the name of that exception is stored.
11549       Return zero if the address could not be computed.  */
11550    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11551 };
11552
11553 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11554 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11555
11556 /* The following exception support info structure describes how to
11557    implement exception catchpoints with the latest version of the
11558    Ada runtime (as of 2019-08-??).  */
11559
11560 static const struct exception_support_info default_exception_support_info =
11561 {
11562   "__gnat_debug_raise_exception", /* catch_exception_sym */
11563   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11564   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11565   "__gnat_begin_handler_v1", /* catch_handlers_sym */
11566   ada_unhandled_exception_name_addr
11567 };
11568
11569 /* The following exception support info structure describes how to
11570    implement exception catchpoints with an earlier version of the
11571    Ada runtime (as of 2007-03-06) using v0 of the EH ABI.  */
11572
11573 static const struct exception_support_info exception_support_info_v0 =
11574 {
11575   "__gnat_debug_raise_exception", /* catch_exception_sym */
11576   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11577   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11578   "__gnat_begin_handler", /* catch_handlers_sym */
11579   ada_unhandled_exception_name_addr
11580 };
11581
11582 /* The following exception support info structure describes how to
11583    implement exception catchpoints with a slightly older version
11584    of the Ada runtime.  */
11585
11586 static const struct exception_support_info exception_support_info_fallback =
11587 {
11588   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11589   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11590   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
11591   "__gnat_begin_handler", /* catch_handlers_sym */
11592   ada_unhandled_exception_name_addr_from_raise
11593 };
11594
11595 /* Return nonzero if we can detect the exception support routines
11596    described in EINFO.
11597
11598    This function errors out if an abnormal situation is detected
11599    (for instance, if we find the exception support routines, but
11600    that support is found to be incomplete).  */
11601
11602 static int
11603 ada_has_this_exception_support (const struct exception_support_info *einfo)
11604 {
11605   struct symbol *sym;
11606
11607   /* The symbol we're looking up is provided by a unit in the GNAT runtime
11608      that should be compiled with debugging information.  As a result, we
11609      expect to find that symbol in the symtabs.  */
11610
11611   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11612   if (sym == NULL)
11613     {
11614       /* Perhaps we did not find our symbol because the Ada runtime was
11615          compiled without debugging info, or simply stripped of it.
11616          It happens on some GNU/Linux distributions for instance, where
11617          users have to install a separate debug package in order to get
11618          the runtime's debugging info.  In that situation, let the user
11619          know why we cannot insert an Ada exception catchpoint.
11620
11621          Note: Just for the purpose of inserting our Ada exception
11622          catchpoint, we could rely purely on the associated minimal symbol.
11623          But we would be operating in degraded mode anyway, since we are
11624          still lacking the debugging info needed later on to extract
11625          the name of the exception being raised (this name is printed in
11626          the catchpoint message, and is also used when trying to catch
11627          a specific exception).  We do not handle this case for now.  */
11628       struct bound_minimal_symbol msym
11629         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11630
11631       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11632         error (_("Your Ada runtime appears to be missing some debugging "
11633                  "information.\nCannot insert Ada exception catchpoint "
11634                  "in this configuration."));
11635
11636       return 0;
11637     }
11638
11639   /* Make sure that the symbol we found corresponds to a function.  */
11640
11641   if (sym->aclass () != LOC_BLOCK)
11642     {
11643       error (_("Symbol \"%s\" is not a function (class = %d)"),
11644              sym->linkage_name (), sym->aclass ());
11645       return 0;
11646     }
11647
11648   sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11649   if (sym == NULL)
11650     {
11651       struct bound_minimal_symbol msym
11652         = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11653
11654       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11655         error (_("Your Ada runtime appears to be missing some debugging "
11656                  "information.\nCannot insert Ada exception catchpoint "
11657                  "in this configuration."));
11658
11659       return 0;
11660     }
11661
11662   /* Make sure that the symbol we found corresponds to a function.  */
11663
11664   if (sym->aclass () != LOC_BLOCK)
11665     {
11666       error (_("Symbol \"%s\" is not a function (class = %d)"),
11667              sym->linkage_name (), sym->aclass ());
11668       return 0;
11669     }
11670
11671   return 1;
11672 }
11673
11674 /* Inspect the Ada runtime and determine which exception info structure
11675    should be used to provide support for exception catchpoints.
11676
11677    This function will always set the per-inferior exception_info,
11678    or raise an error.  */
11679
11680 static void
11681 ada_exception_support_info_sniffer (void)
11682 {
11683   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11684
11685   /* If the exception info is already known, then no need to recompute it.  */
11686   if (data->exception_info != NULL)
11687     return;
11688
11689   /* Check the latest (default) exception support info.  */
11690   if (ada_has_this_exception_support (&default_exception_support_info))
11691     {
11692       data->exception_info = &default_exception_support_info;
11693       return;
11694     }
11695
11696   /* Try the v0 exception suport info.  */
11697   if (ada_has_this_exception_support (&exception_support_info_v0))
11698     {
11699       data->exception_info = &exception_support_info_v0;
11700       return;
11701     }
11702
11703   /* Try our fallback exception suport info.  */
11704   if (ada_has_this_exception_support (&exception_support_info_fallback))
11705     {
11706       data->exception_info = &exception_support_info_fallback;
11707       return;
11708     }
11709
11710   /* Sometimes, it is normal for us to not be able to find the routine
11711      we are looking for.  This happens when the program is linked with
11712      the shared version of the GNAT runtime, and the program has not been
11713      started yet.  Inform the user of these two possible causes if
11714      applicable.  */
11715
11716   if (ada_update_initial_language (language_unknown) != language_ada)
11717     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
11718
11719   /* If the symbol does not exist, then check that the program is
11720      already started, to make sure that shared libraries have been
11721      loaded.  If it is not started, this may mean that the symbol is
11722      in a shared library.  */
11723
11724   if (inferior_ptid.pid () == 0)
11725     error (_("Unable to insert catchpoint. Try to start the program first."));
11726
11727   /* At this point, we know that we are debugging an Ada program and
11728      that the inferior has been started, but we still are not able to
11729      find the run-time symbols.  That can mean that we are in
11730      configurable run time mode, or that a-except as been optimized
11731      out by the linker...  In any case, at this point it is not worth
11732      supporting this feature.  */
11733
11734   error (_("Cannot insert Ada exception catchpoints in this configuration."));
11735 }
11736
11737 /* True iff FRAME is very likely to be that of a function that is
11738    part of the runtime system.  This is all very heuristic, but is
11739    intended to be used as advice as to what frames are uninteresting
11740    to most users.  */
11741
11742 static int
11743 is_known_support_routine (struct frame_info *frame)
11744 {
11745   enum language func_lang;
11746   int i;
11747   const char *fullname;
11748
11749   /* If this code does not have any debugging information (no symtab),
11750      This cannot be any user code.  */
11751
11752   symtab_and_line sal = find_frame_sal (frame);
11753   if (sal.symtab == NULL)
11754     return 1;
11755
11756   /* If there is a symtab, but the associated source file cannot be
11757      located, then assume this is not user code:  Selecting a frame
11758      for which we cannot display the code would not be very helpful
11759      for the user.  This should also take care of case such as VxWorks
11760      where the kernel has some debugging info provided for a few units.  */
11761
11762   fullname = symtab_to_fullname (sal.symtab);
11763   if (access (fullname, R_OK) != 0)
11764     return 1;
11765
11766   /* Check the unit filename against the Ada runtime file naming.
11767      We also check the name of the objfile against the name of some
11768      known system libraries that sometimes come with debugging info
11769      too.  */
11770
11771   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11772     {
11773       re_comp (known_runtime_file_name_patterns[i]);
11774       if (re_exec (lbasename (sal.symtab->filename)))
11775         return 1;
11776       if (sal.symtab->objfile () != NULL
11777           && re_exec (objfile_name (sal.symtab->objfile ())))
11778         return 1;
11779     }
11780
11781   /* Check whether the function is a GNAT-generated entity.  */
11782
11783   gdb::unique_xmalloc_ptr<char> func_name
11784     = find_frame_funname (frame, &func_lang, NULL);
11785   if (func_name == NULL)
11786     return 1;
11787
11788   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11789     {
11790       re_comp (known_auxiliary_function_name_patterns[i]);
11791       if (re_exec (func_name.get ()))
11792         return 1;
11793     }
11794
11795   return 0;
11796 }
11797
11798 /* Find the first frame that contains debugging information and that is not
11799    part of the Ada run-time, starting from FI and moving upward.  */
11800
11801 void
11802 ada_find_printable_frame (struct frame_info *fi)
11803 {
11804   for (; fi != NULL; fi = get_prev_frame (fi))
11805     {
11806       if (!is_known_support_routine (fi))
11807         {
11808           select_frame (fi);
11809           break;
11810         }
11811     }
11812
11813 }
11814
11815 /* Assuming that the inferior just triggered an unhandled exception
11816    catchpoint, return the address in inferior memory where the name
11817    of the exception is stored.
11818    
11819    Return zero if the address could not be computed.  */
11820
11821 static CORE_ADDR
11822 ada_unhandled_exception_name_addr (void)
11823 {
11824   return parse_and_eval_address ("e.full_name");
11825 }
11826
11827 /* Same as ada_unhandled_exception_name_addr, except that this function
11828    should be used when the inferior uses an older version of the runtime,
11829    where the exception name needs to be extracted from a specific frame
11830    several frames up in the callstack.  */
11831
11832 static CORE_ADDR
11833 ada_unhandled_exception_name_addr_from_raise (void)
11834 {
11835   int frame_level;
11836   struct frame_info *fi;
11837   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11838
11839   /* To determine the name of this exception, we need to select
11840      the frame corresponding to RAISE_SYM_NAME.  This frame is
11841      at least 3 levels up, so we simply skip the first 3 frames
11842      without checking the name of their associated function.  */
11843   fi = get_current_frame ();
11844   for (frame_level = 0; frame_level < 3; frame_level += 1)
11845     if (fi != NULL)
11846       fi = get_prev_frame (fi); 
11847
11848   while (fi != NULL)
11849     {
11850       enum language func_lang;
11851
11852       gdb::unique_xmalloc_ptr<char> func_name
11853         = find_frame_funname (fi, &func_lang, NULL);
11854       if (func_name != NULL)
11855         {
11856           if (strcmp (func_name.get (),
11857                       data->exception_info->catch_exception_sym) == 0)
11858             break; /* We found the frame we were looking for...  */
11859         }
11860       fi = get_prev_frame (fi);
11861     }
11862
11863   if (fi == NULL)
11864     return 0;
11865
11866   select_frame (fi);
11867   return parse_and_eval_address ("id.full_name");
11868 }
11869
11870 /* Assuming the inferior just triggered an Ada exception catchpoint
11871    (of any type), return the address in inferior memory where the name
11872    of the exception is stored, if applicable.
11873
11874    Assumes the selected frame is the current frame.
11875
11876    Return zero if the address could not be computed, or if not relevant.  */
11877
11878 static CORE_ADDR
11879 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
11880                            struct breakpoint *b)
11881 {
11882   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11883
11884   switch (ex)
11885     {
11886       case ada_catch_exception:
11887         return (parse_and_eval_address ("e.full_name"));
11888         break;
11889
11890       case ada_catch_exception_unhandled:
11891         return data->exception_info->unhandled_exception_name_addr ();
11892         break;
11893
11894       case ada_catch_handlers:
11895         return 0;  /* The runtimes does not provide access to the exception
11896                       name.  */
11897         break;
11898
11899       case ada_catch_assert:
11900         return 0;  /* Exception name is not relevant in this case.  */
11901         break;
11902
11903       default:
11904         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11905         break;
11906     }
11907
11908   return 0; /* Should never be reached.  */
11909 }
11910
11911 /* Assuming the inferior is stopped at an exception catchpoint,
11912    return the message which was associated to the exception, if
11913    available.  Return NULL if the message could not be retrieved.
11914
11915    Note: The exception message can be associated to an exception
11916    either through the use of the Raise_Exception function, or
11917    more simply (Ada 2005 and later), via:
11918
11919        raise Exception_Name with "exception message";
11920
11921    */
11922
11923 static gdb::unique_xmalloc_ptr<char>
11924 ada_exception_message_1 (void)
11925 {
11926   struct value *e_msg_val;
11927   int e_msg_len;
11928
11929   /* For runtimes that support this feature, the exception message
11930      is passed as an unbounded string argument called "message".  */
11931   e_msg_val = parse_and_eval ("message");
11932   if (e_msg_val == NULL)
11933     return NULL; /* Exception message not supported.  */
11934
11935   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
11936   gdb_assert (e_msg_val != NULL);
11937   e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
11938
11939   /* If the message string is empty, then treat it as if there was
11940      no exception message.  */
11941   if (e_msg_len <= 0)
11942     return NULL;
11943
11944   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
11945   read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
11946                e_msg_len);
11947   e_msg.get ()[e_msg_len] = '\0';
11948
11949   return e_msg;
11950 }
11951
11952 /* Same as ada_exception_message_1, except that all exceptions are
11953    contained here (returning NULL instead).  */
11954
11955 static gdb::unique_xmalloc_ptr<char>
11956 ada_exception_message (void)
11957 {
11958   gdb::unique_xmalloc_ptr<char> e_msg;
11959
11960   try
11961     {
11962       e_msg = ada_exception_message_1 ();
11963     }
11964   catch (const gdb_exception_error &e)
11965     {
11966       e_msg.reset (nullptr);
11967     }
11968
11969   return e_msg;
11970 }
11971
11972 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11973    any error that ada_exception_name_addr_1 might cause to be thrown.
11974    When an error is intercepted, a warning with the error message is printed,
11975    and zero is returned.  */
11976
11977 static CORE_ADDR
11978 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
11979                          struct breakpoint *b)
11980 {
11981   CORE_ADDR result = 0;
11982
11983   try
11984     {
11985       result = ada_exception_name_addr_1 (ex, b);
11986     }
11987
11988   catch (const gdb_exception_error &e)
11989     {
11990       warning (_("failed to get exception name: %s"), e.what ());
11991       return 0;
11992     }
11993
11994   return result;
11995 }
11996
11997 static std::string ada_exception_catchpoint_cond_string
11998   (const char *excep_string,
11999    enum ada_exception_catchpoint_kind ex);
12000
12001 /* Ada catchpoints.
12002
12003    In the case of catchpoints on Ada exceptions, the catchpoint will
12004    stop the target on every exception the program throws.  When a user
12005    specifies the name of a specific exception, we translate this
12006    request into a condition expression (in text form), and then parse
12007    it into an expression stored in each of the catchpoint's locations.
12008    We then use this condition to check whether the exception that was
12009    raised is the one the user is interested in.  If not, then the
12010    target is resumed again.  We store the name of the requested
12011    exception, in order to be able to re-set the condition expression
12012    when symbols change.  */
12013
12014 /* An instance of this type is used to represent an Ada catchpoint
12015    breakpoint location.  */
12016
12017 class ada_catchpoint_location : public bp_location
12018 {
12019 public:
12020   ada_catchpoint_location (breakpoint *owner)
12021     : bp_location (owner, bp_loc_software_breakpoint)
12022   {}
12023
12024   /* The condition that checks whether the exception that was raised
12025      is the specific exception the user specified on catchpoint
12026      creation.  */
12027   expression_up excep_cond_expr;
12028 };
12029
12030 /* An instance of this type is used to represent an Ada catchpoint.  */
12031
12032 struct ada_catchpoint : public breakpoint
12033 {
12034   explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind)
12035     : m_kind (kind)
12036   {
12037   }
12038
12039   /* The name of the specific exception the user specified.  */
12040   std::string excep_string;
12041
12042   /* What kind of catchpoint this is.  */
12043   enum ada_exception_catchpoint_kind m_kind;
12044 };
12045
12046 /* Parse the exception condition string in the context of each of the
12047    catchpoint's locations, and store them for later evaluation.  */
12048
12049 static void
12050 create_excep_cond_exprs (struct ada_catchpoint *c,
12051                          enum ada_exception_catchpoint_kind ex)
12052 {
12053   /* Nothing to do if there's no specific exception to catch.  */
12054   if (c->excep_string.empty ())
12055     return;
12056
12057   /* Same if there are no locations... */
12058   if (c->loc == NULL)
12059     return;
12060
12061   /* Compute the condition expression in text form, from the specific
12062      expection we want to catch.  */
12063   std::string cond_string
12064     = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
12065
12066   /* Iterate over all the catchpoint's locations, and parse an
12067      expression for each.  */
12068   for (bp_location *bl : c->locations ())
12069     {
12070       struct ada_catchpoint_location *ada_loc
12071         = (struct ada_catchpoint_location *) bl;
12072       expression_up exp;
12073
12074       if (!bl->shlib_disabled)
12075         {
12076           const char *s;
12077
12078           s = cond_string.c_str ();
12079           try
12080             {
12081               exp = parse_exp_1 (&s, bl->address,
12082                                  block_for_pc (bl->address),
12083                                  0);
12084             }
12085           catch (const gdb_exception_error &e)
12086             {
12087               warning (_("failed to reevaluate internal exception condition "
12088                          "for catchpoint %d: %s"),
12089                        c->number, e.what ());
12090             }
12091         }
12092
12093       ada_loc->excep_cond_expr = std::move (exp);
12094     }
12095 }
12096
12097 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12098    structure for all exception catchpoint kinds.  */
12099
12100 static struct bp_location *
12101 allocate_location_exception (struct breakpoint *self)
12102 {
12103   return new ada_catchpoint_location (self);
12104 }
12105
12106 /* Implement the RE_SET method in the breakpoint_ops structure for all
12107    exception catchpoint kinds.  */
12108
12109 static void
12110 re_set_exception (struct breakpoint *b)
12111 {
12112   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12113
12114   /* Call the base class's method.  This updates the catchpoint's
12115      locations.  */
12116   bkpt_breakpoint_ops.re_set (b);
12117
12118   /* Reparse the exception conditional expressions.  One for each
12119      location.  */
12120   create_excep_cond_exprs (c, c->m_kind);
12121 }
12122
12123 /* Returns true if we should stop for this breakpoint hit.  If the
12124    user specified a specific exception, we only want to cause a stop
12125    if the program thrown that exception.  */
12126
12127 static bool
12128 should_stop_exception (const struct bp_location *bl)
12129 {
12130   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12131   const struct ada_catchpoint_location *ada_loc
12132     = (const struct ada_catchpoint_location *) bl;
12133   bool stop;
12134
12135   struct internalvar *var = lookup_internalvar ("_ada_exception");
12136   if (c->m_kind == ada_catch_assert)
12137     clear_internalvar (var);
12138   else
12139     {
12140       try
12141         {
12142           const char *expr;
12143
12144           if (c->m_kind == ada_catch_handlers)
12145             expr = ("GNAT_GCC_exception_Access(gcc_exception)"
12146                     ".all.occurrence.id");
12147           else
12148             expr = "e";
12149
12150           struct value *exc = parse_and_eval (expr);
12151           set_internalvar (var, exc);
12152         }
12153       catch (const gdb_exception_error &ex)
12154         {
12155           clear_internalvar (var);
12156         }
12157     }
12158
12159   /* With no specific exception, should always stop.  */
12160   if (c->excep_string.empty ())
12161     return true;
12162
12163   if (ada_loc->excep_cond_expr == NULL)
12164     {
12165       /* We will have a NULL expression if back when we were creating
12166          the expressions, this location's had failed to parse.  */
12167       return true;
12168     }
12169
12170   stop = true;
12171   try
12172     {
12173       struct value *mark;
12174
12175       mark = value_mark ();
12176       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12177       value_free_to_mark (mark);
12178     }
12179   catch (const gdb_exception &ex)
12180     {
12181       exception_fprintf (gdb_stderr, ex,
12182                          _("Error in testing exception condition:\n"));
12183     }
12184
12185   return stop;
12186 }
12187
12188 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12189    for all exception catchpoint kinds.  */
12190
12191 static void
12192 check_status_exception (bpstat *bs)
12193 {
12194   bs->stop = should_stop_exception (bs->bp_location_at.get ());
12195 }
12196
12197 /* Implement the PRINT_IT method in the breakpoint_ops structure
12198    for all exception catchpoint kinds.  */
12199
12200 static enum print_stop_action
12201 print_it_exception (bpstat *bs)
12202 {
12203   struct ui_out *uiout = current_uiout;
12204   struct breakpoint *b = bs->breakpoint_at;
12205
12206   annotate_catchpoint (b->number);
12207
12208   if (uiout->is_mi_like_p ())
12209     {
12210       uiout->field_string ("reason",
12211                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12212       uiout->field_string ("disp", bpdisp_text (b->disposition));
12213     }
12214
12215   uiout->text (b->disposition == disp_del
12216                ? "\nTemporary catchpoint " : "\nCatchpoint ");
12217   uiout->field_signed ("bkptno", b->number);
12218   uiout->text (", ");
12219
12220   /* ada_exception_name_addr relies on the selected frame being the
12221      current frame.  Need to do this here because this function may be
12222      called more than once when printing a stop, and below, we'll
12223      select the first frame past the Ada run-time (see
12224      ada_find_printable_frame).  */
12225   select_frame (get_current_frame ());
12226
12227   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12228   switch (c->m_kind)
12229     {
12230       case ada_catch_exception:
12231       case ada_catch_exception_unhandled:
12232       case ada_catch_handlers:
12233         {
12234           const CORE_ADDR addr = ada_exception_name_addr (c->m_kind, b);
12235           char exception_name[256];
12236
12237           if (addr != 0)
12238             {
12239               read_memory (addr, (gdb_byte *) exception_name,
12240                            sizeof (exception_name) - 1);
12241               exception_name [sizeof (exception_name) - 1] = '\0';
12242             }
12243           else
12244             {
12245               /* For some reason, we were unable to read the exception
12246                  name.  This could happen if the Runtime was compiled
12247                  without debugging info, for instance.  In that case,
12248                  just replace the exception name by the generic string
12249                  "exception" - it will read as "an exception" in the
12250                  notification we are about to print.  */
12251               memcpy (exception_name, "exception", sizeof ("exception"));
12252             }
12253           /* In the case of unhandled exception breakpoints, we print
12254              the exception name as "unhandled EXCEPTION_NAME", to make
12255              it clearer to the user which kind of catchpoint just got
12256              hit.  We used ui_out_text to make sure that this extra
12257              info does not pollute the exception name in the MI case.  */
12258           if (c->m_kind == ada_catch_exception_unhandled)
12259             uiout->text ("unhandled ");
12260           uiout->field_string ("exception-name", exception_name);
12261         }
12262         break;
12263       case ada_catch_assert:
12264         /* In this case, the name of the exception is not really
12265            important.  Just print "failed assertion" to make it clearer
12266            that his program just hit an assertion-failure catchpoint.
12267            We used ui_out_text because this info does not belong in
12268            the MI output.  */
12269         uiout->text ("failed assertion");
12270         break;
12271     }
12272
12273   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12274   if (exception_message != NULL)
12275     {
12276       uiout->text (" (");
12277       uiout->field_string ("exception-message", exception_message.get ());
12278       uiout->text (")");
12279     }
12280
12281   uiout->text (" at ");
12282   ada_find_printable_frame (get_current_frame ());
12283
12284   return PRINT_SRC_AND_LOC;
12285 }
12286
12287 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12288    for all exception catchpoint kinds.  */
12289
12290 static void
12291 print_one_exception (struct breakpoint *b, struct bp_location **last_loc)
12292
12293   struct ui_out *uiout = current_uiout;
12294   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12295   struct value_print_options opts;
12296
12297   get_user_print_options (&opts);
12298
12299   if (opts.addressprint)
12300     uiout->field_skip ("addr");
12301
12302   annotate_field (5);
12303   switch (c->m_kind)
12304     {
12305       case ada_catch_exception:
12306         if (!c->excep_string.empty ())
12307           {
12308             std::string msg = string_printf (_("`%s' Ada exception"),
12309                                              c->excep_string.c_str ());
12310
12311             uiout->field_string ("what", msg);
12312           }
12313         else
12314           uiout->field_string ("what", "all Ada exceptions");
12315         
12316         break;
12317
12318       case ada_catch_exception_unhandled:
12319         uiout->field_string ("what", "unhandled Ada exceptions");
12320         break;
12321       
12322       case ada_catch_handlers:
12323         if (!c->excep_string.empty ())
12324           {
12325             uiout->field_fmt ("what",
12326                               _("`%s' Ada exception handlers"),
12327                               c->excep_string.c_str ());
12328           }
12329         else
12330           uiout->field_string ("what", "all Ada exceptions handlers");
12331         break;
12332
12333       case ada_catch_assert:
12334         uiout->field_string ("what", "failed Ada assertions");
12335         break;
12336
12337       default:
12338         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12339         break;
12340     }
12341 }
12342
12343 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12344    for all exception catchpoint kinds.  */
12345
12346 static void
12347 print_mention_exception (struct breakpoint *b)
12348 {
12349   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12350   struct ui_out *uiout = current_uiout;
12351
12352   uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
12353                                                  : _("Catchpoint "));
12354   uiout->field_signed ("bkptno", b->number);
12355   uiout->text (": ");
12356
12357   switch (c->m_kind)
12358     {
12359       case ada_catch_exception:
12360         if (!c->excep_string.empty ())
12361           {
12362             std::string info = string_printf (_("`%s' Ada exception"),
12363                                               c->excep_string.c_str ());
12364             uiout->text (info);
12365           }
12366         else
12367           uiout->text (_("all Ada exceptions"));
12368         break;
12369
12370       case ada_catch_exception_unhandled:
12371         uiout->text (_("unhandled Ada exceptions"));
12372         break;
12373
12374       case ada_catch_handlers:
12375         if (!c->excep_string.empty ())
12376           {
12377             std::string info
12378               = string_printf (_("`%s' Ada exception handlers"),
12379                                c->excep_string.c_str ());
12380             uiout->text (info);
12381           }
12382         else
12383           uiout->text (_("all Ada exceptions handlers"));
12384         break;
12385
12386       case ada_catch_assert:
12387         uiout->text (_("failed Ada assertions"));
12388         break;
12389
12390       default:
12391         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12392         break;
12393     }
12394 }
12395
12396 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12397    for all exception catchpoint kinds.  */
12398
12399 static void
12400 print_recreate_exception (struct breakpoint *b, struct ui_file *fp)
12401 {
12402   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12403
12404   switch (c->m_kind)
12405     {
12406       case ada_catch_exception:
12407         fprintf_filtered (fp, "catch exception");
12408         if (!c->excep_string.empty ())
12409           fprintf_filtered (fp, " %s", c->excep_string.c_str ());
12410         break;
12411
12412       case ada_catch_exception_unhandled:
12413         fprintf_filtered (fp, "catch exception unhandled");
12414         break;
12415
12416       case ada_catch_handlers:
12417         fprintf_filtered (fp, "catch handlers");
12418         break;
12419
12420       case ada_catch_assert:
12421         fprintf_filtered (fp, "catch assert");
12422         break;
12423
12424       default:
12425         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12426     }
12427   print_recreate_thread (b, fp);
12428 }
12429
12430 /* Virtual table for breakpoint type.  */
12431 static struct breakpoint_ops catch_exception_breakpoint_ops;
12432
12433 /* See ada-lang.h.  */
12434
12435 bool
12436 is_ada_exception_catchpoint (breakpoint *bp)
12437 {
12438   return bp->ops == &catch_exception_breakpoint_ops;
12439 }
12440
12441 /* Split the arguments specified in a "catch exception" command.  
12442    Set EX to the appropriate catchpoint type.
12443    Set EXCEP_STRING to the name of the specific exception if
12444    specified by the user.
12445    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12446    "catch handlers" command.  False otherwise.
12447    If a condition is found at the end of the arguments, the condition
12448    expression is stored in COND_STRING (memory must be deallocated
12449    after use).  Otherwise COND_STRING is set to NULL.  */
12450
12451 static void
12452 catch_ada_exception_command_split (const char *args,
12453                                    bool is_catch_handlers_cmd,
12454                                    enum ada_exception_catchpoint_kind *ex,
12455                                    std::string *excep_string,
12456                                    std::string *cond_string)
12457 {
12458   std::string exception_name;
12459
12460   exception_name = extract_arg (&args);
12461   if (exception_name == "if")
12462     {
12463       /* This is not an exception name; this is the start of a condition
12464          expression for a catchpoint on all exceptions.  So, "un-get"
12465          this token, and set exception_name to NULL.  */
12466       exception_name.clear ();
12467       args -= 2;
12468     }
12469
12470   /* Check to see if we have a condition.  */
12471
12472   args = skip_spaces (args);
12473   if (startswith (args, "if")
12474       && (isspace (args[2]) || args[2] == '\0'))
12475     {
12476       args += 2;
12477       args = skip_spaces (args);
12478
12479       if (args[0] == '\0')
12480         error (_("Condition missing after `if' keyword"));
12481       *cond_string = args;
12482
12483       args += strlen (args);
12484     }
12485
12486   /* Check that we do not have any more arguments.  Anything else
12487      is unexpected.  */
12488
12489   if (args[0] != '\0')
12490     error (_("Junk at end of expression"));
12491
12492   if (is_catch_handlers_cmd)
12493     {
12494       /* Catch handling of exceptions.  */
12495       *ex = ada_catch_handlers;
12496       *excep_string = exception_name;
12497     }
12498   else if (exception_name.empty ())
12499     {
12500       /* Catch all exceptions.  */
12501       *ex = ada_catch_exception;
12502       excep_string->clear ();
12503     }
12504   else if (exception_name == "unhandled")
12505     {
12506       /* Catch unhandled exceptions.  */
12507       *ex = ada_catch_exception_unhandled;
12508       excep_string->clear ();
12509     }
12510   else
12511     {
12512       /* Catch a specific exception.  */
12513       *ex = ada_catch_exception;
12514       *excep_string = exception_name;
12515     }
12516 }
12517
12518 /* Return the name of the symbol on which we should break in order to
12519    implement a catchpoint of the EX kind.  */
12520
12521 static const char *
12522 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12523 {
12524   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12525
12526   gdb_assert (data->exception_info != NULL);
12527
12528   switch (ex)
12529     {
12530       case ada_catch_exception:
12531         return (data->exception_info->catch_exception_sym);
12532         break;
12533       case ada_catch_exception_unhandled:
12534         return (data->exception_info->catch_exception_unhandled_sym);
12535         break;
12536       case ada_catch_assert:
12537         return (data->exception_info->catch_assert_sym);
12538         break;
12539       case ada_catch_handlers:
12540         return (data->exception_info->catch_handlers_sym);
12541         break;
12542       default:
12543         internal_error (__FILE__, __LINE__,
12544                         _("unexpected catchpoint kind (%d)"), ex);
12545     }
12546 }
12547
12548 /* Return the condition that will be used to match the current exception
12549    being raised with the exception that the user wants to catch.  This
12550    assumes that this condition is used when the inferior just triggered
12551    an exception catchpoint.
12552    EX: the type of catchpoints used for catching Ada exceptions.  */
12553
12554 static std::string
12555 ada_exception_catchpoint_cond_string (const char *excep_string,
12556                                       enum ada_exception_catchpoint_kind ex)
12557 {
12558   bool is_standard_exc = false;
12559   std::string result;
12560
12561   if (ex == ada_catch_handlers)
12562     {
12563       /* For exception handlers catchpoints, the condition string does
12564          not use the same parameter as for the other exceptions.  */
12565       result = ("long_integer (GNAT_GCC_exception_Access"
12566                 "(gcc_exception).all.occurrence.id)");
12567     }
12568   else
12569     result = "long_integer (e)";
12570
12571   /* The standard exceptions are a special case.  They are defined in
12572      runtime units that have been compiled without debugging info; if
12573      EXCEP_STRING is the not-fully-qualified name of a standard
12574      exception (e.g. "constraint_error") then, during the evaluation
12575      of the condition expression, the symbol lookup on this name would
12576      *not* return this standard exception.  The catchpoint condition
12577      may then be set only on user-defined exceptions which have the
12578      same not-fully-qualified name (e.g. my_package.constraint_error).
12579
12580      To avoid this unexcepted behavior, these standard exceptions are
12581      systematically prefixed by "standard".  This means that "catch
12582      exception constraint_error" is rewritten into "catch exception
12583      standard.constraint_error".
12584
12585      If an exception named constraint_error is defined in another package of
12586      the inferior program, then the only way to specify this exception as a
12587      breakpoint condition is to use its fully-qualified named:
12588      e.g. my_package.constraint_error.  */
12589
12590   for (const char *name : standard_exc)
12591     {
12592       if (strcmp (name, excep_string) == 0)
12593         {
12594           is_standard_exc = true;
12595           break;
12596         }
12597     }
12598
12599   result += " = ";
12600
12601   if (is_standard_exc)
12602     string_appendf (result, "long_integer (&standard.%s)", excep_string);
12603   else
12604     string_appendf (result, "long_integer (&%s)", excep_string);
12605
12606   return result;
12607 }
12608
12609 /* Return the symtab_and_line that should be used to insert an exception
12610    catchpoint of the TYPE kind.
12611
12612    ADDR_STRING returns the name of the function where the real
12613    breakpoint that implements the catchpoints is set, depending on the
12614    type of catchpoint we need to create.  */
12615
12616 static struct symtab_and_line
12617 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12618                    std::string *addr_string, const struct breakpoint_ops **ops)
12619 {
12620   const char *sym_name;
12621   struct symbol *sym;
12622
12623   /* First, find out which exception support info to use.  */
12624   ada_exception_support_info_sniffer ();
12625
12626   /* Then lookup the function on which we will break in order to catch
12627      the Ada exceptions requested by the user.  */
12628   sym_name = ada_exception_sym_name (ex);
12629   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12630
12631   if (sym == NULL)
12632     error (_("Catchpoint symbol not found: %s"), sym_name);
12633
12634   if (sym->aclass () != LOC_BLOCK)
12635     error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12636
12637   /* Set ADDR_STRING.  */
12638   *addr_string = sym_name;
12639
12640   /* Set OPS.  */
12641   *ops = &catch_exception_breakpoint_ops;
12642
12643   return find_function_start_sal (sym, 1);
12644 }
12645
12646 /* Create an Ada exception catchpoint.
12647
12648    EX_KIND is the kind of exception catchpoint to be created.
12649
12650    If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12651    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
12652    of the exception to which this catchpoint applies.
12653
12654    COND_STRING, if not empty, is the catchpoint condition.
12655
12656    TEMPFLAG, if nonzero, means that the underlying breakpoint
12657    should be temporary.
12658
12659    FROM_TTY is the usual argument passed to all commands implementations.  */
12660
12661 void
12662 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12663                                  enum ada_exception_catchpoint_kind ex_kind,
12664                                  const std::string &excep_string,
12665                                  const std::string &cond_string,
12666                                  int tempflag,
12667                                  int disabled,
12668                                  int from_tty)
12669 {
12670   std::string addr_string;
12671   const struct breakpoint_ops *ops = NULL;
12672   struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
12673
12674   std::unique_ptr<ada_catchpoint> c (new ada_catchpoint (ex_kind));
12675   init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
12676                                  ops, tempflag, disabled, from_tty);
12677   c->excep_string = excep_string;
12678   create_excep_cond_exprs (c.get (), ex_kind);
12679   if (!cond_string.empty ())
12680     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12681   install_breakpoint (0, std::move (c), 1);
12682 }
12683
12684 /* Implement the "catch exception" command.  */
12685
12686 static void
12687 catch_ada_exception_command (const char *arg_entry, int from_tty,
12688                              struct cmd_list_element *command)
12689 {
12690   const char *arg = arg_entry;
12691   struct gdbarch *gdbarch = get_current_arch ();
12692   int tempflag;
12693   enum ada_exception_catchpoint_kind ex_kind;
12694   std::string excep_string;
12695   std::string cond_string;
12696
12697   tempflag = command->context () == CATCH_TEMPORARY;
12698
12699   if (!arg)
12700     arg = "";
12701   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12702                                      &cond_string);
12703   create_ada_exception_catchpoint (gdbarch, ex_kind,
12704                                    excep_string, cond_string,
12705                                    tempflag, 1 /* enabled */,
12706                                    from_tty);
12707 }
12708
12709 /* Implement the "catch handlers" command.  */
12710
12711 static void
12712 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12713                             struct cmd_list_element *command)
12714 {
12715   const char *arg = arg_entry;
12716   struct gdbarch *gdbarch = get_current_arch ();
12717   int tempflag;
12718   enum ada_exception_catchpoint_kind ex_kind;
12719   std::string excep_string;
12720   std::string cond_string;
12721
12722   tempflag = command->context () == CATCH_TEMPORARY;
12723
12724   if (!arg)
12725     arg = "";
12726   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12727                                      &cond_string);
12728   create_ada_exception_catchpoint (gdbarch, ex_kind,
12729                                    excep_string, cond_string,
12730                                    tempflag, 1 /* enabled */,
12731                                    from_tty);
12732 }
12733
12734 /* Completion function for the Ada "catch" commands.  */
12735
12736 static void
12737 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12738                      const char *text, const char *word)
12739 {
12740   std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12741
12742   for (const ada_exc_info &info : exceptions)
12743     {
12744       if (startswith (info.name, word))
12745         tracker.add_completion (make_unique_xstrdup (info.name));
12746     }
12747 }
12748
12749 /* Split the arguments specified in a "catch assert" command.
12750
12751    ARGS contains the command's arguments (or the empty string if
12752    no arguments were passed).
12753
12754    If ARGS contains a condition, set COND_STRING to that condition
12755    (the memory needs to be deallocated after use).  */
12756
12757 static void
12758 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12759 {
12760   args = skip_spaces (args);
12761
12762   /* Check whether a condition was provided.  */
12763   if (startswith (args, "if")
12764       && (isspace (args[2]) || args[2] == '\0'))
12765     {
12766       args += 2;
12767       args = skip_spaces (args);
12768       if (args[0] == '\0')
12769         error (_("condition missing after `if' keyword"));
12770       cond_string.assign (args);
12771     }
12772
12773   /* Otherwise, there should be no other argument at the end of
12774      the command.  */
12775   else if (args[0] != '\0')
12776     error (_("Junk at end of arguments."));
12777 }
12778
12779 /* Implement the "catch assert" command.  */
12780
12781 static void
12782 catch_assert_command (const char *arg_entry, int from_tty,
12783                       struct cmd_list_element *command)
12784 {
12785   const char *arg = arg_entry;
12786   struct gdbarch *gdbarch = get_current_arch ();
12787   int tempflag;
12788   std::string cond_string;
12789
12790   tempflag = command->context () == CATCH_TEMPORARY;
12791
12792   if (!arg)
12793     arg = "";
12794   catch_ada_assert_command_split (arg, cond_string);
12795   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12796                                    "", cond_string,
12797                                    tempflag, 1 /* enabled */,
12798                                    from_tty);
12799 }
12800
12801 /* Return non-zero if the symbol SYM is an Ada exception object.  */
12802
12803 static int
12804 ada_is_exception_sym (struct symbol *sym)
12805 {
12806   const char *type_name = sym->type ()->name ();
12807
12808   return (sym->aclass () != LOC_TYPEDEF
12809           && sym->aclass () != LOC_BLOCK
12810           && sym->aclass () != LOC_CONST
12811           && sym->aclass () != LOC_UNRESOLVED
12812           && type_name != NULL && strcmp (type_name, "exception") == 0);
12813 }
12814
12815 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12816    Ada exception object.  This matches all exceptions except the ones
12817    defined by the Ada language.  */
12818
12819 static int
12820 ada_is_non_standard_exception_sym (struct symbol *sym)
12821 {
12822   if (!ada_is_exception_sym (sym))
12823     return 0;
12824
12825   for (const char *name : standard_exc)
12826     if (strcmp (sym->linkage_name (), name) == 0)
12827       return 0;  /* A standard exception.  */
12828
12829   /* Numeric_Error is also a standard exception, so exclude it.
12830      See the STANDARD_EXC description for more details as to why
12831      this exception is not listed in that array.  */
12832   if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12833     return 0;
12834
12835   return 1;
12836 }
12837
12838 /* A helper function for std::sort, comparing two struct ada_exc_info
12839    objects.
12840
12841    The comparison is determined first by exception name, and then
12842    by exception address.  */
12843
12844 bool
12845 ada_exc_info::operator< (const ada_exc_info &other) const
12846 {
12847   int result;
12848
12849   result = strcmp (name, other.name);
12850   if (result < 0)
12851     return true;
12852   if (result == 0 && addr < other.addr)
12853     return true;
12854   return false;
12855 }
12856
12857 bool
12858 ada_exc_info::operator== (const ada_exc_info &other) const
12859 {
12860   return addr == other.addr && strcmp (name, other.name) == 0;
12861 }
12862
12863 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12864    routine, but keeping the first SKIP elements untouched.
12865
12866    All duplicates are also removed.  */
12867
12868 static void
12869 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
12870                                       int skip)
12871 {
12872   std::sort (exceptions->begin () + skip, exceptions->end ());
12873   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
12874                      exceptions->end ());
12875 }
12876
12877 /* Add all exceptions defined by the Ada standard whose name match
12878    a regular expression.
12879
12880    If PREG is not NULL, then this regexp_t object is used to
12881    perform the symbol name matching.  Otherwise, no name-based
12882    filtering is performed.
12883
12884    EXCEPTIONS is a vector of exceptions to which matching exceptions
12885    gets pushed.  */
12886
12887 static void
12888 ada_add_standard_exceptions (compiled_regex *preg,
12889                              std::vector<ada_exc_info> *exceptions)
12890 {
12891   for (const char *name : standard_exc)
12892     {
12893       if (preg == NULL || preg->exec (name, 0, NULL, 0) == 0)
12894         {
12895           struct bound_minimal_symbol msymbol
12896             = ada_lookup_simple_minsym (name);
12897
12898           if (msymbol.minsym != NULL)
12899             {
12900               struct ada_exc_info info
12901                 = {name, BMSYMBOL_VALUE_ADDRESS (msymbol)};
12902
12903               exceptions->push_back (info);
12904             }
12905         }
12906     }
12907 }
12908
12909 /* Add all Ada exceptions defined locally and accessible from the given
12910    FRAME.
12911
12912    If PREG is not NULL, then this regexp_t object is used to
12913    perform the symbol name matching.  Otherwise, no name-based
12914    filtering is performed.
12915
12916    EXCEPTIONS is a vector of exceptions to which matching exceptions
12917    gets pushed.  */
12918
12919 static void
12920 ada_add_exceptions_from_frame (compiled_regex *preg,
12921                                struct frame_info *frame,
12922                                std::vector<ada_exc_info> *exceptions)
12923 {
12924   const struct block *block = get_frame_block (frame, 0);
12925
12926   while (block != 0)
12927     {
12928       struct block_iterator iter;
12929       struct symbol *sym;
12930
12931       ALL_BLOCK_SYMBOLS (block, iter, sym)
12932         {
12933           switch (sym->aclass ())
12934             {
12935             case LOC_TYPEDEF:
12936             case LOC_BLOCK:
12937             case LOC_CONST:
12938               break;
12939             default:
12940               if (ada_is_exception_sym (sym))
12941                 {
12942                   struct ada_exc_info info = {sym->print_name (),
12943                                               SYMBOL_VALUE_ADDRESS (sym)};
12944
12945                   exceptions->push_back (info);
12946                 }
12947             }
12948         }
12949       if (BLOCK_FUNCTION (block) != NULL)
12950         break;
12951       block = BLOCK_SUPERBLOCK (block);
12952     }
12953 }
12954
12955 /* Return true if NAME matches PREG or if PREG is NULL.  */
12956
12957 static bool
12958 name_matches_regex (const char *name, compiled_regex *preg)
12959 {
12960   return (preg == NULL
12961           || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
12962 }
12963
12964 /* Add all exceptions defined globally whose name name match
12965    a regular expression, excluding standard exceptions.
12966
12967    The reason we exclude standard exceptions is that they need
12968    to be handled separately: Standard exceptions are defined inside
12969    a runtime unit which is normally not compiled with debugging info,
12970    and thus usually do not show up in our symbol search.  However,
12971    if the unit was in fact built with debugging info, we need to
12972    exclude them because they would duplicate the entry we found
12973    during the special loop that specifically searches for those
12974    standard exceptions.
12975
12976    If PREG is not NULL, then this regexp_t object is used to
12977    perform the symbol name matching.  Otherwise, no name-based
12978    filtering is performed.
12979
12980    EXCEPTIONS is a vector of exceptions to which matching exceptions
12981    gets pushed.  */
12982
12983 static void
12984 ada_add_global_exceptions (compiled_regex *preg,
12985                            std::vector<ada_exc_info> *exceptions)
12986 {
12987   /* In Ada, the symbol "search name" is a linkage name, whereas the
12988      regular expression used to do the matching refers to the natural
12989      name.  So match against the decoded name.  */
12990   expand_symtabs_matching (NULL,
12991                            lookup_name_info::match_any (),
12992                            [&] (const char *search_name)
12993                            {
12994                              std::string decoded = ada_decode (search_name);
12995                              return name_matches_regex (decoded.c_str (), preg);
12996                            },
12997                            NULL,
12998                            SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
12999                            VARIABLES_DOMAIN);
13000
13001   for (objfile *objfile : current_program_space->objfiles ())
13002     {
13003       for (compunit_symtab *s : objfile->compunits ())
13004         {
13005           const struct blockvector *bv = s->blockvector ();
13006           int i;
13007
13008           for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13009             {
13010               const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13011               struct block_iterator iter;
13012               struct symbol *sym;
13013
13014               ALL_BLOCK_SYMBOLS (b, iter, sym)
13015                 if (ada_is_non_standard_exception_sym (sym)
13016                     && name_matches_regex (sym->natural_name (), preg))
13017                   {
13018                     struct ada_exc_info info
13019                       = {sym->print_name (), SYMBOL_VALUE_ADDRESS (sym)};
13020
13021                     exceptions->push_back (info);
13022                   }
13023             }
13024         }
13025     }
13026 }
13027
13028 /* Implements ada_exceptions_list with the regular expression passed
13029    as a regex_t, rather than a string.
13030
13031    If not NULL, PREG is used to filter out exceptions whose names
13032    do not match.  Otherwise, all exceptions are listed.  */
13033
13034 static std::vector<ada_exc_info>
13035 ada_exceptions_list_1 (compiled_regex *preg)
13036 {
13037   std::vector<ada_exc_info> result;
13038   int prev_len;
13039
13040   /* First, list the known standard exceptions.  These exceptions
13041      need to be handled separately, as they are usually defined in
13042      runtime units that have been compiled without debugging info.  */
13043
13044   ada_add_standard_exceptions (preg, &result);
13045
13046   /* Next, find all exceptions whose scope is local and accessible
13047      from the currently selected frame.  */
13048
13049   if (has_stack_frames ())
13050     {
13051       prev_len = result.size ();
13052       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13053                                      &result);
13054       if (result.size () > prev_len)
13055         sort_remove_dups_ada_exceptions_list (&result, prev_len);
13056     }
13057
13058   /* Add all exceptions whose scope is global.  */
13059
13060   prev_len = result.size ();
13061   ada_add_global_exceptions (preg, &result);
13062   if (result.size () > prev_len)
13063     sort_remove_dups_ada_exceptions_list (&result, prev_len);
13064
13065   return result;
13066 }
13067
13068 /* Return a vector of ada_exc_info.
13069
13070    If REGEXP is NULL, all exceptions are included in the result.
13071    Otherwise, it should contain a valid regular expression,
13072    and only the exceptions whose names match that regular expression
13073    are included in the result.
13074
13075    The exceptions are sorted in the following order:
13076      - Standard exceptions (defined by the Ada language), in
13077        alphabetical order;
13078      - Exceptions only visible from the current frame, in
13079        alphabetical order;
13080      - Exceptions whose scope is global, in alphabetical order.  */
13081
13082 std::vector<ada_exc_info>
13083 ada_exceptions_list (const char *regexp)
13084 {
13085   if (regexp == NULL)
13086     return ada_exceptions_list_1 (NULL);
13087
13088   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13089   return ada_exceptions_list_1 (&reg);
13090 }
13091
13092 /* Implement the "info exceptions" command.  */
13093
13094 static void
13095 info_exceptions_command (const char *regexp, int from_tty)
13096 {
13097   struct gdbarch *gdbarch = get_current_arch ();
13098
13099   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13100
13101   if (regexp != NULL)
13102     printf_filtered
13103       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13104   else
13105     printf_filtered (_("All defined Ada exceptions:\n"));
13106
13107   for (const ada_exc_info &info : exceptions)
13108     printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13109 }
13110
13111 \f
13112                                 /* Language vector */
13113
13114 /* symbol_name_matcher_ftype adapter for wild_match.  */
13115
13116 static bool
13117 do_wild_match (const char *symbol_search_name,
13118                const lookup_name_info &lookup_name,
13119                completion_match_result *comp_match_res)
13120 {
13121   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
13122 }
13123
13124 /* symbol_name_matcher_ftype adapter for full_match.  */
13125
13126 static bool
13127 do_full_match (const char *symbol_search_name,
13128                const lookup_name_info &lookup_name,
13129                completion_match_result *comp_match_res)
13130 {
13131   const char *lname = lookup_name.ada ().lookup_name ().c_str ();
13132
13133   /* If both symbols start with "_ada_", just let the loop below
13134      handle the comparison.  However, if only the symbol name starts
13135      with "_ada_", skip the prefix and let the match proceed as
13136      usual.  */
13137   if (startswith (symbol_search_name, "_ada_")
13138       && !startswith (lname, "_ada"))
13139     symbol_search_name += 5;
13140
13141   int uscore_count = 0;
13142   while (*lname != '\0')
13143     {
13144       if (*symbol_search_name != *lname)
13145         {
13146           if (*symbol_search_name == 'B' && uscore_count == 2
13147               && symbol_search_name[1] == '_')
13148             {
13149               symbol_search_name += 2;
13150               while (isdigit (*symbol_search_name))
13151                 ++symbol_search_name;
13152               if (symbol_search_name[0] == '_'
13153                   && symbol_search_name[1] == '_')
13154                 {
13155                   symbol_search_name += 2;
13156                   continue;
13157                 }
13158             }
13159           return false;
13160         }
13161
13162       if (*symbol_search_name == '_')
13163         ++uscore_count;
13164       else
13165         uscore_count = 0;
13166
13167       ++symbol_search_name;
13168       ++lname;
13169     }
13170
13171   return is_name_suffix (symbol_search_name);
13172 }
13173
13174 /* symbol_name_matcher_ftype for exact (verbatim) matches.  */
13175
13176 static bool
13177 do_exact_match (const char *symbol_search_name,
13178                 const lookup_name_info &lookup_name,
13179                 completion_match_result *comp_match_res)
13180 {
13181   return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
13182 }
13183
13184 /* Build the Ada lookup name for LOOKUP_NAME.  */
13185
13186 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
13187 {
13188   gdb::string_view user_name = lookup_name.name ();
13189
13190   if (!user_name.empty () && user_name[0] == '<')
13191     {
13192       if (user_name.back () == '>')
13193         m_encoded_name
13194           = gdb::to_string (user_name.substr (1, user_name.size () - 2));
13195       else
13196         m_encoded_name
13197           = gdb::to_string (user_name.substr (1, user_name.size () - 1));
13198       m_encoded_p = true;
13199       m_verbatim_p = true;
13200       m_wild_match_p = false;
13201       m_standard_p = false;
13202     }
13203   else
13204     {
13205       m_verbatim_p = false;
13206
13207       m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
13208
13209       if (!m_encoded_p)
13210         {
13211           const char *folded = ada_fold_name (user_name);
13212           m_encoded_name = ada_encode_1 (folded, false);
13213           if (m_encoded_name.empty ())
13214             m_encoded_name = gdb::to_string (user_name);
13215         }
13216       else
13217         m_encoded_name = gdb::to_string (user_name);
13218
13219       /* Handle the 'package Standard' special case.  See description
13220          of m_standard_p.  */
13221       if (startswith (m_encoded_name.c_str (), "standard__"))
13222         {
13223           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
13224           m_standard_p = true;
13225         }
13226       else
13227         m_standard_p = false;
13228
13229       /* If the name contains a ".", then the user is entering a fully
13230          qualified entity name, and the match must not be done in wild
13231          mode.  Similarly, if the user wants to complete what looks
13232          like an encoded name, the match must not be done in wild
13233          mode.  Also, in the standard__ special case always do
13234          non-wild matching.  */
13235       m_wild_match_p
13236         = (lookup_name.match_type () != symbol_name_match_type::FULL
13237            && !m_encoded_p
13238            && !m_standard_p
13239            && user_name.find ('.') == std::string::npos);
13240     }
13241 }
13242
13243 /* symbol_name_matcher_ftype method for Ada.  This only handles
13244    completion mode.  */
13245
13246 static bool
13247 ada_symbol_name_matches (const char *symbol_search_name,
13248                          const lookup_name_info &lookup_name,
13249                          completion_match_result *comp_match_res)
13250 {
13251   return lookup_name.ada ().matches (symbol_search_name,
13252                                      lookup_name.match_type (),
13253                                      comp_match_res);
13254 }
13255
13256 /* A name matcher that matches the symbol name exactly, with
13257    strcmp.  */
13258
13259 static bool
13260 literal_symbol_name_matcher (const char *symbol_search_name,
13261                              const lookup_name_info &lookup_name,
13262                              completion_match_result *comp_match_res)
13263 {
13264   gdb::string_view name_view = lookup_name.name ();
13265
13266   if (lookup_name.completion_mode ()
13267       ? (strncmp (symbol_search_name, name_view.data (),
13268                   name_view.size ()) == 0)
13269       : symbol_search_name == name_view)
13270     {
13271       if (comp_match_res != NULL)
13272         comp_match_res->set_match (symbol_search_name);
13273       return true;
13274     }
13275   else
13276     return false;
13277 }
13278
13279 /* Implement the "get_symbol_name_matcher" language_defn method for
13280    Ada.  */
13281
13282 static symbol_name_matcher_ftype *
13283 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
13284 {
13285   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
13286     return literal_symbol_name_matcher;
13287
13288   if (lookup_name.completion_mode ())
13289     return ada_symbol_name_matches;
13290   else
13291     {
13292       if (lookup_name.ada ().wild_match_p ())
13293         return do_wild_match;
13294       else if (lookup_name.ada ().verbatim_p ())
13295         return do_exact_match;
13296       else
13297         return do_full_match;
13298     }
13299 }
13300
13301 /* Class representing the Ada language.  */
13302
13303 class ada_language : public language_defn
13304 {
13305 public:
13306   ada_language ()
13307     : language_defn (language_ada)
13308   { /* Nothing.  */ }
13309
13310   /* See language.h.  */
13311
13312   const char *name () const override
13313   { return "ada"; }
13314
13315   /* See language.h.  */
13316
13317   const char *natural_name () const override
13318   { return "Ada"; }
13319
13320   /* See language.h.  */
13321
13322   const std::vector<const char *> &filename_extensions () const override
13323   {
13324     static const std::vector<const char *> extensions
13325       = { ".adb", ".ads", ".a", ".ada", ".dg" };
13326     return extensions;
13327   }
13328
13329   /* Print an array element index using the Ada syntax.  */
13330
13331   void print_array_index (struct type *index_type,
13332                           LONGEST index,
13333                           struct ui_file *stream,
13334                           const value_print_options *options) const override
13335   {
13336     struct value *index_value = val_atr (index_type, index);
13337
13338     value_print (index_value, stream, options);
13339     fprintf_filtered (stream, " => ");
13340   }
13341
13342   /* Implement the "read_var_value" language_defn method for Ada.  */
13343
13344   struct value *read_var_value (struct symbol *var,
13345                                 const struct block *var_block,
13346                                 struct frame_info *frame) const override
13347   {
13348     /* The only case where default_read_var_value is not sufficient
13349        is when VAR is a renaming...  */
13350     if (frame != nullptr)
13351       {
13352         const struct block *frame_block = get_frame_block (frame, NULL);
13353         if (frame_block != nullptr && ada_is_renaming_symbol (var))
13354           return ada_read_renaming_var_value (var, frame_block);
13355       }
13356
13357     /* This is a typical case where we expect the default_read_var_value
13358        function to work.  */
13359     return language_defn::read_var_value (var, var_block, frame);
13360   }
13361
13362   /* See language.h.  */
13363   virtual bool symbol_printing_suppressed (struct symbol *symbol) const override
13364   {
13365     return symbol->artificial;
13366   }
13367
13368   /* See language.h.  */
13369   void language_arch_info (struct gdbarch *gdbarch,
13370                            struct language_arch_info *lai) const override
13371   {
13372     const struct builtin_type *builtin = builtin_type (gdbarch);
13373
13374     /* Helper function to allow shorter lines below.  */
13375     auto add = [&] (struct type *t)
13376     {
13377       lai->add_primitive_type (t);
13378     };
13379
13380     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13381                             0, "integer"));
13382     add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13383                             0, "long_integer"));
13384     add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13385                             0, "short_integer"));
13386     struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
13387                                                   1, "character");
13388     lai->set_string_char_type (char_type);
13389     add (char_type);
13390     add (arch_character_type (gdbarch, 16, 1, "wide_character"));
13391     add (arch_character_type (gdbarch, 32, 1, "wide_wide_character"));
13392     add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13393                           "float", gdbarch_float_format (gdbarch)));
13394     add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13395                           "long_float", gdbarch_double_format (gdbarch)));
13396     add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13397                             0, "long_long_integer"));
13398     add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13399                           "long_long_float",
13400                           gdbarch_long_double_format (gdbarch)));
13401     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13402                             0, "natural"));
13403     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13404                             0, "positive"));
13405     add (builtin->builtin_void);
13406
13407     struct type *system_addr_ptr
13408       = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13409                                         "void"));
13410     system_addr_ptr->set_name ("system__address");
13411     add (system_addr_ptr);
13412
13413     /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13414        type.  This is a signed integral type whose size is the same as
13415        the size of addresses.  */
13416     unsigned int addr_length = TYPE_LENGTH (system_addr_ptr);
13417     add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13418                             "storage_offset"));
13419
13420     lai->set_bool_type (builtin->builtin_bool);
13421   }
13422
13423   /* See language.h.  */
13424
13425   bool iterate_over_symbols
13426         (const struct block *block, const lookup_name_info &name,
13427          domain_enum domain,
13428          gdb::function_view<symbol_found_callback_ftype> callback) const override
13429   {
13430     std::vector<struct block_symbol> results
13431       = ada_lookup_symbol_list_worker (name, block, domain, 0);
13432     for (block_symbol &sym : results)
13433       {
13434         if (!callback (&sym))
13435           return false;
13436       }
13437
13438     return true;
13439   }
13440
13441   /* See language.h.  */
13442   bool sniff_from_mangled_name
13443        (const char *mangled,
13444         gdb::unique_xmalloc_ptr<char> *out) const override
13445   {
13446     std::string demangled = ada_decode (mangled);
13447
13448     *out = NULL;
13449
13450     if (demangled != mangled && demangled[0] != '<')
13451       {
13452         /* Set the gsymbol language to Ada, but still return 0.
13453            Two reasons for that:
13454
13455            1. For Ada, we prefer computing the symbol's decoded name
13456            on the fly rather than pre-compute it, in order to save
13457            memory (Ada projects are typically very large).
13458
13459            2. There are some areas in the definition of the GNAT
13460            encoding where, with a bit of bad luck, we might be able
13461            to decode a non-Ada symbol, generating an incorrect
13462            demangled name (Eg: names ending with "TB" for instance
13463            are identified as task bodies and so stripped from
13464            the decoded name returned).
13465
13466            Returning true, here, but not setting *DEMANGLED, helps us get
13467            a little bit of the best of both worlds.  Because we're last,
13468            we should not affect any of the other languages that were
13469            able to demangle the symbol before us; we get to correctly
13470            tag Ada symbols as such; and even if we incorrectly tagged a
13471            non-Ada symbol, which should be rare, any routing through the
13472            Ada language should be transparent (Ada tries to behave much
13473            like C/C++ with non-Ada symbols).  */
13474         return true;
13475       }
13476
13477     return false;
13478   }
13479
13480   /* See language.h.  */
13481
13482   gdb::unique_xmalloc_ptr<char> demangle_symbol (const char *mangled,
13483                                                  int options) const override
13484   {
13485     return make_unique_xstrdup (ada_decode (mangled).c_str ());
13486   }
13487
13488   /* See language.h.  */
13489
13490   void print_type (struct type *type, const char *varstring,
13491                    struct ui_file *stream, int show, int level,
13492                    const struct type_print_options *flags) const override
13493   {
13494     ada_print_type (type, varstring, stream, show, level, flags);
13495   }
13496
13497   /* See language.h.  */
13498
13499   const char *word_break_characters (void) const override
13500   {
13501     return ada_completer_word_break_characters;
13502   }
13503
13504   /* See language.h.  */
13505
13506   void collect_symbol_completion_matches (completion_tracker &tracker,
13507                                           complete_symbol_mode mode,
13508                                           symbol_name_match_type name_match_type,
13509                                           const char *text, const char *word,
13510                                           enum type_code code) const override
13511   {
13512     struct symbol *sym;
13513     const struct block *b, *surrounding_static_block = 0;
13514     struct block_iterator iter;
13515
13516     gdb_assert (code == TYPE_CODE_UNDEF);
13517
13518     lookup_name_info lookup_name (text, name_match_type, true);
13519
13520     /* First, look at the partial symtab symbols.  */
13521     expand_symtabs_matching (NULL,
13522                              lookup_name,
13523                              NULL,
13524                              NULL,
13525                              SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13526                              ALL_DOMAIN);
13527
13528     /* At this point scan through the misc symbol vectors and add each
13529        symbol you find to the list.  Eventually we want to ignore
13530        anything that isn't a text symbol (everything else will be
13531        handled by the psymtab code above).  */
13532
13533     for (objfile *objfile : current_program_space->objfiles ())
13534       {
13535         for (minimal_symbol *msymbol : objfile->msymbols ())
13536           {
13537             QUIT;
13538
13539             if (completion_skip_symbol (mode, msymbol))
13540               continue;
13541
13542             language symbol_language = msymbol->language ();
13543
13544             /* Ada minimal symbols won't have their language set to Ada.  If
13545                we let completion_list_add_name compare using the
13546                default/C-like matcher, then when completing e.g., symbols in a
13547                package named "pck", we'd match internal Ada symbols like
13548                "pckS", which are invalid in an Ada expression, unless you wrap
13549                them in '<' '>' to request a verbatim match.
13550
13551                Unfortunately, some Ada encoded names successfully demangle as
13552                C++ symbols (using an old mangling scheme), such as "name__2Xn"
13553                -> "Xn::name(void)" and thus some Ada minimal symbols end up
13554                with the wrong language set.  Paper over that issue here.  */
13555             if (symbol_language == language_auto
13556                 || symbol_language == language_cplus)
13557               symbol_language = language_ada;
13558
13559             completion_list_add_name (tracker,
13560                                       symbol_language,
13561                                       msymbol->linkage_name (),
13562                                       lookup_name, text, word);
13563           }
13564       }
13565
13566     /* Search upwards from currently selected frame (so that we can
13567        complete on local vars.  */
13568
13569     for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
13570       {
13571         if (!BLOCK_SUPERBLOCK (b))
13572           surrounding_static_block = b;   /* For elmin of dups */
13573
13574         ALL_BLOCK_SYMBOLS (b, iter, sym)
13575           {
13576             if (completion_skip_symbol (mode, sym))
13577               continue;
13578
13579             completion_list_add_name (tracker,
13580                                       sym->language (),
13581                                       sym->linkage_name (),
13582                                       lookup_name, text, word);
13583           }
13584       }
13585
13586     /* Go through the symtabs and check the externs and statics for
13587        symbols which match.  */
13588
13589     for (objfile *objfile : current_program_space->objfiles ())
13590       {
13591         for (compunit_symtab *s : objfile->compunits ())
13592           {
13593             QUIT;
13594             b = BLOCKVECTOR_BLOCK (s->blockvector (), GLOBAL_BLOCK);
13595             ALL_BLOCK_SYMBOLS (b, iter, sym)
13596               {
13597                 if (completion_skip_symbol (mode, sym))
13598                   continue;
13599
13600                 completion_list_add_name (tracker,
13601                                           sym->language (),
13602                                           sym->linkage_name (),
13603                                           lookup_name, text, word);
13604               }
13605           }
13606       }
13607
13608     for (objfile *objfile : current_program_space->objfiles ())
13609       {
13610         for (compunit_symtab *s : objfile->compunits ())
13611           {
13612             QUIT;
13613             b = BLOCKVECTOR_BLOCK (s->blockvector (), STATIC_BLOCK);
13614             /* Don't do this block twice.  */
13615             if (b == surrounding_static_block)
13616               continue;
13617             ALL_BLOCK_SYMBOLS (b, iter, sym)
13618               {
13619                 if (completion_skip_symbol (mode, sym))
13620                   continue;
13621
13622                 completion_list_add_name (tracker,
13623                                           sym->language (),
13624                                           sym->linkage_name (),
13625                                           lookup_name, text, word);
13626               }
13627           }
13628       }
13629   }
13630
13631   /* See language.h.  */
13632
13633   gdb::unique_xmalloc_ptr<char> watch_location_expression
13634         (struct type *type, CORE_ADDR addr) const override
13635   {
13636     type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
13637     std::string name = type_to_string (type);
13638     return xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr));
13639   }
13640
13641   /* See language.h.  */
13642
13643   void value_print (struct value *val, struct ui_file *stream,
13644                     const struct value_print_options *options) const override
13645   {
13646     return ada_value_print (val, stream, options);
13647   }
13648
13649   /* See language.h.  */
13650
13651   void value_print_inner
13652         (struct value *val, struct ui_file *stream, int recurse,
13653          const struct value_print_options *options) const override
13654   {
13655     return ada_value_print_inner (val, stream, recurse, options);
13656   }
13657
13658   /* See language.h.  */
13659
13660   struct block_symbol lookup_symbol_nonlocal
13661         (const char *name, const struct block *block,
13662          const domain_enum domain) const override
13663   {
13664     struct block_symbol sym;
13665
13666     sym = ada_lookup_symbol (name, block_static_block (block), domain);
13667     if (sym.symbol != NULL)
13668       return sym;
13669
13670     /* If we haven't found a match at this point, try the primitive
13671        types.  In other languages, this search is performed before
13672        searching for global symbols in order to short-circuit that
13673        global-symbol search if it happens that the name corresponds
13674        to a primitive type.  But we cannot do the same in Ada, because
13675        it is perfectly legitimate for a program to declare a type which
13676        has the same name as a standard type.  If looking up a type in
13677        that situation, we have traditionally ignored the primitive type
13678        in favor of user-defined types.  This is why, unlike most other
13679        languages, we search the primitive types this late and only after
13680        having searched the global symbols without success.  */
13681
13682     if (domain == VAR_DOMAIN)
13683       {
13684         struct gdbarch *gdbarch;
13685
13686         if (block == NULL)
13687           gdbarch = target_gdbarch ();
13688         else
13689           gdbarch = block_gdbarch (block);
13690         sym.symbol
13691           = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13692         if (sym.symbol != NULL)
13693           return sym;
13694       }
13695
13696     return {};
13697   }
13698
13699   /* See language.h.  */
13700
13701   int parser (struct parser_state *ps) const override
13702   {
13703     warnings_issued = 0;
13704     return ada_parse (ps);
13705   }
13706
13707   /* See language.h.  */
13708
13709   void emitchar (int ch, struct type *chtype,
13710                  struct ui_file *stream, int quoter) const override
13711   {
13712     ada_emit_char (ch, chtype, stream, quoter, 1);
13713   }
13714
13715   /* See language.h.  */
13716
13717   void printchar (int ch, struct type *chtype,
13718                   struct ui_file *stream) const override
13719   {
13720     ada_printchar (ch, chtype, stream);
13721   }
13722
13723   /* See language.h.  */
13724
13725   void printstr (struct ui_file *stream, struct type *elttype,
13726                  const gdb_byte *string, unsigned int length,
13727                  const char *encoding, int force_ellipses,
13728                  const struct value_print_options *options) const override
13729   {
13730     ada_printstr (stream, elttype, string, length, encoding,
13731                   force_ellipses, options);
13732   }
13733
13734   /* See language.h.  */
13735
13736   void print_typedef (struct type *type, struct symbol *new_symbol,
13737                       struct ui_file *stream) const override
13738   {
13739     ada_print_typedef (type, new_symbol, stream);
13740   }
13741
13742   /* See language.h.  */
13743
13744   bool is_string_type_p (struct type *type) const override
13745   {
13746     return ada_is_string_type (type);
13747   }
13748
13749   /* See language.h.  */
13750
13751   const char *struct_too_deep_ellipsis () const override
13752   { return "(...)"; }
13753
13754   /* See language.h.  */
13755
13756   bool c_style_arrays_p () const override
13757   { return false; }
13758
13759   /* See language.h.  */
13760
13761   bool store_sym_names_in_linkage_form_p () const override
13762   { return true; }
13763
13764   /* See language.h.  */
13765
13766   const struct lang_varobj_ops *varobj_ops () const override
13767   { return &ada_varobj_ops; }
13768
13769 protected:
13770   /* See language.h.  */
13771
13772   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13773         (const lookup_name_info &lookup_name) const override
13774   {
13775     return ada_get_symbol_name_matcher (lookup_name);
13776   }
13777 };
13778
13779 /* Single instance of the Ada language class.  */
13780
13781 static ada_language ada_language_defn;
13782
13783 /* Command-list for the "set/show ada" prefix command.  */
13784 static struct cmd_list_element *set_ada_list;
13785 static struct cmd_list_element *show_ada_list;
13786
13787 static void
13788 initialize_ada_catchpoint_ops (void)
13789 {
13790   struct breakpoint_ops *ops;
13791
13792   initialize_breakpoint_ops ();
13793
13794   ops = &catch_exception_breakpoint_ops;
13795   *ops = bkpt_breakpoint_ops;
13796   ops->allocate_location = allocate_location_exception;
13797   ops->re_set = re_set_exception;
13798   ops->check_status = check_status_exception;
13799   ops->print_it = print_it_exception;
13800   ops->print_one = print_one_exception;
13801   ops->print_mention = print_mention_exception;
13802   ops->print_recreate = print_recreate_exception;
13803 }
13804
13805 /* This module's 'new_objfile' observer.  */
13806
13807 static void
13808 ada_new_objfile_observer (struct objfile *objfile)
13809 {
13810   ada_clear_symbol_cache ();
13811 }
13812
13813 /* This module's 'free_objfile' observer.  */
13814
13815 static void
13816 ada_free_objfile_observer (struct objfile *objfile)
13817 {
13818   ada_clear_symbol_cache ();
13819 }
13820
13821 /* Charsets known to GNAT.  */
13822 static const char * const gnat_source_charsets[] =
13823 {
13824   /* Note that code below assumes that the default comes first.
13825      Latin-1 is the default here, because that is also GNAT's
13826      default.  */
13827   "ISO-8859-1",
13828   "ISO-8859-2",
13829   "ISO-8859-3",
13830   "ISO-8859-4",
13831   "ISO-8859-5",
13832   "ISO-8859-15",
13833   "CP437",
13834   "CP850",
13835   /* Note that this value is special-cased in the encoder and
13836      decoder.  */
13837   ada_utf8,
13838   nullptr
13839 };
13840
13841 void _initialize_ada_language ();
13842 void
13843 _initialize_ada_language ()
13844 {
13845   initialize_ada_catchpoint_ops ();
13846
13847   add_setshow_prefix_cmd
13848     ("ada", no_class,
13849      _("Prefix command for changing Ada-specific settings."),
13850      _("Generic command for showing Ada-specific settings."),
13851      &set_ada_list, &show_ada_list,
13852      &setlist, &showlist);
13853
13854   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13855                            &trust_pad_over_xvs, _("\
13856 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13857 Show whether an optimization trusting PAD types over XVS types is activated."),
13858                            _("\
13859 This is related to the encoding used by the GNAT compiler.  The debugger\n\
13860 should normally trust the contents of PAD types, but certain older versions\n\
13861 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13862 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
13863 work around this bug.  It is always safe to turn this option \"off\", but\n\
13864 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13865 this option to \"off\" unless necessary."),
13866                             NULL, NULL, &set_ada_list, &show_ada_list);
13867
13868   add_setshow_boolean_cmd ("print-signatures", class_vars,
13869                            &print_signatures, _("\
13870 Enable or disable the output of formal and return types for functions in the \
13871 overloads selection menu."), _("\
13872 Show whether the output of formal and return types for functions in the \
13873 overloads selection menu is activated."),
13874                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
13875
13876   ada_source_charset = gnat_source_charsets[0];
13877   add_setshow_enum_cmd ("source-charset", class_files,
13878                         gnat_source_charsets,
13879                         &ada_source_charset,  _("\
13880 Set the Ada source character set."), _("\
13881 Show the Ada source character set."), _("\
13882 The character set used for Ada source files.\n\
13883 This must correspond to the '-gnati' or '-gnatW' option passed to GNAT."),
13884                         nullptr, nullptr,
13885                         &set_ada_list, &show_ada_list);
13886
13887   add_catch_command ("exception", _("\
13888 Catch Ada exceptions, when raised.\n\
13889 Usage: catch exception [ARG] [if CONDITION]\n\
13890 Without any argument, stop when any Ada exception is raised.\n\
13891 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
13892 being raised does not have a handler (and will therefore lead to the task's\n\
13893 termination).\n\
13894 Otherwise, the catchpoint only stops when the name of the exception being\n\
13895 raised is the same as ARG.\n\
13896 CONDITION is a boolean expression that is evaluated to see whether the\n\
13897 exception should cause a stop."),
13898                      catch_ada_exception_command,
13899                      catch_ada_completer,
13900                      CATCH_PERMANENT,
13901                      CATCH_TEMPORARY);
13902
13903   add_catch_command ("handlers", _("\
13904 Catch Ada exceptions, when handled.\n\
13905 Usage: catch handlers [ARG] [if CONDITION]\n\
13906 Without any argument, stop when any Ada exception is handled.\n\
13907 With an argument, catch only exceptions with the given name.\n\
13908 CONDITION is a boolean expression that is evaluated to see whether the\n\
13909 exception should cause a stop."),
13910                      catch_ada_handlers_command,
13911                      catch_ada_completer,
13912                      CATCH_PERMANENT,
13913                      CATCH_TEMPORARY);
13914   add_catch_command ("assert", _("\
13915 Catch failed Ada assertions, when raised.\n\
13916 Usage: catch assert [if CONDITION]\n\
13917 CONDITION is a boolean expression that is evaluated to see whether the\n\
13918 exception should cause a stop."),
13919                      catch_assert_command,
13920                      NULL,
13921                      CATCH_PERMANENT,
13922                      CATCH_TEMPORARY);
13923
13924   add_info ("exceptions", info_exceptions_command,
13925             _("\
13926 List all Ada exception names.\n\
13927 Usage: info exceptions [REGEXP]\n\
13928 If a regular expression is passed as an argument, only those matching\n\
13929 the regular expression are listed."));
13930
13931   add_setshow_prefix_cmd ("ada", class_maintenance,
13932                           _("Set Ada maintenance-related variables."),
13933                           _("Show Ada maintenance-related variables."),
13934                           &maint_set_ada_cmdlist, &maint_show_ada_cmdlist,
13935                           &maintenance_set_cmdlist, &maintenance_show_cmdlist);
13936
13937   add_setshow_boolean_cmd
13938     ("ignore-descriptive-types", class_maintenance,
13939      &ada_ignore_descriptive_types_p,
13940      _("Set whether descriptive types generated by GNAT should be ignored."),
13941      _("Show whether descriptive types generated by GNAT should be ignored."),
13942      _("\
13943 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13944 DWARF attribute."),
13945      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
13946
13947   decoded_names_store = htab_create_alloc (256, htab_hash_string,
13948                                            htab_eq_string,
13949                                            NULL, xcalloc, xfree);
13950
13951   /* The ada-lang observers.  */
13952   gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
13953   gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
13954   gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");
13955 }
This page took 0.832205 seconds and 4 git commands to generate.