]> Git Repo - binutils.git/blob - gdb/ada-lang.c
Add accessors for symbol's artificial field
[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 = msym.value_address ();
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, bool operators)
1308 {
1309   int i;
1310   int len0;
1311   const char *p;
1312   int at_start_name;
1313   std::string decoded;
1314   int suffix = -1;
1315
1316   /* With function descriptors on PPC64, the value of a symbol named
1317      ".FN", if it exists, is the entry point of the function "FN".  */
1318   if (encoded[0] == '.')
1319     encoded += 1;
1320
1321   /* The name of the Ada main procedure starts with "_ada_".
1322      This prefix is not part of the decoded name, so skip this part
1323      if we see this prefix.  */
1324   if (startswith (encoded, "_ada_"))
1325     encoded += 5;
1326   /* The "___ghost_" prefix is used for ghost entities.  Normally
1327      these aren't preserved but when they are, it's useful to see
1328      them.  */
1329   if (startswith (encoded, "___ghost_"))
1330     encoded += 9;
1331
1332   /* If the name starts with '_', then it is not a properly encoded
1333      name, so do not attempt to decode it.  Similarly, if the name
1334      starts with '<', the name should not be decoded.  */
1335   if (encoded[0] == '_' || encoded[0] == '<')
1336     goto Suppress;
1337
1338   len0 = strlen (encoded);
1339
1340   suffix = remove_compiler_suffix (encoded, &len0);
1341
1342   ada_remove_trailing_digits (encoded, &len0);
1343   ada_remove_po_subprogram_suffix (encoded, &len0);
1344
1345   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1346      the suffix is located before the current "end" of ENCODED.  We want
1347      to avoid re-matching parts of ENCODED that have previously been
1348      marked as discarded (by decrementing LEN0).  */
1349   p = strstr (encoded, "___");
1350   if (p != NULL && p - encoded < len0 - 3)
1351     {
1352       if (p[3] == 'X')
1353         len0 = p - encoded;
1354       else
1355         goto Suppress;
1356     }
1357
1358   /* Remove any trailing TKB suffix.  It tells us that this symbol
1359      is for the body of a task, but that information does not actually
1360      appear in the decoded name.  */
1361
1362   if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1363     len0 -= 3;
1364
1365   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1366      from the TKB suffix because it is used for non-anonymous task
1367      bodies.  */
1368
1369   if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1370     len0 -= 2;
1371
1372   /* Remove trailing "B" suffixes.  */
1373   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1374
1375   if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1376     len0 -= 1;
1377
1378   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1379
1380   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1381     {
1382       i = len0 - 2;
1383       while ((i >= 0 && isdigit (encoded[i]))
1384              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1385         i -= 1;
1386       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1387         len0 = i - 1;
1388       else if (encoded[i] == '$')
1389         len0 = i;
1390     }
1391
1392   /* The first few characters that are not alphabetic are not part
1393      of any encoding we use, so we can copy them over verbatim.  */
1394
1395   for (i = 0; i < len0 && !isalpha (encoded[i]); i += 1)
1396     decoded.push_back (encoded[i]);
1397
1398   at_start_name = 1;
1399   while (i < len0)
1400     {
1401       /* Is this a symbol function?  */
1402       if (operators && at_start_name && encoded[i] == 'O')
1403         {
1404           int k;
1405
1406           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1407             {
1408               int op_len = strlen (ada_opname_table[k].encoded);
1409               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1410                             op_len - 1) == 0)
1411                   && !isalnum (encoded[i + op_len]))
1412                 {
1413                   decoded.append (ada_opname_table[k].decoded);
1414                   at_start_name = 0;
1415                   i += op_len;
1416                   break;
1417                 }
1418             }
1419           if (ada_opname_table[k].encoded != NULL)
1420             continue;
1421         }
1422       at_start_name = 0;
1423
1424       /* Replace "TK__" with "__", which will eventually be translated
1425          into "." (just below).  */
1426
1427       if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1428         i += 2;
1429
1430       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1431          be translated into "." (just below).  These are internal names
1432          generated for anonymous blocks inside which our symbol is nested.  */
1433
1434       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1435           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1436           && isdigit (encoded [i+4]))
1437         {
1438           int k = i + 5;
1439           
1440           while (k < len0 && isdigit (encoded[k]))
1441             k++;  /* Skip any extra digit.  */
1442
1443           /* Double-check that the "__B_{DIGITS}+" sequence we found
1444              is indeed followed by "__".  */
1445           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1446             i = k;
1447         }
1448
1449       /* Remove _E{DIGITS}+[sb] */
1450
1451       /* Just as for protected object subprograms, there are 2 categories
1452          of subprograms created by the compiler for each entry.  The first
1453          one implements the actual entry code, and has a suffix following
1454          the convention above; the second one implements the barrier and
1455          uses the same convention as above, except that the 'E' is replaced
1456          by a 'B'.
1457
1458          Just as above, we do not decode the name of barrier functions
1459          to give the user a clue that the code he is debugging has been
1460          internally generated.  */
1461
1462       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1463           && isdigit (encoded[i+2]))
1464         {
1465           int k = i + 3;
1466
1467           while (k < len0 && isdigit (encoded[k]))
1468             k++;
1469
1470           if (k < len0
1471               && (encoded[k] == 'b' || encoded[k] == 's'))
1472             {
1473               k++;
1474               /* Just as an extra precaution, make sure that if this
1475                  suffix is followed by anything else, it is a '_'.
1476                  Otherwise, we matched this sequence by accident.  */
1477               if (k == len0
1478                   || (k < len0 && encoded[k] == '_'))
1479                 i = k;
1480             }
1481         }
1482
1483       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1484          the GNAT front-end in protected object subprograms.  */
1485
1486       if (i < len0 + 3
1487           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1488         {
1489           /* Backtrack a bit up until we reach either the begining of
1490              the encoded name, or "__".  Make sure that we only find
1491              digits or lowercase characters.  */
1492           const char *ptr = encoded + i - 1;
1493
1494           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1495             ptr--;
1496           if (ptr < encoded
1497               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1498             i++;
1499         }
1500
1501       if (i < len0 + 3 && encoded[i] == 'U' && isxdigit (encoded[i + 1]))
1502         {
1503           if (convert_from_hex_encoded (decoded, &encoded[i + 1], 2))
1504             {
1505               i += 3;
1506               continue;
1507             }
1508         }
1509       else if (i < len0 + 5 && encoded[i] == 'W' && isxdigit (encoded[i + 1]))
1510         {
1511           if (convert_from_hex_encoded (decoded, &encoded[i + 1], 4))
1512             {
1513               i += 5;
1514               continue;
1515             }
1516         }
1517       else if (i < len0 + 10 && encoded[i] == 'W' && encoded[i + 1] == 'W'
1518                && isxdigit (encoded[i + 2]))
1519         {
1520           if (convert_from_hex_encoded (decoded, &encoded[i + 2], 8))
1521             {
1522               i += 10;
1523               continue;
1524             }
1525         }
1526
1527       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1528         {
1529           /* This is a X[bn]* sequence not separated from the previous
1530              part of the name with a non-alpha-numeric character (in other
1531              words, immediately following an alpha-numeric character), then
1532              verify that it is placed at the end of the encoded name.  If
1533              not, then the encoding is not valid and we should abort the
1534              decoding.  Otherwise, just skip it, it is used in body-nested
1535              package names.  */
1536           do
1537             i += 1;
1538           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1539           if (i < len0)
1540             goto Suppress;
1541         }
1542       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1543         {
1544          /* Replace '__' by '.'.  */
1545           decoded.push_back ('.');
1546           at_start_name = 1;
1547           i += 2;
1548         }
1549       else
1550         {
1551           /* It's a character part of the decoded name, so just copy it
1552              over.  */
1553           decoded.push_back (encoded[i]);
1554           i += 1;
1555         }
1556     }
1557
1558   /* Decoded names should never contain any uppercase character.
1559      Double-check this, and abort the decoding if we find one.  */
1560
1561   if (operators)
1562     {
1563       for (i = 0; i < decoded.length(); ++i)
1564         if (isupper (decoded[i]) || decoded[i] == ' ')
1565           goto Suppress;
1566     }
1567
1568   /* If the compiler added a suffix, append it now.  */
1569   if (suffix >= 0)
1570     decoded = decoded + "[" + &encoded[suffix] + "]";
1571
1572   return decoded;
1573
1574 Suppress:
1575   if (!wrap)
1576     return {};
1577
1578   if (encoded[0] == '<')
1579     decoded = encoded;
1580   else
1581     decoded = '<' + std::string(encoded) + '>';
1582   return decoded;
1583 }
1584
1585 /* Table for keeping permanent unique copies of decoded names.  Once
1586    allocated, names in this table are never released.  While this is a
1587    storage leak, it should not be significant unless there are massive
1588    changes in the set of decoded names in successive versions of a 
1589    symbol table loaded during a single session.  */
1590 static struct htab *decoded_names_store;
1591
1592 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1593    in the language-specific part of GSYMBOL, if it has not been
1594    previously computed.  Tries to save the decoded name in the same
1595    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1596    in any case, the decoded symbol has a lifetime at least that of
1597    GSYMBOL).
1598    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1599    const, but nevertheless modified to a semantically equivalent form
1600    when a decoded name is cached in it.  */
1601
1602 const char *
1603 ada_decode_symbol (const struct general_symbol_info *arg)
1604 {
1605   struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1606   const char **resultp =
1607     &gsymbol->language_specific.demangled_name;
1608
1609   if (!gsymbol->ada_mangled)
1610     {
1611       std::string decoded = ada_decode (gsymbol->linkage_name ());
1612       struct obstack *obstack = gsymbol->language_specific.obstack;
1613
1614       gsymbol->ada_mangled = 1;
1615
1616       if (obstack != NULL)
1617         *resultp = obstack_strdup (obstack, decoded.c_str ());
1618       else
1619         {
1620           /* Sometimes, we can't find a corresponding objfile, in
1621              which case, we put the result on the heap.  Since we only
1622              decode when needed, we hope this usually does not cause a
1623              significant memory leak (FIXME).  */
1624
1625           char **slot = (char **) htab_find_slot (decoded_names_store,
1626                                                   decoded.c_str (), INSERT);
1627
1628           if (*slot == NULL)
1629             *slot = xstrdup (decoded.c_str ());
1630           *resultp = *slot;
1631         }
1632     }
1633
1634   return *resultp;
1635 }
1636
1637 \f
1638
1639                                 /* Arrays */
1640
1641 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1642    generated by the GNAT compiler to describe the index type used
1643    for each dimension of an array, check whether it follows the latest
1644    known encoding.  If not, fix it up to conform to the latest encoding.
1645    Otherwise, do nothing.  This function also does nothing if
1646    INDEX_DESC_TYPE is NULL.
1647
1648    The GNAT encoding used to describe the array index type evolved a bit.
1649    Initially, the information would be provided through the name of each
1650    field of the structure type only, while the type of these fields was
1651    described as unspecified and irrelevant.  The debugger was then expected
1652    to perform a global type lookup using the name of that field in order
1653    to get access to the full index type description.  Because these global
1654    lookups can be very expensive, the encoding was later enhanced to make
1655    the global lookup unnecessary by defining the field type as being
1656    the full index type description.
1657
1658    The purpose of this routine is to allow us to support older versions
1659    of the compiler by detecting the use of the older encoding, and by
1660    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1661    we essentially replace each field's meaningless type by the associated
1662    index subtype).  */
1663
1664 void
1665 ada_fixup_array_indexes_type (struct type *index_desc_type)
1666 {
1667   int i;
1668
1669   if (index_desc_type == NULL)
1670     return;
1671   gdb_assert (index_desc_type->num_fields () > 0);
1672
1673   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1674      to check one field only, no need to check them all).  If not, return
1675      now.
1676
1677      If our INDEX_DESC_TYPE was generated using the older encoding,
1678      the field type should be a meaningless integer type whose name
1679      is not equal to the field name.  */
1680   if (index_desc_type->field (0).type ()->name () != NULL
1681       && strcmp (index_desc_type->field (0).type ()->name (),
1682                  index_desc_type->field (0).name ()) == 0)
1683     return;
1684
1685   /* Fixup each field of INDEX_DESC_TYPE.  */
1686   for (i = 0; i < index_desc_type->num_fields (); i++)
1687    {
1688      const char *name = index_desc_type->field (i).name ();
1689      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1690
1691      if (raw_type)
1692        index_desc_type->field (i).set_type (raw_type);
1693    }
1694 }
1695
1696 /* The desc_* routines return primitive portions of array descriptors
1697    (fat pointers).  */
1698
1699 /* The descriptor or array type, if any, indicated by TYPE; removes
1700    level of indirection, if needed.  */
1701
1702 static struct type *
1703 desc_base_type (struct type *type)
1704 {
1705   if (type == NULL)
1706     return NULL;
1707   type = ada_check_typedef (type);
1708   if (type->code () == TYPE_CODE_TYPEDEF)
1709     type = ada_typedef_target_type (type);
1710
1711   if (type != NULL
1712       && (type->code () == TYPE_CODE_PTR
1713           || type->code () == TYPE_CODE_REF))
1714     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1715   else
1716     return type;
1717 }
1718
1719 /* True iff TYPE indicates a "thin" array pointer type.  */
1720
1721 static int
1722 is_thin_pntr (struct type *type)
1723 {
1724   return
1725     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1726     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1727 }
1728
1729 /* The descriptor type for thin pointer type TYPE.  */
1730
1731 static struct type *
1732 thin_descriptor_type (struct type *type)
1733 {
1734   struct type *base_type = desc_base_type (type);
1735
1736   if (base_type == NULL)
1737     return NULL;
1738   if (is_suffix (ada_type_name (base_type), "___XVE"))
1739     return base_type;
1740   else
1741     {
1742       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1743
1744       if (alt_type == NULL)
1745         return base_type;
1746       else
1747         return alt_type;
1748     }
1749 }
1750
1751 /* A pointer to the array data for thin-pointer value VAL.  */
1752
1753 static struct value *
1754 thin_data_pntr (struct value *val)
1755 {
1756   struct type *type = ada_check_typedef (value_type (val));
1757   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1758
1759   data_type = lookup_pointer_type (data_type);
1760
1761   if (type->code () == TYPE_CODE_PTR)
1762     return value_cast (data_type, value_copy (val));
1763   else
1764     return value_from_longest (data_type, value_address (val));
1765 }
1766
1767 /* True iff TYPE indicates a "thick" array pointer type.  */
1768
1769 static int
1770 is_thick_pntr (struct type *type)
1771 {
1772   type = desc_base_type (type);
1773   return (type != NULL && type->code () == TYPE_CODE_STRUCT
1774           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1775 }
1776
1777 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1778    pointer to one, the type of its bounds data; otherwise, NULL.  */
1779
1780 static struct type *
1781 desc_bounds_type (struct type *type)
1782 {
1783   struct type *r;
1784
1785   type = desc_base_type (type);
1786
1787   if (type == NULL)
1788     return NULL;
1789   else if (is_thin_pntr (type))
1790     {
1791       type = thin_descriptor_type (type);
1792       if (type == NULL)
1793         return NULL;
1794       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1795       if (r != NULL)
1796         return ada_check_typedef (r);
1797     }
1798   else if (type->code () == TYPE_CODE_STRUCT)
1799     {
1800       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1801       if (r != NULL)
1802         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1803     }
1804   return NULL;
1805 }
1806
1807 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1808    one, a pointer to its bounds data.   Otherwise NULL.  */
1809
1810 static struct value *
1811 desc_bounds (struct value *arr)
1812 {
1813   struct type *type = ada_check_typedef (value_type (arr));
1814
1815   if (is_thin_pntr (type))
1816     {
1817       struct type *bounds_type =
1818         desc_bounds_type (thin_descriptor_type (type));
1819       LONGEST addr;
1820
1821       if (bounds_type == NULL)
1822         error (_("Bad GNAT array descriptor"));
1823
1824       /* NOTE: The following calculation is not really kosher, but
1825          since desc_type is an XVE-encoded type (and shouldn't be),
1826          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1827       if (type->code () == TYPE_CODE_PTR)
1828         addr = value_as_long (arr);
1829       else
1830         addr = value_address (arr);
1831
1832       return
1833         value_from_longest (lookup_pointer_type (bounds_type),
1834                             addr - TYPE_LENGTH (bounds_type));
1835     }
1836
1837   else if (is_thick_pntr (type))
1838     {
1839       struct value *p_bounds = value_struct_elt (&arr, {}, "P_BOUNDS", NULL,
1840                                                _("Bad GNAT array descriptor"));
1841       struct type *p_bounds_type = value_type (p_bounds);
1842
1843       if (p_bounds_type
1844           && p_bounds_type->code () == TYPE_CODE_PTR)
1845         {
1846           struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1847
1848           if (target_type->is_stub ())
1849             p_bounds = value_cast (lookup_pointer_type
1850                                    (ada_check_typedef (target_type)),
1851                                    p_bounds);
1852         }
1853       else
1854         error (_("Bad GNAT array descriptor"));
1855
1856       return p_bounds;
1857     }
1858   else
1859     return NULL;
1860 }
1861
1862 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1863    position of the field containing the address of the bounds data.  */
1864
1865 static int
1866 fat_pntr_bounds_bitpos (struct type *type)
1867 {
1868   return desc_base_type (type)->field (1).loc_bitpos ();
1869 }
1870
1871 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1872    size of the field containing the address of the bounds data.  */
1873
1874 static int
1875 fat_pntr_bounds_bitsize (struct type *type)
1876 {
1877   type = desc_base_type (type);
1878
1879   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1880     return TYPE_FIELD_BITSIZE (type, 1);
1881   else
1882     return 8 * TYPE_LENGTH (ada_check_typedef (type->field (1).type ()));
1883 }
1884
1885 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1886    pointer to one, the type of its array data (a array-with-no-bounds type);
1887    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1888    data.  */
1889
1890 static struct type *
1891 desc_data_target_type (struct type *type)
1892 {
1893   type = desc_base_type (type);
1894
1895   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1896   if (is_thin_pntr (type))
1897     return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1898   else if (is_thick_pntr (type))
1899     {
1900       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1901
1902       if (data_type
1903           && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1904         return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1905     }
1906
1907   return NULL;
1908 }
1909
1910 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1911    its array data.  */
1912
1913 static struct value *
1914 desc_data (struct value *arr)
1915 {
1916   struct type *type = value_type (arr);
1917
1918   if (is_thin_pntr (type))
1919     return thin_data_pntr (arr);
1920   else if (is_thick_pntr (type))
1921     return value_struct_elt (&arr, {}, "P_ARRAY", NULL,
1922                              _("Bad GNAT array descriptor"));
1923   else
1924     return NULL;
1925 }
1926
1927
1928 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1929    position of the field containing the address of the data.  */
1930
1931 static int
1932 fat_pntr_data_bitpos (struct type *type)
1933 {
1934   return desc_base_type (type)->field (0).loc_bitpos ();
1935 }
1936
1937 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1938    size of the field containing the address of the data.  */
1939
1940 static int
1941 fat_pntr_data_bitsize (struct type *type)
1942 {
1943   type = desc_base_type (type);
1944
1945   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1946     return TYPE_FIELD_BITSIZE (type, 0);
1947   else
1948     return TARGET_CHAR_BIT * TYPE_LENGTH (type->field (0).type ());
1949 }
1950
1951 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1952    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1953    bound, if WHICH is 1.  The first bound is I=1.  */
1954
1955 static struct value *
1956 desc_one_bound (struct value *bounds, int i, int which)
1957 {
1958   char bound_name[20];
1959   xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1960              which ? 'U' : 'L', i - 1);
1961   return value_struct_elt (&bounds, {}, bound_name, NULL,
1962                            _("Bad GNAT array descriptor bounds"));
1963 }
1964
1965 /* If BOUNDS is an array-bounds structure type, return the bit position
1966    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1967    bound, if WHICH is 1.  The first bound is I=1.  */
1968
1969 static int
1970 desc_bound_bitpos (struct type *type, int i, int which)
1971 {
1972   return desc_base_type (type)->field (2 * i + which - 2).loc_bitpos ();
1973 }
1974
1975 /* If BOUNDS is an array-bounds structure type, return the bit field size
1976    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1977    bound, if WHICH is 1.  The first bound is I=1.  */
1978
1979 static int
1980 desc_bound_bitsize (struct type *type, int i, int which)
1981 {
1982   type = desc_base_type (type);
1983
1984   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1985     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1986   else
1987     return 8 * TYPE_LENGTH (type->field (2 * i + which - 2).type ());
1988 }
1989
1990 /* If TYPE is the type of an array-bounds structure, the type of its
1991    Ith bound (numbering from 1).  Otherwise, NULL.  */
1992
1993 static struct type *
1994 desc_index_type (struct type *type, int i)
1995 {
1996   type = desc_base_type (type);
1997
1998   if (type->code () == TYPE_CODE_STRUCT)
1999     {
2000       char bound_name[20];
2001       xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
2002       return lookup_struct_elt_type (type, bound_name, 1);
2003     }
2004   else
2005     return NULL;
2006 }
2007
2008 /* The number of index positions in the array-bounds type TYPE.
2009    Return 0 if TYPE is NULL.  */
2010
2011 static int
2012 desc_arity (struct type *type)
2013 {
2014   type = desc_base_type (type);
2015
2016   if (type != NULL)
2017     return type->num_fields () / 2;
2018   return 0;
2019 }
2020
2021 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
2022    an array descriptor type (representing an unconstrained array
2023    type).  */
2024
2025 static int
2026 ada_is_direct_array_type (struct type *type)
2027 {
2028   if (type == NULL)
2029     return 0;
2030   type = ada_check_typedef (type);
2031   return (type->code () == TYPE_CODE_ARRAY
2032           || ada_is_array_descriptor_type (type));
2033 }
2034
2035 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
2036  * to one.  */
2037
2038 static int
2039 ada_is_array_type (struct type *type)
2040 {
2041   while (type != NULL
2042          && (type->code () == TYPE_CODE_PTR
2043              || type->code () == TYPE_CODE_REF))
2044     type = TYPE_TARGET_TYPE (type);
2045   return ada_is_direct_array_type (type);
2046 }
2047
2048 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
2049
2050 int
2051 ada_is_simple_array_type (struct type *type)
2052 {
2053   if (type == NULL)
2054     return 0;
2055   type = ada_check_typedef (type);
2056   return (type->code () == TYPE_CODE_ARRAY
2057           || (type->code () == TYPE_CODE_PTR
2058               && (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ()
2059                   == TYPE_CODE_ARRAY)));
2060 }
2061
2062 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
2063
2064 int
2065 ada_is_array_descriptor_type (struct type *type)
2066 {
2067   struct type *data_type = desc_data_target_type (type);
2068
2069   if (type == NULL)
2070     return 0;
2071   type = ada_check_typedef (type);
2072   return (data_type != NULL
2073           && data_type->code () == TYPE_CODE_ARRAY
2074           && desc_arity (desc_bounds_type (type)) > 0);
2075 }
2076
2077 /* Non-zero iff type is a partially mal-formed GNAT array
2078    descriptor.  FIXME: This is to compensate for some problems with
2079    debugging output from GNAT.  Re-examine periodically to see if it
2080    is still needed.  */
2081
2082 int
2083 ada_is_bogus_array_descriptor (struct type *type)
2084 {
2085   return
2086     type != NULL
2087     && type->code () == TYPE_CODE_STRUCT
2088     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
2089         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
2090     && !ada_is_array_descriptor_type (type);
2091 }
2092
2093
2094 /* If ARR has a record type in the form of a standard GNAT array descriptor,
2095    (fat pointer) returns the type of the array data described---specifically,
2096    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
2097    in from the descriptor; otherwise, they are left unspecified.  If
2098    the ARR denotes a null array descriptor and BOUNDS is non-zero,
2099    returns NULL.  The result is simply the type of ARR if ARR is not
2100    a descriptor.  */
2101
2102 static struct type *
2103 ada_type_of_array (struct value *arr, int bounds)
2104 {
2105   if (ada_is_constrained_packed_array_type (value_type (arr)))
2106     return decode_constrained_packed_array_type (value_type (arr));
2107
2108   if (!ada_is_array_descriptor_type (value_type (arr)))
2109     return value_type (arr);
2110
2111   if (!bounds)
2112     {
2113       struct type *array_type =
2114         ada_check_typedef (desc_data_target_type (value_type (arr)));
2115
2116       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2117         TYPE_FIELD_BITSIZE (array_type, 0) =
2118           decode_packed_array_bitsize (value_type (arr));
2119       
2120       return array_type;
2121     }
2122   else
2123     {
2124       struct type *elt_type;
2125       int arity;
2126       struct value *descriptor;
2127
2128       elt_type = ada_array_element_type (value_type (arr), -1);
2129       arity = ada_array_arity (value_type (arr));
2130
2131       if (elt_type == NULL || arity == 0)
2132         return ada_check_typedef (value_type (arr));
2133
2134       descriptor = desc_bounds (arr);
2135       if (value_as_long (descriptor) == 0)
2136         return NULL;
2137       while (arity > 0)
2138         {
2139           struct type *range_type = alloc_type_copy (value_type (arr));
2140           struct type *array_type = alloc_type_copy (value_type (arr));
2141           struct value *low = desc_one_bound (descriptor, arity, 0);
2142           struct value *high = desc_one_bound (descriptor, arity, 1);
2143
2144           arity -= 1;
2145           create_static_range_type (range_type, value_type (low),
2146                                     longest_to_int (value_as_long (low)),
2147                                     longest_to_int (value_as_long (high)));
2148           elt_type = create_array_type (array_type, elt_type, range_type);
2149
2150           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2151             {
2152               /* We need to store the element packed bitsize, as well as
2153                  recompute the array size, because it was previously
2154                  computed based on the unpacked element size.  */
2155               LONGEST lo = value_as_long (low);
2156               LONGEST hi = value_as_long (high);
2157
2158               TYPE_FIELD_BITSIZE (elt_type, 0) =
2159                 decode_packed_array_bitsize (value_type (arr));
2160               /* If the array has no element, then the size is already
2161                  zero, and does not need to be recomputed.  */
2162               if (lo < hi)
2163                 {
2164                   int array_bitsize =
2165                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2166
2167                   TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2168                 }
2169             }
2170         }
2171
2172       return lookup_pointer_type (elt_type);
2173     }
2174 }
2175
2176 /* If ARR does not represent an array, returns ARR unchanged.
2177    Otherwise, returns either a standard GDB array with bounds set
2178    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2179    GDB array.  Returns NULL if ARR is a null fat pointer.  */
2180
2181 struct value *
2182 ada_coerce_to_simple_array_ptr (struct value *arr)
2183 {
2184   if (ada_is_array_descriptor_type (value_type (arr)))
2185     {
2186       struct type *arrType = ada_type_of_array (arr, 1);
2187
2188       if (arrType == NULL)
2189         return NULL;
2190       return value_cast (arrType, value_copy (desc_data (arr)));
2191     }
2192   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2193     return decode_constrained_packed_array (arr);
2194   else
2195     return arr;
2196 }
2197
2198 /* If ARR does not represent an array, returns ARR unchanged.
2199    Otherwise, returns a standard GDB array describing ARR (which may
2200    be ARR itself if it already is in the proper form).  */
2201
2202 struct value *
2203 ada_coerce_to_simple_array (struct value *arr)
2204 {
2205   if (ada_is_array_descriptor_type (value_type (arr)))
2206     {
2207       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2208
2209       if (arrVal == NULL)
2210         error (_("Bounds unavailable for null array pointer."));
2211       return value_ind (arrVal);
2212     }
2213   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2214     return decode_constrained_packed_array (arr);
2215   else
2216     return arr;
2217 }
2218
2219 /* If TYPE represents a GNAT array type, return it translated to an
2220    ordinary GDB array type (possibly with BITSIZE fields indicating
2221    packing).  For other types, is the identity.  */
2222
2223 struct type *
2224 ada_coerce_to_simple_array_type (struct type *type)
2225 {
2226   if (ada_is_constrained_packed_array_type (type))
2227     return decode_constrained_packed_array_type (type);
2228
2229   if (ada_is_array_descriptor_type (type))
2230     return ada_check_typedef (desc_data_target_type (type));
2231
2232   return type;
2233 }
2234
2235 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
2236
2237 static int
2238 ada_is_gnat_encoded_packed_array_type  (struct type *type)
2239 {
2240   if (type == NULL)
2241     return 0;
2242   type = desc_base_type (type);
2243   type = ada_check_typedef (type);
2244   return
2245     ada_type_name (type) != NULL
2246     && strstr (ada_type_name (type), "___XP") != NULL;
2247 }
2248
2249 /* Non-zero iff TYPE represents a standard GNAT constrained
2250    packed-array type.  */
2251
2252 int
2253 ada_is_constrained_packed_array_type (struct type *type)
2254 {
2255   return ada_is_gnat_encoded_packed_array_type (type)
2256     && !ada_is_array_descriptor_type (type);
2257 }
2258
2259 /* Non-zero iff TYPE represents an array descriptor for a
2260    unconstrained packed-array type.  */
2261
2262 static int
2263 ada_is_unconstrained_packed_array_type (struct type *type)
2264 {
2265   if (!ada_is_array_descriptor_type (type))
2266     return 0;
2267
2268   if (ada_is_gnat_encoded_packed_array_type (type))
2269     return 1;
2270
2271   /* If we saw GNAT encodings, then the above code is sufficient.
2272      However, with minimal encodings, we will just have a thick
2273      pointer instead.  */
2274   if (is_thick_pntr (type))
2275     {
2276       type = desc_base_type (type);
2277       /* The structure's first field is a pointer to an array, so this
2278          fetches the array type.  */
2279       type = TYPE_TARGET_TYPE (type->field (0).type ());
2280       if (type->code () == TYPE_CODE_TYPEDEF)
2281         type = ada_typedef_target_type (type);
2282       /* Now we can see if the array elements are packed.  */
2283       return TYPE_FIELD_BITSIZE (type, 0) > 0;
2284     }
2285
2286   return 0;
2287 }
2288
2289 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2290    type, or if it is an ordinary (non-Gnat-encoded) packed array.  */
2291
2292 static bool
2293 ada_is_any_packed_array_type (struct type *type)
2294 {
2295   return (ada_is_constrained_packed_array_type (type)
2296           || (type->code () == TYPE_CODE_ARRAY
2297               && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
2298 }
2299
2300 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2301    return the size of its elements in bits.  */
2302
2303 static long
2304 decode_packed_array_bitsize (struct type *type)
2305 {
2306   const char *raw_name;
2307   const char *tail;
2308   long bits;
2309
2310   /* Access to arrays implemented as fat pointers are encoded as a typedef
2311      of the fat pointer type.  We need the name of the fat pointer type
2312      to do the decoding, so strip the typedef layer.  */
2313   if (type->code () == TYPE_CODE_TYPEDEF)
2314     type = ada_typedef_target_type (type);
2315
2316   raw_name = ada_type_name (ada_check_typedef (type));
2317   if (!raw_name)
2318     raw_name = ada_type_name (desc_base_type (type));
2319
2320   if (!raw_name)
2321     return 0;
2322
2323   tail = strstr (raw_name, "___XP");
2324   if (tail == nullptr)
2325     {
2326       gdb_assert (is_thick_pntr (type));
2327       /* The structure's first field is a pointer to an array, so this
2328          fetches the array type.  */
2329       type = TYPE_TARGET_TYPE (type->field (0).type ());
2330       /* Now we can see if the array elements are packed.  */
2331       return TYPE_FIELD_BITSIZE (type, 0);
2332     }
2333
2334   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2335     {
2336       lim_warning
2337         (_("could not understand bit size information on packed array"));
2338       return 0;
2339     }
2340
2341   return bits;
2342 }
2343
2344 /* Given that TYPE is a standard GDB array type with all bounds filled
2345    in, and that the element size of its ultimate scalar constituents
2346    (that is, either its elements, or, if it is an array of arrays, its
2347    elements' elements, etc.) is *ELT_BITS, return an identical type,
2348    but with the bit sizes of its elements (and those of any
2349    constituent arrays) recorded in the BITSIZE components of its
2350    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2351    in bits.
2352
2353    Note that, for arrays whose index type has an XA encoding where
2354    a bound references a record discriminant, getting that discriminant,
2355    and therefore the actual value of that bound, is not possible
2356    because none of the given parameters gives us access to the record.
2357    This function assumes that it is OK in the context where it is being
2358    used to return an array whose bounds are still dynamic and where
2359    the length is arbitrary.  */
2360
2361 static struct type *
2362 constrained_packed_array_type (struct type *type, long *elt_bits)
2363 {
2364   struct type *new_elt_type;
2365   struct type *new_type;
2366   struct type *index_type_desc;
2367   struct type *index_type;
2368   LONGEST low_bound, high_bound;
2369
2370   type = ada_check_typedef (type);
2371   if (type->code () != TYPE_CODE_ARRAY)
2372     return type;
2373
2374   index_type_desc = ada_find_parallel_type (type, "___XA");
2375   if (index_type_desc)
2376     index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2377                                       NULL);
2378   else
2379     index_type = type->index_type ();
2380
2381   new_type = alloc_type_copy (type);
2382   new_elt_type =
2383     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2384                                    elt_bits);
2385   create_array_type (new_type, new_elt_type, index_type);
2386   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2387   new_type->set_name (ada_type_name (type));
2388
2389   if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2390        && is_dynamic_type (check_typedef (index_type)))
2391       || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2392     low_bound = high_bound = 0;
2393   if (high_bound < low_bound)
2394     *elt_bits = TYPE_LENGTH (new_type) = 0;
2395   else
2396     {
2397       *elt_bits *= (high_bound - low_bound + 1);
2398       TYPE_LENGTH (new_type) =
2399         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2400     }
2401
2402   new_type->set_is_fixed_instance (true);
2403   return new_type;
2404 }
2405
2406 /* The array type encoded by TYPE, where
2407    ada_is_constrained_packed_array_type (TYPE).  */
2408
2409 static struct type *
2410 decode_constrained_packed_array_type (struct type *type)
2411 {
2412   const char *raw_name = ada_type_name (ada_check_typedef (type));
2413   char *name;
2414   const char *tail;
2415   struct type *shadow_type;
2416   long bits;
2417
2418   if (!raw_name)
2419     raw_name = ada_type_name (desc_base_type (type));
2420
2421   if (!raw_name)
2422     return NULL;
2423
2424   name = (char *) alloca (strlen (raw_name) + 1);
2425   tail = strstr (raw_name, "___XP");
2426   type = desc_base_type (type);
2427
2428   memcpy (name, raw_name, tail - raw_name);
2429   name[tail - raw_name] = '\000';
2430
2431   shadow_type = ada_find_parallel_type_with_name (type, name);
2432
2433   if (shadow_type == NULL)
2434     {
2435       lim_warning (_("could not find bounds information on packed array"));
2436       return NULL;
2437     }
2438   shadow_type = check_typedef (shadow_type);
2439
2440   if (shadow_type->code () != TYPE_CODE_ARRAY)
2441     {
2442       lim_warning (_("could not understand bounds "
2443                      "information on packed array"));
2444       return NULL;
2445     }
2446
2447   bits = decode_packed_array_bitsize (type);
2448   return constrained_packed_array_type (shadow_type, &bits);
2449 }
2450
2451 /* Helper function for decode_constrained_packed_array.  Set the field
2452    bitsize on a series of packed arrays.  Returns the number of
2453    elements in TYPE.  */
2454
2455 static LONGEST
2456 recursively_update_array_bitsize (struct type *type)
2457 {
2458   gdb_assert (type->code () == TYPE_CODE_ARRAY);
2459
2460   LONGEST low, high;
2461   if (!get_discrete_bounds (type->index_type (), &low, &high)
2462       || low > high)
2463     return 0;
2464   LONGEST our_len = high - low + 1;
2465
2466   struct type *elt_type = TYPE_TARGET_TYPE (type);
2467   if (elt_type->code () == TYPE_CODE_ARRAY)
2468     {
2469       LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2470       LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2471       TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2472
2473       TYPE_LENGTH (type) = ((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2474                             / HOST_CHAR_BIT);
2475     }
2476
2477   return our_len;
2478 }
2479
2480 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2481    array, returns a simple array that denotes that array.  Its type is a
2482    standard GDB array type except that the BITSIZEs of the array
2483    target types are set to the number of bits in each element, and the
2484    type length is set appropriately.  */
2485
2486 static struct value *
2487 decode_constrained_packed_array (struct value *arr)
2488 {
2489   struct type *type;
2490
2491   /* If our value is a pointer, then dereference it. Likewise if
2492      the value is a reference.  Make sure that this operation does not
2493      cause the target type to be fixed, as this would indirectly cause
2494      this array to be decoded.  The rest of the routine assumes that
2495      the array hasn't been decoded yet, so we use the basic "coerce_ref"
2496      and "value_ind" routines to perform the dereferencing, as opposed
2497      to using "ada_coerce_ref" or "ada_value_ind".  */
2498   arr = coerce_ref (arr);
2499   if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2500     arr = value_ind (arr);
2501
2502   type = decode_constrained_packed_array_type (value_type (arr));
2503   if (type == NULL)
2504     {
2505       error (_("can't unpack array"));
2506       return NULL;
2507     }
2508
2509   /* Decoding the packed array type could not correctly set the field
2510      bitsizes for any dimension except the innermost, because the
2511      bounds may be variable and were not passed to that function.  So,
2512      we further resolve the array bounds here and then update the
2513      sizes.  */
2514   const gdb_byte *valaddr = value_contents_for_printing (arr).data ();
2515   CORE_ADDR address = value_address (arr);
2516   gdb::array_view<const gdb_byte> view
2517     = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
2518   type = resolve_dynamic_type (type, view, address);
2519   recursively_update_array_bitsize (type);
2520
2521   if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2522       && ada_is_modular_type (value_type (arr)))
2523     {
2524        /* This is a (right-justified) modular type representing a packed
2525           array with no wrapper.  In order to interpret the value through
2526           the (left-justified) packed array type we just built, we must
2527           first left-justify it.  */
2528       int bit_size, bit_pos;
2529       ULONGEST mod;
2530
2531       mod = ada_modulus (value_type (arr)) - 1;
2532       bit_size = 0;
2533       while (mod > 0)
2534         {
2535           bit_size += 1;
2536           mod >>= 1;
2537         }
2538       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2539       arr = ada_value_primitive_packed_val (arr, NULL,
2540                                             bit_pos / HOST_CHAR_BIT,
2541                                             bit_pos % HOST_CHAR_BIT,
2542                                             bit_size,
2543                                             type);
2544     }
2545
2546   return coerce_unspec_val_to_type (arr, type);
2547 }
2548
2549
2550 /* The value of the element of packed array ARR at the ARITY indices
2551    given in IND.   ARR must be a simple array.  */
2552
2553 static struct value *
2554 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2555 {
2556   int i;
2557   int bits, elt_off, bit_off;
2558   long elt_total_bit_offset;
2559   struct type *elt_type;
2560   struct value *v;
2561
2562   bits = 0;
2563   elt_total_bit_offset = 0;
2564   elt_type = ada_check_typedef (value_type (arr));
2565   for (i = 0; i < arity; i += 1)
2566     {
2567       if (elt_type->code () != TYPE_CODE_ARRAY
2568           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2569         error
2570           (_("attempt to do packed indexing of "
2571              "something other than a packed array"));
2572       else
2573         {
2574           struct type *range_type = elt_type->index_type ();
2575           LONGEST lowerbound, upperbound;
2576           LONGEST idx;
2577
2578           if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2579             {
2580               lim_warning (_("don't know bounds of array"));
2581               lowerbound = upperbound = 0;
2582             }
2583
2584           idx = pos_atr (ind[i]);
2585           if (idx < lowerbound || idx > upperbound)
2586             lim_warning (_("packed array index %ld out of bounds"),
2587                          (long) idx);
2588           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2589           elt_total_bit_offset += (idx - lowerbound) * bits;
2590           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2591         }
2592     }
2593   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2594   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2595
2596   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2597                                       bits, elt_type);
2598   return v;
2599 }
2600
2601 /* Non-zero iff TYPE includes negative integer values.  */
2602
2603 static int
2604 has_negatives (struct type *type)
2605 {
2606   switch (type->code ())
2607     {
2608     default:
2609       return 0;
2610     case TYPE_CODE_INT:
2611       return !type->is_unsigned ();
2612     case TYPE_CODE_RANGE:
2613       return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2614     }
2615 }
2616
2617 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2618    unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
2619    the unpacked buffer.
2620
2621    The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2622    enough to contain at least BIT_OFFSET bits.  If not, an error is raised.
2623
2624    IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2625    zero otherwise.
2626
2627    IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2628
2629    IS_SCALAR is nonzero if the data corresponds to a signed type.  */
2630
2631 static void
2632 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2633                           gdb_byte *unpacked, int unpacked_len,
2634                           int is_big_endian, int is_signed_type,
2635                           int is_scalar)
2636 {
2637   int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2638   int src_idx;                  /* Index into the source area */
2639   int src_bytes_left;           /* Number of source bytes left to process.  */
2640   int srcBitsLeft;              /* Number of source bits left to move */
2641   int unusedLS;                 /* Number of bits in next significant
2642                                    byte of source that are unused */
2643
2644   int unpacked_idx;             /* Index into the unpacked buffer */
2645   int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */
2646
2647   unsigned long accum;          /* Staging area for bits being transferred */
2648   int accumSize;                /* Number of meaningful bits in accum */
2649   unsigned char sign;
2650
2651   /* Transmit bytes from least to most significant; delta is the direction
2652      the indices move.  */
2653   int delta = is_big_endian ? -1 : 1;
2654
2655   /* Make sure that unpacked is large enough to receive the BIT_SIZE
2656      bits from SRC.  .*/
2657   if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2658     error (_("Cannot unpack %d bits into buffer of %d bytes"),
2659            bit_size, unpacked_len);
2660
2661   srcBitsLeft = bit_size;
2662   src_bytes_left = src_len;
2663   unpacked_bytes_left = unpacked_len;
2664   sign = 0;
2665
2666   if (is_big_endian)
2667     {
2668       src_idx = src_len - 1;
2669       if (is_signed_type
2670           && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2671         sign = ~0;
2672
2673       unusedLS =
2674         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2675         % HOST_CHAR_BIT;
2676
2677       if (is_scalar)
2678         {
2679           accumSize = 0;
2680           unpacked_idx = unpacked_len - 1;
2681         }
2682       else
2683         {
2684           /* Non-scalar values must be aligned at a byte boundary...  */
2685           accumSize =
2686             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2687           /* ... And are placed at the beginning (most-significant) bytes
2688              of the target.  */
2689           unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2690           unpacked_bytes_left = unpacked_idx + 1;
2691         }
2692     }
2693   else
2694     {
2695       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2696
2697       src_idx = unpacked_idx = 0;
2698       unusedLS = bit_offset;
2699       accumSize = 0;
2700
2701       if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2702         sign = ~0;
2703     }
2704
2705   accum = 0;
2706   while (src_bytes_left > 0)
2707     {
2708       /* Mask for removing bits of the next source byte that are not
2709          part of the value.  */
2710       unsigned int unusedMSMask =
2711         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2712         1;
2713       /* Sign-extend bits for this byte.  */
2714       unsigned int signMask = sign & ~unusedMSMask;
2715
2716       accum |=
2717         (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2718       accumSize += HOST_CHAR_BIT - unusedLS;
2719       if (accumSize >= HOST_CHAR_BIT)
2720         {
2721           unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2722           accumSize -= HOST_CHAR_BIT;
2723           accum >>= HOST_CHAR_BIT;
2724           unpacked_bytes_left -= 1;
2725           unpacked_idx += delta;
2726         }
2727       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2728       unusedLS = 0;
2729       src_bytes_left -= 1;
2730       src_idx += delta;
2731     }
2732   while (unpacked_bytes_left > 0)
2733     {
2734       accum |= sign << accumSize;
2735       unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2736       accumSize -= HOST_CHAR_BIT;
2737       if (accumSize < 0)
2738         accumSize = 0;
2739       accum >>= HOST_CHAR_BIT;
2740       unpacked_bytes_left -= 1;
2741       unpacked_idx += delta;
2742     }
2743 }
2744
2745 /* Create a new value of type TYPE from the contents of OBJ starting
2746    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2747    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2748    assigning through the result will set the field fetched from.
2749    VALADDR is ignored unless OBJ is NULL, in which case,
2750    VALADDR+OFFSET must address the start of storage containing the 
2751    packed value.  The value returned  in this case is never an lval.
2752    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2753
2754 struct value *
2755 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2756                                 long offset, int bit_offset, int bit_size,
2757                                 struct type *type)
2758 {
2759   struct value *v;
2760   const gdb_byte *src;                /* First byte containing data to unpack */
2761   gdb_byte *unpacked;
2762   const int is_scalar = is_scalar_type (type);
2763   const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2764   gdb::byte_vector staging;
2765
2766   type = ada_check_typedef (type);
2767
2768   if (obj == NULL)
2769     src = valaddr + offset;
2770   else
2771     src = value_contents (obj).data () + offset;
2772
2773   if (is_dynamic_type (type))
2774     {
2775       /* The length of TYPE might by dynamic, so we need to resolve
2776          TYPE in order to know its actual size, which we then use
2777          to create the contents buffer of the value we return.
2778          The difficulty is that the data containing our object is
2779          packed, and therefore maybe not at a byte boundary.  So, what
2780          we do, is unpack the data into a byte-aligned buffer, and then
2781          use that buffer as our object's value for resolving the type.  */
2782       int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2783       staging.resize (staging_len);
2784
2785       ada_unpack_from_contents (src, bit_offset, bit_size,
2786                                 staging.data (), staging.size (),
2787                                 is_big_endian, has_negatives (type),
2788                                 is_scalar);
2789       type = resolve_dynamic_type (type, staging, 0);
2790       if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2791         {
2792           /* This happens when the length of the object is dynamic,
2793              and is actually smaller than the space reserved for it.
2794              For instance, in an array of variant records, the bit_size
2795              we're given is the array stride, which is constant and
2796              normally equal to the maximum size of its element.
2797              But, in reality, each element only actually spans a portion
2798              of that stride.  */
2799           bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2800         }
2801     }
2802
2803   if (obj == NULL)
2804     {
2805       v = allocate_value (type);
2806       src = valaddr + offset;
2807     }
2808   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2809     {
2810       int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2811       gdb_byte *buf;
2812
2813       v = value_at (type, value_address (obj) + offset);
2814       buf = (gdb_byte *) alloca (src_len);
2815       read_memory (value_address (v), buf, src_len);
2816       src = buf;
2817     }
2818   else
2819     {
2820       v = allocate_value (type);
2821       src = value_contents (obj).data () + offset;
2822     }
2823
2824   if (obj != NULL)
2825     {
2826       long new_offset = offset;
2827
2828       set_value_component_location (v, obj);
2829       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2830       set_value_bitsize (v, bit_size);
2831       if (value_bitpos (v) >= HOST_CHAR_BIT)
2832         {
2833           ++new_offset;
2834           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2835         }
2836       set_value_offset (v, new_offset);
2837
2838       /* Also set the parent value.  This is needed when trying to
2839          assign a new value (in inferior memory).  */
2840       set_value_parent (v, obj);
2841     }
2842   else
2843     set_value_bitsize (v, bit_size);
2844   unpacked = value_contents_writeable (v).data ();
2845
2846   if (bit_size == 0)
2847     {
2848       memset (unpacked, 0, TYPE_LENGTH (type));
2849       return v;
2850     }
2851
2852   if (staging.size () == TYPE_LENGTH (type))
2853     {
2854       /* Small short-cut: If we've unpacked the data into a buffer
2855          of the same size as TYPE's length, then we can reuse that,
2856          instead of doing the unpacking again.  */
2857       memcpy (unpacked, staging.data (), staging.size ());
2858     }
2859   else
2860     ada_unpack_from_contents (src, bit_offset, bit_size,
2861                               unpacked, TYPE_LENGTH (type),
2862                               is_big_endian, has_negatives (type), is_scalar);
2863
2864   return v;
2865 }
2866
2867 /* Store the contents of FROMVAL into the location of TOVAL.
2868    Return a new value with the location of TOVAL and contents of
2869    FROMVAL.   Handles assignment into packed fields that have
2870    floating-point or non-scalar types.  */
2871
2872 static struct value *
2873 ada_value_assign (struct value *toval, struct value *fromval)
2874 {
2875   struct type *type = value_type (toval);
2876   int bits = value_bitsize (toval);
2877
2878   toval = ada_coerce_ref (toval);
2879   fromval = ada_coerce_ref (fromval);
2880
2881   if (ada_is_direct_array_type (value_type (toval)))
2882     toval = ada_coerce_to_simple_array (toval);
2883   if (ada_is_direct_array_type (value_type (fromval)))
2884     fromval = ada_coerce_to_simple_array (fromval);
2885
2886   if (!deprecated_value_modifiable (toval))
2887     error (_("Left operand of assignment is not a modifiable lvalue."));
2888
2889   if (VALUE_LVAL (toval) == lval_memory
2890       && bits > 0
2891       && (type->code () == TYPE_CODE_FLT
2892           || type->code () == TYPE_CODE_STRUCT))
2893     {
2894       int len = (value_bitpos (toval)
2895                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2896       int from_size;
2897       gdb_byte *buffer = (gdb_byte *) alloca (len);
2898       struct value *val;
2899       CORE_ADDR to_addr = value_address (toval);
2900
2901       if (type->code () == TYPE_CODE_FLT)
2902         fromval = value_cast (type, fromval);
2903
2904       read_memory (to_addr, buffer, len);
2905       from_size = value_bitsize (fromval);
2906       if (from_size == 0)
2907         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2908
2909       const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2910       ULONGEST from_offset = 0;
2911       if (is_big_endian && is_scalar_type (value_type (fromval)))
2912         from_offset = from_size - bits;
2913       copy_bitwise (buffer, value_bitpos (toval),
2914                     value_contents (fromval).data (), from_offset,
2915                     bits, is_big_endian);
2916       write_memory_with_notification (to_addr, buffer, len);
2917
2918       val = value_copy (toval);
2919       memcpy (value_contents_raw (val).data (),
2920               value_contents (fromval).data (),
2921               TYPE_LENGTH (type));
2922       deprecated_set_value_type (val, type);
2923
2924       return val;
2925     }
2926
2927   return value_assign (toval, fromval);
2928 }
2929
2930
2931 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2932    CONTAINER, assign the contents of VAL to COMPONENTS's place in
2933    CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2934    COMPONENT, and not the inferior's memory.  The current contents
2935    of COMPONENT are ignored.
2936
2937    Although not part of the initial design, this function also works
2938    when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2939    had a null address, and COMPONENT had an address which is equal to
2940    its offset inside CONTAINER.  */
2941
2942 static void
2943 value_assign_to_component (struct value *container, struct value *component,
2944                            struct value *val)
2945 {
2946   LONGEST offset_in_container =
2947     (LONGEST)  (value_address (component) - value_address (container));
2948   int bit_offset_in_container =
2949     value_bitpos (component) - value_bitpos (container);
2950   int bits;
2951
2952   val = value_cast (value_type (component), val);
2953
2954   if (value_bitsize (component) == 0)
2955     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2956   else
2957     bits = value_bitsize (component);
2958
2959   if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2960     {
2961       int src_offset;
2962
2963       if (is_scalar_type (check_typedef (value_type (component))))
2964         src_offset
2965           = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2966       else
2967         src_offset = 0;
2968       copy_bitwise ((value_contents_writeable (container).data ()
2969                      + offset_in_container),
2970                     value_bitpos (container) + bit_offset_in_container,
2971                     value_contents (val).data (), src_offset, bits, 1);
2972     }
2973   else
2974     copy_bitwise ((value_contents_writeable (container).data ()
2975                    + offset_in_container),
2976                   value_bitpos (container) + bit_offset_in_container,
2977                   value_contents (val).data (), 0, bits, 0);
2978 }
2979
2980 /* Determine if TYPE is an access to an unconstrained array.  */
2981
2982 bool
2983 ada_is_access_to_unconstrained_array (struct type *type)
2984 {
2985   return (type->code () == TYPE_CODE_TYPEDEF
2986           && is_thick_pntr (ada_typedef_target_type (type)));
2987 }
2988
2989 /* The value of the element of array ARR at the ARITY indices given in IND.
2990    ARR may be either a simple array, GNAT array descriptor, or pointer
2991    thereto.  */
2992
2993 struct value *
2994 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2995 {
2996   int k;
2997   struct value *elt;
2998   struct type *elt_type;
2999
3000   elt = ada_coerce_to_simple_array (arr);
3001
3002   elt_type = ada_check_typedef (value_type (elt));
3003   if (elt_type->code () == TYPE_CODE_ARRAY
3004       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
3005     return value_subscript_packed (elt, arity, ind);
3006
3007   for (k = 0; k < arity; k += 1)
3008     {
3009       struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
3010
3011       if (elt_type->code () != TYPE_CODE_ARRAY)
3012         error (_("too many subscripts (%d expected)"), k);
3013
3014       elt = value_subscript (elt, pos_atr (ind[k]));
3015
3016       if (ada_is_access_to_unconstrained_array (saved_elt_type)
3017           && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
3018         {
3019           /* The element is a typedef to an unconstrained array,
3020              except that the value_subscript call stripped the
3021              typedef layer.  The typedef layer is GNAT's way to
3022              specify that the element is, at the source level, an
3023              access to the unconstrained array, rather than the
3024              unconstrained array.  So, we need to restore that
3025              typedef layer, which we can do by forcing the element's
3026              type back to its original type. Otherwise, the returned
3027              value is going to be printed as the array, rather
3028              than as an access.  Another symptom of the same issue
3029              would be that an expression trying to dereference the
3030              element would also be improperly rejected.  */
3031           deprecated_set_value_type (elt, saved_elt_type);
3032         }
3033
3034       elt_type = ada_check_typedef (value_type (elt));
3035     }
3036
3037   return elt;
3038 }
3039
3040 /* Assuming ARR is a pointer to a GDB array, the value of the element
3041    of *ARR at the ARITY indices given in IND.
3042    Does not read the entire array into memory.
3043
3044    Note: Unlike what one would expect, this function is used instead of
3045    ada_value_subscript for basically all non-packed array types.  The reason
3046    for this is that a side effect of doing our own pointer arithmetics instead
3047    of relying on value_subscript is that there is no implicit typedef peeling.
3048    This is important for arrays of array accesses, where it allows us to
3049    preserve the fact that the array's element is an array access, where the
3050    access part os encoded in a typedef layer.  */
3051
3052 static struct value *
3053 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
3054 {
3055   int k;
3056   struct value *array_ind = ada_value_ind (arr);
3057   struct type *type
3058     = check_typedef (value_enclosing_type (array_ind));
3059
3060   if (type->code () == TYPE_CODE_ARRAY
3061       && TYPE_FIELD_BITSIZE (type, 0) > 0)
3062     return value_subscript_packed (array_ind, arity, ind);
3063
3064   for (k = 0; k < arity; k += 1)
3065     {
3066       LONGEST lwb, upb;
3067
3068       if (type->code () != TYPE_CODE_ARRAY)
3069         error (_("too many subscripts (%d expected)"), k);
3070       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
3071                         value_copy (arr));
3072       get_discrete_bounds (type->index_type (), &lwb, &upb);
3073       arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
3074       type = TYPE_TARGET_TYPE (type);
3075     }
3076
3077   return value_ind (arr);
3078 }
3079
3080 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
3081    actual type of ARRAY_PTR is ignored), returns the Ada slice of
3082    HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
3083    this array is LOW, as per Ada rules.  */
3084 static struct value *
3085 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
3086                           int low, int high)
3087 {
3088   struct type *type0 = ada_check_typedef (type);
3089   struct type *base_index_type = TYPE_TARGET_TYPE (type0->index_type ());
3090   struct type *index_type
3091     = create_static_range_type (NULL, base_index_type, low, high);
3092   struct type *slice_type = create_array_type_with_stride
3093                               (NULL, TYPE_TARGET_TYPE (type0), index_type,
3094                                type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
3095                                TYPE_FIELD_BITSIZE (type0, 0));
3096   int base_low =  ada_discrete_type_low_bound (type0->index_type ());
3097   gdb::optional<LONGEST> base_low_pos, low_pos;
3098   CORE_ADDR base;
3099
3100   low_pos = discrete_position (base_index_type, low);
3101   base_low_pos = discrete_position (base_index_type, base_low);
3102
3103   if (!low_pos.has_value () || !base_low_pos.has_value ())
3104     {
3105       warning (_("unable to get positions in slice, use bounds instead"));
3106       low_pos = low;
3107       base_low_pos = base_low;
3108     }
3109
3110   ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
3111   if (stride == 0)
3112     stride = TYPE_LENGTH (TYPE_TARGET_TYPE (type0));
3113
3114   base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
3115   return value_at_lazy (slice_type, base);
3116 }
3117
3118
3119 static struct value *
3120 ada_value_slice (struct value *array, int low, int high)
3121 {
3122   struct type *type = ada_check_typedef (value_type (array));
3123   struct type *base_index_type = TYPE_TARGET_TYPE (type->index_type ());
3124   struct type *index_type
3125     = create_static_range_type (NULL, type->index_type (), low, high);
3126   struct type *slice_type = create_array_type_with_stride
3127                               (NULL, TYPE_TARGET_TYPE (type), index_type,
3128                                type->dyn_prop (DYN_PROP_BYTE_STRIDE),
3129                                TYPE_FIELD_BITSIZE (type, 0));
3130   gdb::optional<LONGEST> low_pos, high_pos;
3131
3132
3133   low_pos = discrete_position (base_index_type, low);
3134   high_pos = discrete_position (base_index_type, high);
3135
3136   if (!low_pos.has_value () || !high_pos.has_value ())
3137     {
3138       warning (_("unable to get positions in slice, use bounds instead"));
3139       low_pos = low;
3140       high_pos = high;
3141     }
3142
3143   return value_cast (slice_type,
3144                      value_slice (array, low, *high_pos - *low_pos + 1));
3145 }
3146
3147 /* If type is a record type in the form of a standard GNAT array
3148    descriptor, returns the number of dimensions for type.  If arr is a
3149    simple array, returns the number of "array of"s that prefix its
3150    type designation.  Otherwise, returns 0.  */
3151
3152 int
3153 ada_array_arity (struct type *type)
3154 {
3155   int arity;
3156
3157   if (type == NULL)
3158     return 0;
3159
3160   type = desc_base_type (type);
3161
3162   arity = 0;
3163   if (type->code () == TYPE_CODE_STRUCT)
3164     return desc_arity (desc_bounds_type (type));
3165   else
3166     while (type->code () == TYPE_CODE_ARRAY)
3167       {
3168         arity += 1;
3169         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
3170       }
3171
3172   return arity;
3173 }
3174
3175 /* If TYPE is a record type in the form of a standard GNAT array
3176    descriptor or a simple array type, returns the element type for
3177    TYPE after indexing by NINDICES indices, or by all indices if
3178    NINDICES is -1.  Otherwise, returns NULL.  */
3179
3180 struct type *
3181 ada_array_element_type (struct type *type, int nindices)
3182 {
3183   type = desc_base_type (type);
3184
3185   if (type->code () == TYPE_CODE_STRUCT)
3186     {
3187       int k;
3188       struct type *p_array_type;
3189
3190       p_array_type = desc_data_target_type (type);
3191
3192       k = ada_array_arity (type);
3193       if (k == 0)
3194         return NULL;
3195
3196       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
3197       if (nindices >= 0 && k > nindices)
3198         k = nindices;
3199       while (k > 0 && p_array_type != NULL)
3200         {
3201           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
3202           k -= 1;
3203         }
3204       return p_array_type;
3205     }
3206   else if (type->code () == TYPE_CODE_ARRAY)
3207     {
3208       while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
3209         {
3210           type = TYPE_TARGET_TYPE (type);
3211           nindices -= 1;
3212         }
3213       return type;
3214     }
3215
3216   return NULL;
3217 }
3218
3219 /* See ada-lang.h.  */
3220
3221 struct type *
3222 ada_index_type (struct type *type, int n, const char *name)
3223 {
3224   struct type *result_type;
3225
3226   type = desc_base_type (type);
3227
3228   if (n < 0 || n > ada_array_arity (type))
3229     error (_("invalid dimension number to '%s"), name);
3230
3231   if (ada_is_simple_array_type (type))
3232     {
3233       int i;
3234
3235       for (i = 1; i < n; i += 1)
3236         {
3237           type = ada_check_typedef (type);
3238           type = TYPE_TARGET_TYPE (type);
3239         }
3240       result_type = TYPE_TARGET_TYPE (ada_check_typedef (type)->index_type ());
3241       /* FIXME: The stabs type r(0,0);bound;bound in an array type
3242          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
3243          perhaps stabsread.c would make more sense.  */
3244       if (result_type && result_type->code () == TYPE_CODE_UNDEF)
3245         result_type = NULL;
3246     }
3247   else
3248     {
3249       result_type = desc_index_type (desc_bounds_type (type), n);
3250       if (result_type == NULL)
3251         error (_("attempt to take bound of something that is not an array"));
3252     }
3253
3254   return result_type;
3255 }
3256
3257 /* Given that arr is an array type, returns the lower bound of the
3258    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3259    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
3260    array-descriptor type.  It works for other arrays with bounds supplied
3261    by run-time quantities other than discriminants.  */
3262
3263 static LONGEST
3264 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3265 {
3266   struct type *type, *index_type_desc, *index_type;
3267   int i;
3268
3269   gdb_assert (which == 0 || which == 1);
3270
3271   if (ada_is_constrained_packed_array_type (arr_type))
3272     arr_type = decode_constrained_packed_array_type (arr_type);
3273
3274   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3275     return (LONGEST) - which;
3276
3277   if (arr_type->code () == TYPE_CODE_PTR)
3278     type = TYPE_TARGET_TYPE (arr_type);
3279   else
3280     type = arr_type;
3281
3282   if (type->is_fixed_instance ())
3283     {
3284       /* The array has already been fixed, so we do not need to
3285          check the parallel ___XA type again.  That encoding has
3286          already been applied, so ignore it now.  */
3287       index_type_desc = NULL;
3288     }
3289   else
3290     {
3291       index_type_desc = ada_find_parallel_type (type, "___XA");
3292       ada_fixup_array_indexes_type (index_type_desc);
3293     }
3294
3295   if (index_type_desc != NULL)
3296     index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
3297                                       NULL);
3298   else
3299     {
3300       struct type *elt_type = check_typedef (type);
3301
3302       for (i = 1; i < n; i++)
3303         elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3304
3305       index_type = elt_type->index_type ();
3306     }
3307
3308   return
3309     (LONGEST) (which == 0
3310                ? ada_discrete_type_low_bound (index_type)
3311                : ada_discrete_type_high_bound (index_type));
3312 }
3313
3314 /* Given that arr is an array value, returns the lower bound of the
3315    nth index (numbering from 1) if WHICH is 0, and the upper bound if
3316    WHICH is 1.  This routine will also work for arrays with bounds
3317    supplied by run-time quantities other than discriminants.  */
3318
3319 static LONGEST
3320 ada_array_bound (struct value *arr, int n, int which)
3321 {
3322   struct type *arr_type;
3323
3324   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3325     arr = value_ind (arr);
3326   arr_type = value_enclosing_type (arr);
3327
3328   if (ada_is_constrained_packed_array_type (arr_type))
3329     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3330   else if (ada_is_simple_array_type (arr_type))
3331     return ada_array_bound_from_type (arr_type, n, which);
3332   else
3333     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3334 }
3335
3336 /* Given that arr is an array value, returns the length of the
3337    nth index.  This routine will also work for arrays with bounds
3338    supplied by run-time quantities other than discriminants.
3339    Does not work for arrays indexed by enumeration types with representation
3340    clauses at the moment.  */
3341
3342 static LONGEST
3343 ada_array_length (struct value *arr, int n)
3344 {
3345   struct type *arr_type, *index_type;
3346   int low, high;
3347
3348   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3349     arr = value_ind (arr);
3350   arr_type = value_enclosing_type (arr);
3351
3352   if (ada_is_constrained_packed_array_type (arr_type))
3353     return ada_array_length (decode_constrained_packed_array (arr), n);
3354
3355   if (ada_is_simple_array_type (arr_type))
3356     {
3357       low = ada_array_bound_from_type (arr_type, n, 0);
3358       high = ada_array_bound_from_type (arr_type, n, 1);
3359     }
3360   else
3361     {
3362       low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3363       high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3364     }
3365
3366   arr_type = check_typedef (arr_type);
3367   index_type = ada_index_type (arr_type, n, "length");
3368   if (index_type != NULL)
3369     {
3370       struct type *base_type;
3371       if (index_type->code () == TYPE_CODE_RANGE)
3372         base_type = TYPE_TARGET_TYPE (index_type);
3373       else
3374         base_type = index_type;
3375
3376       low = pos_atr (value_from_longest (base_type, low));
3377       high = pos_atr (value_from_longest (base_type, high));
3378     }
3379   return high - low + 1;
3380 }
3381
3382 /* An array whose type is that of ARR_TYPE (an array type), with
3383    bounds LOW to HIGH, but whose contents are unimportant.  If HIGH is
3384    less than LOW, then LOW-1 is used.  */
3385
3386 static struct value *
3387 empty_array (struct type *arr_type, int low, int high)
3388 {
3389   struct type *arr_type0 = ada_check_typedef (arr_type);
3390   struct type *index_type
3391     = create_static_range_type
3392         (NULL, TYPE_TARGET_TYPE (arr_type0->index_type ()), low,
3393          high < low ? low - 1 : high);
3394   struct type *elt_type = ada_array_element_type (arr_type0, 1);
3395
3396   return allocate_value (create_array_type (NULL, elt_type, index_type));
3397 }
3398 \f
3399
3400                                 /* Name resolution */
3401
3402 /* The "decoded" name for the user-definable Ada operator corresponding
3403    to OP.  */
3404
3405 static const char *
3406 ada_decoded_op_name (enum exp_opcode op)
3407 {
3408   int i;
3409
3410   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3411     {
3412       if (ada_opname_table[i].op == op)
3413         return ada_opname_table[i].decoded;
3414     }
3415   error (_("Could not find operator name for opcode"));
3416 }
3417
3418 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3419    in a listing of choices during disambiguation (see sort_choices, below).
3420    The idea is that overloadings of a subprogram name from the
3421    same package should sort in their source order.  We settle for ordering
3422    such symbols by their trailing number (__N  or $N).  */
3423
3424 static int
3425 encoded_ordered_before (const char *N0, const char *N1)
3426 {
3427   if (N1 == NULL)
3428     return 0;
3429   else if (N0 == NULL)
3430     return 1;
3431   else
3432     {
3433       int k0, k1;
3434
3435       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3436         ;
3437       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3438         ;
3439       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3440           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3441         {
3442           int n0, n1;
3443
3444           n0 = k0;
3445           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3446             n0 -= 1;
3447           n1 = k1;
3448           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3449             n1 -= 1;
3450           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3451             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3452         }
3453       return (strcmp (N0, N1) < 0);
3454     }
3455 }
3456
3457 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3458    encoded names.  */
3459
3460 static void
3461 sort_choices (struct block_symbol syms[], int nsyms)
3462 {
3463   int i;
3464
3465   for (i = 1; i < nsyms; i += 1)
3466     {
3467       struct block_symbol sym = syms[i];
3468       int j;
3469
3470       for (j = i - 1; j >= 0; j -= 1)
3471         {
3472           if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3473                                       sym.symbol->linkage_name ()))
3474             break;
3475           syms[j + 1] = syms[j];
3476         }
3477       syms[j + 1] = sym;
3478     }
3479 }
3480
3481 /* Whether GDB should display formals and return types for functions in the
3482    overloads selection menu.  */
3483 static bool print_signatures = true;
3484
3485 /* Print the signature for SYM on STREAM according to the FLAGS options.  For
3486    all but functions, the signature is just the name of the symbol.  For
3487    functions, this is the name of the function, the list of types for formals
3488    and the return type (if any).  */
3489
3490 static void
3491 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3492                             const struct type_print_options *flags)
3493 {
3494   struct type *type = sym->type ();
3495
3496   gdb_printf (stream, "%s", sym->print_name ());
3497   if (!print_signatures
3498       || type == NULL
3499       || type->code () != TYPE_CODE_FUNC)
3500     return;
3501
3502   if (type->num_fields () > 0)
3503     {
3504       int i;
3505
3506       gdb_printf (stream, " (");
3507       for (i = 0; i < type->num_fields (); ++i)
3508         {
3509           if (i > 0)
3510             gdb_printf (stream, "; ");
3511           ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3512                           flags);
3513         }
3514       gdb_printf (stream, ")");
3515     }
3516   if (TYPE_TARGET_TYPE (type) != NULL
3517       && TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_VOID)
3518     {
3519       gdb_printf (stream, " return ");
3520       ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3521     }
3522 }
3523
3524 /* Read and validate a set of numeric choices from the user in the
3525    range 0 .. N_CHOICES-1.  Place the results in increasing
3526    order in CHOICES[0 .. N-1], and return N.
3527
3528    The user types choices as a sequence of numbers on one line
3529    separated by blanks, encoding them as follows:
3530
3531      + A choice of 0 means to cancel the selection, throwing an error.
3532      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3533      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3534
3535    The user is not allowed to choose more than MAX_RESULTS values.
3536
3537    ANNOTATION_SUFFIX, if present, is used to annotate the input
3538    prompts (for use with the -f switch).  */
3539
3540 static int
3541 get_selections (int *choices, int n_choices, int max_results,
3542                 int is_all_choice, const char *annotation_suffix)
3543 {
3544   const char *args;
3545   const char *prompt;
3546   int n_chosen;
3547   int first_choice = is_all_choice ? 2 : 1;
3548
3549   prompt = getenv ("PS2");
3550   if (prompt == NULL)
3551     prompt = "> ";
3552
3553   args = command_line_input (prompt, annotation_suffix);
3554
3555   if (args == NULL)
3556     error_no_arg (_("one or more choice numbers"));
3557
3558   n_chosen = 0;
3559
3560   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3561      order, as given in args.  Choices are validated.  */
3562   while (1)
3563     {
3564       char *args2;
3565       int choice, j;
3566
3567       args = skip_spaces (args);
3568       if (*args == '\0' && n_chosen == 0)
3569         error_no_arg (_("one or more choice numbers"));
3570       else if (*args == '\0')
3571         break;
3572
3573       choice = strtol (args, &args2, 10);
3574       if (args == args2 || choice < 0
3575           || choice > n_choices + first_choice - 1)
3576         error (_("Argument must be choice number"));
3577       args = args2;
3578
3579       if (choice == 0)
3580         error (_("cancelled"));
3581
3582       if (choice < first_choice)
3583         {
3584           n_chosen = n_choices;
3585           for (j = 0; j < n_choices; j += 1)
3586             choices[j] = j;
3587           break;
3588         }
3589       choice -= first_choice;
3590
3591       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3592         {
3593         }
3594
3595       if (j < 0 || choice != choices[j])
3596         {
3597           int k;
3598
3599           for (k = n_chosen - 1; k > j; k -= 1)
3600             choices[k + 1] = choices[k];
3601           choices[j + 1] = choice;
3602           n_chosen += 1;
3603         }
3604     }
3605
3606   if (n_chosen > max_results)
3607     error (_("Select no more than %d of the above"), max_results);
3608
3609   return n_chosen;
3610 }
3611
3612 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3613    by asking the user (if necessary), returning the number selected,
3614    and setting the first elements of SYMS items.  Error if no symbols
3615    selected.  */
3616
3617 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3618    to be re-integrated one of these days.  */
3619
3620 static int
3621 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3622 {
3623   int i;
3624   int *chosen = XALLOCAVEC (int , nsyms);
3625   int n_chosen;
3626   int first_choice = (max_results == 1) ? 1 : 2;
3627   const char *select_mode = multiple_symbols_select_mode ();
3628
3629   if (max_results < 1)
3630     error (_("Request to select 0 symbols!"));
3631   if (nsyms <= 1)
3632     return nsyms;
3633
3634   if (select_mode == multiple_symbols_cancel)
3635     error (_("\
3636 canceled because the command is ambiguous\n\
3637 See set/show multiple-symbol."));
3638
3639   /* If select_mode is "all", then return all possible symbols.
3640      Only do that if more than one symbol can be selected, of course.
3641      Otherwise, display the menu as usual.  */
3642   if (select_mode == multiple_symbols_all && max_results > 1)
3643     return nsyms;
3644
3645   gdb_printf (_("[0] cancel\n"));
3646   if (max_results > 1)
3647     gdb_printf (_("[1] all\n"));
3648
3649   sort_choices (syms, nsyms);
3650
3651   for (i = 0; i < nsyms; i += 1)
3652     {
3653       if (syms[i].symbol == NULL)
3654         continue;
3655
3656       if (syms[i].symbol->aclass () == LOC_BLOCK)
3657         {
3658           struct symtab_and_line sal =
3659             find_function_start_sal (syms[i].symbol, 1);
3660
3661           gdb_printf ("[%d] ", i + first_choice);
3662           ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3663                                       &type_print_raw_options);
3664           if (sal.symtab == NULL)
3665             gdb_printf (_(" at %p[<no source file available>%p]:%d\n"),
3666                         metadata_style.style ().ptr (), nullptr, sal.line);
3667           else
3668             gdb_printf
3669               (_(" at %ps:%d\n"),
3670                styled_string (file_name_style.style (),
3671                               symtab_to_filename_for_display (sal.symtab)),
3672                sal.line);
3673           continue;
3674         }
3675       else
3676         {
3677           int is_enumeral =
3678             (syms[i].symbol->aclass () == LOC_CONST
3679              && syms[i].symbol->type () != NULL
3680              && syms[i].symbol->type ()->code () == TYPE_CODE_ENUM);
3681           struct symtab *symtab = NULL;
3682
3683           if (syms[i].symbol->is_objfile_owned ())
3684             symtab = symbol_symtab (syms[i].symbol);
3685
3686           if (syms[i].symbol->line () != 0 && symtab != NULL)
3687             {
3688               gdb_printf ("[%d] ", i + first_choice);
3689               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3690                                           &type_print_raw_options);
3691               gdb_printf (_(" at %s:%d\n"),
3692                           symtab_to_filename_for_display (symtab),
3693                           syms[i].symbol->line ());
3694             }
3695           else if (is_enumeral
3696                    && syms[i].symbol->type ()->name () != NULL)
3697             {
3698               gdb_printf (("[%d] "), i + first_choice);
3699               ada_print_type (syms[i].symbol->type (), NULL,
3700                               gdb_stdout, -1, 0, &type_print_raw_options);
3701               gdb_printf (_("'(%s) (enumeral)\n"),
3702                           syms[i].symbol->print_name ());
3703             }
3704           else
3705             {
3706               gdb_printf ("[%d] ", i + first_choice);
3707               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3708                                           &type_print_raw_options);
3709
3710               if (symtab != NULL)
3711                 gdb_printf (is_enumeral
3712                             ? _(" in %s (enumeral)\n")
3713                             : _(" at %s:?\n"),
3714                             symtab_to_filename_for_display (symtab));
3715               else
3716                 gdb_printf (is_enumeral
3717                             ? _(" (enumeral)\n")
3718                             : _(" at ?\n"));
3719             }
3720         }
3721     }
3722
3723   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3724                              "overload-choice");
3725
3726   for (i = 0; i < n_chosen; i += 1)
3727     syms[i] = syms[chosen[i]];
3728
3729   return n_chosen;
3730 }
3731
3732 /* See ada-lang.h.  */
3733
3734 block_symbol
3735 ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
3736                           int nargs, value *argvec[])
3737 {
3738   if (possible_user_operator_p (op, argvec))
3739     {
3740       std::vector<struct block_symbol> candidates
3741         = ada_lookup_symbol_list (ada_decoded_op_name (op),
3742                                   NULL, VAR_DOMAIN);
3743
3744       int i = ada_resolve_function (candidates, argvec,
3745                                     nargs, ada_decoded_op_name (op), NULL,
3746                                     parse_completion);
3747       if (i >= 0)
3748         return candidates[i];
3749     }
3750   return {};
3751 }
3752
3753 /* See ada-lang.h.  */
3754
3755 block_symbol
3756 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3757                      struct type *context_type,
3758                      bool parse_completion,
3759                      int nargs, value *argvec[],
3760                      innermost_block_tracker *tracker)
3761 {
3762   std::vector<struct block_symbol> candidates
3763     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3764
3765   int i;
3766   if (candidates.size () == 1)
3767     i = 0;
3768   else
3769     {
3770       i = ada_resolve_function
3771         (candidates,
3772          argvec, nargs,
3773          sym->linkage_name (),
3774          context_type, parse_completion);
3775       if (i < 0)
3776         error (_("Could not find a match for %s"), sym->print_name ());
3777     }
3778
3779   tracker->update (candidates[i]);
3780   return candidates[i];
3781 }
3782
3783 /* Resolve a mention of a name where the context type is an
3784    enumeration type.  */
3785
3786 static int
3787 ada_resolve_enum (std::vector<struct block_symbol> &syms,
3788                   const char *name, struct type *context_type,
3789                   bool parse_completion)
3790 {
3791   gdb_assert (context_type->code () == TYPE_CODE_ENUM);
3792   context_type = ada_check_typedef (context_type);
3793
3794   for (int i = 0; i < syms.size (); ++i)
3795     {
3796       /* We already know the name matches, so we're just looking for
3797          an element of the correct enum type.  */
3798       if (ada_check_typedef (syms[i].symbol->type ()) == context_type)
3799         return i;
3800     }
3801
3802   error (_("No name '%s' in enumeration type '%s'"), name,
3803          ada_type_name (context_type));
3804 }
3805
3806 /* See ada-lang.h.  */
3807
3808 block_symbol
3809 ada_resolve_variable (struct symbol *sym, const struct block *block,
3810                       struct type *context_type,
3811                       bool parse_completion,
3812                       int deprocedure_p,
3813                       innermost_block_tracker *tracker)
3814 {
3815   std::vector<struct block_symbol> candidates
3816     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3817
3818   if (std::any_of (candidates.begin (),
3819                    candidates.end (),
3820                    [] (block_symbol &bsym)
3821                    {
3822                      switch (bsym.symbol->aclass ())
3823                        {
3824                        case LOC_REGISTER:
3825                        case LOC_ARG:
3826                        case LOC_REF_ARG:
3827                        case LOC_REGPARM_ADDR:
3828                        case LOC_LOCAL:
3829                        case LOC_COMPUTED:
3830                          return true;
3831                        default:
3832                          return false;
3833                        }
3834                    }))
3835     {
3836       /* Types tend to get re-introduced locally, so if there
3837          are any local symbols that are not types, first filter
3838          out all types.  */
3839       candidates.erase
3840         (std::remove_if
3841          (candidates.begin (),
3842           candidates.end (),
3843           [] (block_symbol &bsym)
3844           {
3845             return bsym.symbol->aclass () == LOC_TYPEDEF;
3846           }),
3847          candidates.end ());
3848     }
3849
3850   /* Filter out artificial symbols.  */
3851   candidates.erase
3852     (std::remove_if
3853      (candidates.begin (),
3854       candidates.end (),
3855       [] (block_symbol &bsym)
3856       {
3857         return bsym.symbol->is_artificial ();
3858       }),
3859      candidates.end ());
3860
3861   int i;
3862   if (candidates.empty ())
3863     error (_("No definition found for %s"), sym->print_name ());
3864   else if (candidates.size () == 1)
3865     i = 0;
3866   else if (context_type != nullptr
3867            && context_type->code () == TYPE_CODE_ENUM)
3868     i = ada_resolve_enum (candidates, sym->linkage_name (), context_type,
3869                           parse_completion);
3870   else if (deprocedure_p && !is_nonfunction (candidates))
3871     {
3872       i = ada_resolve_function
3873         (candidates, NULL, 0,
3874          sym->linkage_name (),
3875          context_type, parse_completion);
3876       if (i < 0)
3877         error (_("Could not find a match for %s"), sym->print_name ());
3878     }
3879   else
3880     {
3881       gdb_printf (_("Multiple matches for %s\n"), sym->print_name ());
3882       user_select_syms (candidates.data (), candidates.size (), 1);
3883       i = 0;
3884     }
3885
3886   tracker->update (candidates[i]);
3887   return candidates[i];
3888 }
3889
3890 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  */
3891 /* The term "match" here is rather loose.  The match is heuristic and
3892    liberal.  */
3893
3894 static int
3895 ada_type_match (struct type *ftype, struct type *atype)
3896 {
3897   ftype = ada_check_typedef (ftype);
3898   atype = ada_check_typedef (atype);
3899
3900   if (ftype->code () == TYPE_CODE_REF)
3901     ftype = TYPE_TARGET_TYPE (ftype);
3902   if (atype->code () == TYPE_CODE_REF)
3903     atype = TYPE_TARGET_TYPE (atype);
3904
3905   switch (ftype->code ())
3906     {
3907     default:
3908       return ftype->code () == atype->code ();
3909     case TYPE_CODE_PTR:
3910       if (atype->code () != TYPE_CODE_PTR)
3911         return 0;
3912       atype = TYPE_TARGET_TYPE (atype);
3913       /* This can only happen if the actual argument is 'null'.  */
3914       if (atype->code () == TYPE_CODE_INT && TYPE_LENGTH (atype) == 0)
3915         return 1;
3916       return ada_type_match (TYPE_TARGET_TYPE (ftype), atype);
3917     case TYPE_CODE_INT:
3918     case TYPE_CODE_ENUM:
3919     case TYPE_CODE_RANGE:
3920       switch (atype->code ())
3921         {
3922         case TYPE_CODE_INT:
3923         case TYPE_CODE_ENUM:
3924         case TYPE_CODE_RANGE:
3925           return 1;
3926         default:
3927           return 0;
3928         }
3929
3930     case TYPE_CODE_ARRAY:
3931       return (atype->code () == TYPE_CODE_ARRAY
3932               || ada_is_array_descriptor_type (atype));
3933
3934     case TYPE_CODE_STRUCT:
3935       if (ada_is_array_descriptor_type (ftype))
3936         return (atype->code () == TYPE_CODE_ARRAY
3937                 || ada_is_array_descriptor_type (atype));
3938       else
3939         return (atype->code () == TYPE_CODE_STRUCT
3940                 && !ada_is_array_descriptor_type (atype));
3941
3942     case TYPE_CODE_UNION:
3943     case TYPE_CODE_FLT:
3944       return (atype->code () == ftype->code ());
3945     }
3946 }
3947
3948 /* Return non-zero if the formals of FUNC "sufficiently match" the
3949    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3950    may also be an enumeral, in which case it is treated as a 0-
3951    argument function.  */
3952
3953 static int
3954 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3955 {
3956   int i;
3957   struct type *func_type = func->type ();
3958
3959   if (func->aclass () == LOC_CONST
3960       && func_type->code () == TYPE_CODE_ENUM)
3961     return (n_actuals == 0);
3962   else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3963     return 0;
3964
3965   if (func_type->num_fields () != n_actuals)
3966     return 0;
3967
3968   for (i = 0; i < n_actuals; i += 1)
3969     {
3970       if (actuals[i] == NULL)
3971         return 0;
3972       else
3973         {
3974           struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3975           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3976
3977           if (!ada_type_match (ftype, atype))
3978             return 0;
3979         }
3980     }
3981   return 1;
3982 }
3983
3984 /* False iff function type FUNC_TYPE definitely does not produce a value
3985    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3986    FUNC_TYPE is not a valid function type with a non-null return type
3987    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3988
3989 static int
3990 return_match (struct type *func_type, struct type *context_type)
3991 {
3992   struct type *return_type;
3993
3994   if (func_type == NULL)
3995     return 1;
3996
3997   if (func_type->code () == TYPE_CODE_FUNC)
3998     return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3999   else
4000     return_type = get_base_type (func_type);
4001   if (return_type == NULL)
4002     return 1;
4003
4004   context_type = get_base_type (context_type);
4005
4006   if (return_type->code () == TYPE_CODE_ENUM)
4007     return context_type == NULL || return_type == context_type;
4008   else if (context_type == NULL)
4009     return return_type->code () != TYPE_CODE_VOID;
4010   else
4011     return return_type->code () == context_type->code ();
4012 }
4013
4014
4015 /* Returns the index in SYMS that contains the symbol for the
4016    function (if any) that matches the types of the NARGS arguments in
4017    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
4018    that returns that type, then eliminate matches that don't.  If
4019    CONTEXT_TYPE is void and there is at least one match that does not
4020    return void, eliminate all matches that do.
4021
4022    Asks the user if there is more than one match remaining.  Returns -1
4023    if there is no such symbol or none is selected.  NAME is used
4024    solely for messages.  May re-arrange and modify SYMS in
4025    the process; the index returned is for the modified vector.  */
4026
4027 static int
4028 ada_resolve_function (std::vector<struct block_symbol> &syms,
4029                       struct value **args, int nargs,
4030                       const char *name, struct type *context_type,
4031                       bool parse_completion)
4032 {
4033   int fallback;
4034   int k;
4035   int m;                        /* Number of hits */
4036
4037   m = 0;
4038   /* In the first pass of the loop, we only accept functions matching
4039      context_type.  If none are found, we add a second pass of the loop
4040      where every function is accepted.  */
4041   for (fallback = 0; m == 0 && fallback < 2; fallback++)
4042     {
4043       for (k = 0; k < syms.size (); k += 1)
4044         {
4045           struct type *type = ada_check_typedef (syms[k].symbol->type ());
4046
4047           if (ada_args_match (syms[k].symbol, args, nargs)
4048               && (fallback || return_match (type, context_type)))
4049             {
4050               syms[m] = syms[k];
4051               m += 1;
4052             }
4053         }
4054     }
4055
4056   /* If we got multiple matches, ask the user which one to use.  Don't do this
4057      interactive thing during completion, though, as the purpose of the
4058      completion is providing a list of all possible matches.  Prompting the
4059      user to filter it down would be completely unexpected in this case.  */
4060   if (m == 0)
4061     return -1;
4062   else if (m > 1 && !parse_completion)
4063     {
4064       gdb_printf (_("Multiple matches for %s\n"), name);
4065       user_select_syms (syms.data (), m, 1);
4066       return 0;
4067     }
4068   return 0;
4069 }
4070
4071 /* Type-class predicates */
4072
4073 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4074    or FLOAT).  */
4075
4076 static int
4077 numeric_type_p (struct type *type)
4078 {
4079   if (type == NULL)
4080     return 0;
4081   else
4082     {
4083       switch (type->code ())
4084         {
4085         case TYPE_CODE_INT:
4086         case TYPE_CODE_FLT:
4087         case TYPE_CODE_FIXED_POINT:
4088           return 1;
4089         case TYPE_CODE_RANGE:
4090           return (type == TYPE_TARGET_TYPE (type)
4091                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
4092         default:
4093           return 0;
4094         }
4095     }
4096 }
4097
4098 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
4099
4100 static int
4101 integer_type_p (struct type *type)
4102 {
4103   if (type == NULL)
4104     return 0;
4105   else
4106     {
4107       switch (type->code ())
4108         {
4109         case TYPE_CODE_INT:
4110           return 1;
4111         case TYPE_CODE_RANGE:
4112           return (type == TYPE_TARGET_TYPE (type)
4113                   || integer_type_p (TYPE_TARGET_TYPE (type)));
4114         default:
4115           return 0;
4116         }
4117     }
4118 }
4119
4120 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
4121
4122 static int
4123 scalar_type_p (struct type *type)
4124 {
4125   if (type == NULL)
4126     return 0;
4127   else
4128     {
4129       switch (type->code ())
4130         {
4131         case TYPE_CODE_INT:
4132         case TYPE_CODE_RANGE:
4133         case TYPE_CODE_ENUM:
4134         case TYPE_CODE_FLT:
4135         case TYPE_CODE_FIXED_POINT:
4136           return 1;
4137         default:
4138           return 0;
4139         }
4140     }
4141 }
4142
4143 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
4144
4145 static int
4146 discrete_type_p (struct type *type)
4147 {
4148   if (type == NULL)
4149     return 0;
4150   else
4151     {
4152       switch (type->code ())
4153         {
4154         case TYPE_CODE_INT:
4155         case TYPE_CODE_RANGE:
4156         case TYPE_CODE_ENUM:
4157         case TYPE_CODE_BOOL:
4158           return 1;
4159         default:
4160           return 0;
4161         }
4162     }
4163 }
4164
4165 /* Returns non-zero if OP with operands in the vector ARGS could be
4166    a user-defined function.  Errs on the side of pre-defined operators
4167    (i.e., result 0).  */
4168
4169 static int
4170 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4171 {
4172   struct type *type0 =
4173     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4174   struct type *type1 =
4175     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4176
4177   if (type0 == NULL)
4178     return 0;
4179
4180   switch (op)
4181     {
4182     default:
4183       return 0;
4184
4185     case BINOP_ADD:
4186     case BINOP_SUB:
4187     case BINOP_MUL:
4188     case BINOP_DIV:
4189       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4190
4191     case BINOP_REM:
4192     case BINOP_MOD:
4193     case BINOP_BITWISE_AND:
4194     case BINOP_BITWISE_IOR:
4195     case BINOP_BITWISE_XOR:
4196       return (!(integer_type_p (type0) && integer_type_p (type1)));
4197
4198     case BINOP_EQUAL:
4199     case BINOP_NOTEQUAL:
4200     case BINOP_LESS:
4201     case BINOP_GTR:
4202     case BINOP_LEQ:
4203     case BINOP_GEQ:
4204       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4205
4206     case BINOP_CONCAT:
4207       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4208
4209     case BINOP_EXP:
4210       return (!(numeric_type_p (type0) && integer_type_p (type1)));
4211
4212     case UNOP_NEG:
4213     case UNOP_PLUS:
4214     case UNOP_LOGICAL_NOT:
4215     case UNOP_ABS:
4216       return (!numeric_type_p (type0));
4217
4218     }
4219 }
4220 \f
4221                                 /* Renaming */
4222
4223 /* NOTES: 
4224
4225    1. In the following, we assume that a renaming type's name may
4226       have an ___XD suffix.  It would be nice if this went away at some
4227       point.
4228    2. We handle both the (old) purely type-based representation of 
4229       renamings and the (new) variable-based encoding.  At some point,
4230       it is devoutly to be hoped that the former goes away 
4231       (FIXME: hilfinger-2007-07-09).
4232    3. Subprogram renamings are not implemented, although the XRS
4233       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
4234
4235 /* If SYM encodes a renaming, 
4236
4237        <renaming> renames <renamed entity>,
4238
4239    sets *LEN to the length of the renamed entity's name,
4240    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4241    the string describing the subcomponent selected from the renamed
4242    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4243    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4244    are undefined).  Otherwise, returns a value indicating the category
4245    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4246    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4247    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
4248    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4249    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4250    may be NULL, in which case they are not assigned.
4251
4252    [Currently, however, GCC does not generate subprogram renamings.]  */
4253
4254 enum ada_renaming_category
4255 ada_parse_renaming (struct symbol *sym,
4256                     const char **renamed_entity, int *len, 
4257                     const char **renaming_expr)
4258 {
4259   enum ada_renaming_category kind;
4260   const char *info;
4261   const char *suffix;
4262
4263   if (sym == NULL)
4264     return ADA_NOT_RENAMING;
4265   switch (sym->aclass ()) 
4266     {
4267     default:
4268       return ADA_NOT_RENAMING;
4269     case LOC_LOCAL:
4270     case LOC_STATIC:
4271     case LOC_COMPUTED:
4272     case LOC_OPTIMIZED_OUT:
4273       info = strstr (sym->linkage_name (), "___XR");
4274       if (info == NULL)
4275         return ADA_NOT_RENAMING;
4276       switch (info[5])
4277         {
4278         case '_':
4279           kind = ADA_OBJECT_RENAMING;
4280           info += 6;
4281           break;
4282         case 'E':
4283           kind = ADA_EXCEPTION_RENAMING;
4284           info += 7;
4285           break;
4286         case 'P':
4287           kind = ADA_PACKAGE_RENAMING;
4288           info += 7;
4289           break;
4290         case 'S':
4291           kind = ADA_SUBPROGRAM_RENAMING;
4292           info += 7;
4293           break;
4294         default:
4295           return ADA_NOT_RENAMING;
4296         }
4297     }
4298
4299   if (renamed_entity != NULL)
4300     *renamed_entity = info;
4301   suffix = strstr (info, "___XE");
4302   if (suffix == NULL || suffix == info)
4303     return ADA_NOT_RENAMING;
4304   if (len != NULL)
4305     *len = strlen (info) - strlen (suffix);
4306   suffix += 5;
4307   if (renaming_expr != NULL)
4308     *renaming_expr = suffix;
4309   return kind;
4310 }
4311
4312 /* Compute the value of the given RENAMING_SYM, which is expected to
4313    be a symbol encoding a renaming expression.  BLOCK is the block
4314    used to evaluate the renaming.  */
4315
4316 static struct value *
4317 ada_read_renaming_var_value (struct symbol *renaming_sym,
4318                              const struct block *block)
4319 {
4320   const char *sym_name;
4321
4322   sym_name = renaming_sym->linkage_name ();
4323   expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4324   return evaluate_expression (expr.get ());
4325 }
4326 \f
4327
4328                                 /* Evaluation: Function Calls */
4329
4330 /* Return an lvalue containing the value VAL.  This is the identity on
4331    lvalues, and otherwise has the side-effect of allocating memory
4332    in the inferior where a copy of the value contents is copied.  */
4333
4334 static struct value *
4335 ensure_lval (struct value *val)
4336 {
4337   if (VALUE_LVAL (val) == not_lval
4338       || VALUE_LVAL (val) == lval_internalvar)
4339     {
4340       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4341       const CORE_ADDR addr =
4342         value_as_long (value_allocate_space_in_inferior (len));
4343
4344       VALUE_LVAL (val) = lval_memory;
4345       set_value_address (val, addr);
4346       write_memory (addr, value_contents (val).data (), len);
4347     }
4348
4349   return val;
4350 }
4351
4352 /* Given ARG, a value of type (pointer or reference to a)*
4353    structure/union, extract the component named NAME from the ultimate
4354    target structure/union and return it as a value with its
4355    appropriate type.
4356
4357    The routine searches for NAME among all members of the structure itself
4358    and (recursively) among all members of any wrapper members
4359    (e.g., '_parent').
4360
4361    If NO_ERR, then simply return NULL in case of error, rather than
4362    calling error.  */
4363
4364 static struct value *
4365 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
4366 {
4367   struct type *t, *t1;
4368   struct value *v;
4369   int check_tag;
4370
4371   v = NULL;
4372   t1 = t = ada_check_typedef (value_type (arg));
4373   if (t->code () == TYPE_CODE_REF)
4374     {
4375       t1 = TYPE_TARGET_TYPE (t);
4376       if (t1 == NULL)
4377         goto BadValue;
4378       t1 = ada_check_typedef (t1);
4379       if (t1->code () == TYPE_CODE_PTR)
4380         {
4381           arg = coerce_ref (arg);
4382           t = t1;
4383         }
4384     }
4385
4386   while (t->code () == TYPE_CODE_PTR)
4387     {
4388       t1 = TYPE_TARGET_TYPE (t);
4389       if (t1 == NULL)
4390         goto BadValue;
4391       t1 = ada_check_typedef (t1);
4392       if (t1->code () == TYPE_CODE_PTR)
4393         {
4394           arg = value_ind (arg);
4395           t = t1;
4396         }
4397       else
4398         break;
4399     }
4400
4401   if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4402     goto BadValue;
4403
4404   if (t1 == t)
4405     v = ada_search_struct_field (name, arg, 0, t);
4406   else
4407     {
4408       int bit_offset, bit_size, byte_offset;
4409       struct type *field_type;
4410       CORE_ADDR address;
4411
4412       if (t->code () == TYPE_CODE_PTR)
4413         address = value_address (ada_value_ind (arg));
4414       else
4415         address = value_address (ada_coerce_ref (arg));
4416
4417       /* Check to see if this is a tagged type.  We also need to handle
4418          the case where the type is a reference to a tagged type, but
4419          we have to be careful to exclude pointers to tagged types.
4420          The latter should be shown as usual (as a pointer), whereas
4421          a reference should mostly be transparent to the user.  */
4422
4423       if (ada_is_tagged_type (t1, 0)
4424           || (t1->code () == TYPE_CODE_REF
4425               && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
4426         {
4427           /* We first try to find the searched field in the current type.
4428              If not found then let's look in the fixed type.  */
4429
4430           if (!find_struct_field (name, t1, 0,
4431                                   nullptr, nullptr, nullptr,
4432                                   nullptr, nullptr))
4433             check_tag = 1;
4434           else
4435             check_tag = 0;
4436         }
4437       else
4438         check_tag = 0;
4439
4440       /* Convert to fixed type in all cases, so that we have proper
4441          offsets to each field in unconstrained record types.  */
4442       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4443                               address, NULL, check_tag);
4444
4445       /* Resolve the dynamic type as well.  */
4446       arg = value_from_contents_and_address (t1, nullptr, address);
4447       t1 = value_type (arg);
4448
4449       if (find_struct_field (name, t1, 0,
4450                              &field_type, &byte_offset, &bit_offset,
4451                              &bit_size, NULL))
4452         {
4453           if (bit_size != 0)
4454             {
4455               if (t->code () == TYPE_CODE_REF)
4456                 arg = ada_coerce_ref (arg);
4457               else
4458                 arg = ada_value_ind (arg);
4459               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4460                                                   bit_offset, bit_size,
4461                                                   field_type);
4462             }
4463           else
4464             v = value_at_lazy (field_type, address + byte_offset);
4465         }
4466     }
4467
4468   if (v != NULL || no_err)
4469     return v;
4470   else
4471     error (_("There is no member named %s."), name);
4472
4473  BadValue:
4474   if (no_err)
4475     return NULL;
4476   else
4477     error (_("Attempt to extract a component of "
4478              "a value that is not a record."));
4479 }
4480
4481 /* Return the value ACTUAL, converted to be an appropriate value for a
4482    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4483    allocating any necessary descriptors (fat pointers), or copies of
4484    values not residing in memory, updating it as needed.  */
4485
4486 struct value *
4487 ada_convert_actual (struct value *actual, struct type *formal_type0)
4488 {
4489   struct type *actual_type = ada_check_typedef (value_type (actual));
4490   struct type *formal_type = ada_check_typedef (formal_type0);
4491   struct type *formal_target =
4492     formal_type->code () == TYPE_CODE_PTR
4493     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4494   struct type *actual_target =
4495     actual_type->code () == TYPE_CODE_PTR
4496     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4497
4498   if (ada_is_array_descriptor_type (formal_target)
4499       && actual_target->code () == TYPE_CODE_ARRAY)
4500     return make_array_descriptor (formal_type, actual);
4501   else if (formal_type->code () == TYPE_CODE_PTR
4502            || formal_type->code () == TYPE_CODE_REF)
4503     {
4504       struct value *result;
4505
4506       if (formal_target->code () == TYPE_CODE_ARRAY
4507           && ada_is_array_descriptor_type (actual_target))
4508         result = desc_data (actual);
4509       else if (formal_type->code () != TYPE_CODE_PTR)
4510         {
4511           if (VALUE_LVAL (actual) != lval_memory)
4512             {
4513               struct value *val;
4514
4515               actual_type = ada_check_typedef (value_type (actual));
4516               val = allocate_value (actual_type);
4517               copy (value_contents (actual), value_contents_raw (val));
4518               actual = ensure_lval (val);
4519             }
4520           result = value_addr (actual);
4521         }
4522       else
4523         return actual;
4524       return value_cast_pointers (formal_type, result, 0);
4525     }
4526   else if (actual_type->code () == TYPE_CODE_PTR)
4527     return ada_value_ind (actual);
4528   else if (ada_is_aligner_type (formal_type))
4529     {
4530       /* We need to turn this parameter into an aligner type
4531          as well.  */
4532       struct value *aligner = allocate_value (formal_type);
4533       struct value *component = ada_value_struct_elt (aligner, "F", 0);
4534
4535       value_assign_to_component (aligner, component, actual);
4536       return aligner;
4537     }
4538
4539   return actual;
4540 }
4541
4542 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4543    type TYPE.  This is usually an inefficient no-op except on some targets
4544    (such as AVR) where the representation of a pointer and an address
4545    differs.  */
4546
4547 static CORE_ADDR
4548 value_pointer (struct value *value, struct type *type)
4549 {
4550   unsigned len = TYPE_LENGTH (type);
4551   gdb_byte *buf = (gdb_byte *) alloca (len);
4552   CORE_ADDR addr;
4553
4554   addr = value_address (value);
4555   gdbarch_address_to_pointer (type->arch (), type, buf, addr);
4556   addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4557   return addr;
4558 }
4559
4560
4561 /* Push a descriptor of type TYPE for array value ARR on the stack at
4562    *SP, updating *SP to reflect the new descriptor.  Return either
4563    an lvalue representing the new descriptor, or (if TYPE is a pointer-
4564    to-descriptor type rather than a descriptor type), a struct value *
4565    representing a pointer to this descriptor.  */
4566
4567 static struct value *
4568 make_array_descriptor (struct type *type, struct value *arr)
4569 {
4570   struct type *bounds_type = desc_bounds_type (type);
4571   struct type *desc_type = desc_base_type (type);
4572   struct value *descriptor = allocate_value (desc_type);
4573   struct value *bounds = allocate_value (bounds_type);
4574   int i;
4575
4576   for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4577        i > 0; i -= 1)
4578     {
4579       modify_field (value_type (bounds),
4580                     value_contents_writeable (bounds).data (),
4581                     ada_array_bound (arr, i, 0),
4582                     desc_bound_bitpos (bounds_type, i, 0),
4583                     desc_bound_bitsize (bounds_type, i, 0));
4584       modify_field (value_type (bounds),
4585                     value_contents_writeable (bounds).data (),
4586                     ada_array_bound (arr, i, 1),
4587                     desc_bound_bitpos (bounds_type, i, 1),
4588                     desc_bound_bitsize (bounds_type, i, 1));
4589     }
4590
4591   bounds = ensure_lval (bounds);
4592
4593   modify_field (value_type (descriptor),
4594                 value_contents_writeable (descriptor).data (),
4595                 value_pointer (ensure_lval (arr),
4596                                desc_type->field (0).type ()),
4597                 fat_pntr_data_bitpos (desc_type),
4598                 fat_pntr_data_bitsize (desc_type));
4599
4600   modify_field (value_type (descriptor),
4601                 value_contents_writeable (descriptor).data (),
4602                 value_pointer (bounds,
4603                                desc_type->field (1).type ()),
4604                 fat_pntr_bounds_bitpos (desc_type),
4605                 fat_pntr_bounds_bitsize (desc_type));
4606
4607   descriptor = ensure_lval (descriptor);
4608
4609   if (type->code () == TYPE_CODE_PTR)
4610     return value_addr (descriptor);
4611   else
4612     return descriptor;
4613 }
4614 \f
4615                                 /* Symbol Cache Module */
4616
4617 /* Performance measurements made as of 2010-01-15 indicate that
4618    this cache does bring some noticeable improvements.  Depending
4619    on the type of entity being printed, the cache can make it as much
4620    as an order of magnitude faster than without it.
4621
4622    The descriptive type DWARF extension has significantly reduced
4623    the need for this cache, at least when DWARF is being used.  However,
4624    even in this case, some expensive name-based symbol searches are still
4625    sometimes necessary - to find an XVZ variable, mostly.  */
4626
4627 /* Return the symbol cache associated to the given program space PSPACE.
4628    If not allocated for this PSPACE yet, allocate and initialize one.  */
4629
4630 static struct ada_symbol_cache *
4631 ada_get_symbol_cache (struct program_space *pspace)
4632 {
4633   struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4634
4635   if (pspace_data->sym_cache == nullptr)
4636     pspace_data->sym_cache.reset (new ada_symbol_cache);
4637
4638   return pspace_data->sym_cache.get ();
4639 }
4640
4641 /* Clear all entries from the symbol cache.  */
4642
4643 static void
4644 ada_clear_symbol_cache ()
4645 {
4646   struct ada_pspace_data *pspace_data
4647     = get_ada_pspace_data (current_program_space);
4648
4649   if (pspace_data->sym_cache != nullptr)
4650     pspace_data->sym_cache.reset ();
4651 }
4652
4653 /* Search our cache for an entry matching NAME and DOMAIN.
4654    Return it if found, or NULL otherwise.  */
4655
4656 static struct cache_entry **
4657 find_entry (const char *name, domain_enum domain)
4658 {
4659   struct ada_symbol_cache *sym_cache
4660     = ada_get_symbol_cache (current_program_space);
4661   int h = msymbol_hash (name) % HASH_SIZE;
4662   struct cache_entry **e;
4663
4664   for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4665     {
4666       if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4667         return e;
4668     }
4669   return NULL;
4670 }
4671
4672 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4673    Return 1 if found, 0 otherwise.
4674
4675    If an entry was found and SYM is not NULL, set *SYM to the entry's
4676    SYM.  Same principle for BLOCK if not NULL.  */
4677
4678 static int
4679 lookup_cached_symbol (const char *name, domain_enum domain,
4680                       struct symbol **sym, const struct block **block)
4681 {
4682   struct cache_entry **e = find_entry (name, domain);
4683
4684   if (e == NULL)
4685     return 0;
4686   if (sym != NULL)
4687     *sym = (*e)->sym;
4688   if (block != NULL)
4689     *block = (*e)->block;
4690   return 1;
4691 }
4692
4693 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4694    in domain DOMAIN, save this result in our symbol cache.  */
4695
4696 static void
4697 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4698               const struct block *block)
4699 {
4700   struct ada_symbol_cache *sym_cache
4701     = ada_get_symbol_cache (current_program_space);
4702   int h;
4703   struct cache_entry *e;
4704
4705   /* Symbols for builtin types don't have a block.
4706      For now don't cache such symbols.  */
4707   if (sym != NULL && !sym->is_objfile_owned ())
4708     return;
4709
4710   /* If the symbol is a local symbol, then do not cache it, as a search
4711      for that symbol depends on the context.  To determine whether
4712      the symbol is local or not, we check the block where we found it
4713      against the global and static blocks of its associated symtab.  */
4714   if (sym
4715       && BLOCKVECTOR_BLOCK (symbol_symtab (sym)->compunit ()->blockvector (),
4716                             GLOBAL_BLOCK) != block
4717       && BLOCKVECTOR_BLOCK (symbol_symtab (sym)->compunit ()->blockvector (),
4718                             STATIC_BLOCK) != block)
4719     return;
4720
4721   h = msymbol_hash (name) % HASH_SIZE;
4722   e = XOBNEW (&sym_cache->cache_space, cache_entry);
4723   e->next = sym_cache->root[h];
4724   sym_cache->root[h] = e;
4725   e->name = obstack_strdup (&sym_cache->cache_space, name);
4726   e->sym = sym;
4727   e->domain = domain;
4728   e->block = block;
4729 }
4730 \f
4731                                 /* Symbol Lookup */
4732
4733 /* Return the symbol name match type that should be used used when
4734    searching for all symbols matching LOOKUP_NAME.
4735
4736    LOOKUP_NAME is expected to be a symbol name after transformation
4737    for Ada lookups.  */
4738
4739 static symbol_name_match_type
4740 name_match_type_from_name (const char *lookup_name)
4741 {
4742   return (strstr (lookup_name, "__") == NULL
4743           ? symbol_name_match_type::WILD
4744           : symbol_name_match_type::FULL);
4745 }
4746
4747 /* Return the result of a standard (literal, C-like) lookup of NAME in
4748    given DOMAIN, visible from lexical block BLOCK.  */
4749
4750 static struct symbol *
4751 standard_lookup (const char *name, const struct block *block,
4752                  domain_enum domain)
4753 {
4754   /* Initialize it just to avoid a GCC false warning.  */
4755   struct block_symbol sym = {};
4756
4757   if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4758     return sym.symbol;
4759   ada_lookup_encoded_symbol (name, block, domain, &sym);
4760   cache_symbol (name, domain, sym.symbol, sym.block);
4761   return sym.symbol;
4762 }
4763
4764
4765 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4766    in the symbol fields of SYMS.  We treat enumerals as functions, 
4767    since they contend in overloading in the same way.  */
4768 static int
4769 is_nonfunction (const std::vector<struct block_symbol> &syms)
4770 {
4771   for (const block_symbol &sym : syms)
4772     if (sym.symbol->type ()->code () != TYPE_CODE_FUNC
4773         && (sym.symbol->type ()->code () != TYPE_CODE_ENUM
4774             || sym.symbol->aclass () != LOC_CONST))
4775       return 1;
4776
4777   return 0;
4778 }
4779
4780 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4781    struct types.  Otherwise, they may not.  */
4782
4783 static int
4784 equiv_types (struct type *type0, struct type *type1)
4785 {
4786   if (type0 == type1)
4787     return 1;
4788   if (type0 == NULL || type1 == NULL
4789       || type0->code () != type1->code ())
4790     return 0;
4791   if ((type0->code () == TYPE_CODE_STRUCT
4792        || type0->code () == TYPE_CODE_ENUM)
4793       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4794       && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4795     return 1;
4796
4797   return 0;
4798 }
4799
4800 /* True iff SYM0 represents the same entity as SYM1, or one that is
4801    no more defined than that of SYM1.  */
4802
4803 static int
4804 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4805 {
4806   if (sym0 == sym1)
4807     return 1;
4808   if (sym0->domain () != sym1->domain ()
4809       || sym0->aclass () != sym1->aclass ())
4810     return 0;
4811
4812   switch (sym0->aclass ())
4813     {
4814     case LOC_UNDEF:
4815       return 1;
4816     case LOC_TYPEDEF:
4817       {
4818         struct type *type0 = sym0->type ();
4819         struct type *type1 = sym1->type ();
4820         const char *name0 = sym0->linkage_name ();
4821         const char *name1 = sym1->linkage_name ();
4822         int len0 = strlen (name0);
4823
4824         return
4825           type0->code () == type1->code ()
4826           && (equiv_types (type0, type1)
4827               || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4828                   && startswith (name1 + len0, "___XV")));
4829       }
4830     case LOC_CONST:
4831       return sym0->value_longest () == sym1->value_longest ()
4832         && equiv_types (sym0->type (), sym1->type ());
4833
4834     case LOC_STATIC:
4835       {
4836         const char *name0 = sym0->linkage_name ();
4837         const char *name1 = sym1->linkage_name ();
4838         return (strcmp (name0, name1) == 0
4839                 && sym0->value_address () == sym1->value_address ());
4840       }
4841
4842     default:
4843       return 0;
4844     }
4845 }
4846
4847 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4848    records in RESULT.  Do nothing if SYM is a duplicate.  */
4849
4850 static void
4851 add_defn_to_vec (std::vector<struct block_symbol> &result,
4852                  struct symbol *sym,
4853                  const struct block *block)
4854 {
4855   /* Do not try to complete stub types, as the debugger is probably
4856      already scanning all symbols matching a certain name at the
4857      time when this function is called.  Trying to replace the stub
4858      type by its associated full type will cause us to restart a scan
4859      which may lead to an infinite recursion.  Instead, the client
4860      collecting the matching symbols will end up collecting several
4861      matches, with at least one of them complete.  It can then filter
4862      out the stub ones if needed.  */
4863
4864   for (int i = result.size () - 1; i >= 0; i -= 1)
4865     {
4866       if (lesseq_defined_than (sym, result[i].symbol))
4867         return;
4868       else if (lesseq_defined_than (result[i].symbol, sym))
4869         {
4870           result[i].symbol = sym;
4871           result[i].block = block;
4872           return;
4873         }
4874     }
4875
4876   struct block_symbol info;
4877   info.symbol = sym;
4878   info.block = block;
4879   result.push_back (info);
4880 }
4881
4882 /* Return a bound minimal symbol matching NAME according to Ada
4883    decoding rules.  Returns an invalid symbol if there is no such
4884    minimal symbol.  Names prefixed with "standard__" are handled
4885    specially: "standard__" is first stripped off, and only static and
4886    global symbols are searched.  */
4887
4888 struct bound_minimal_symbol
4889 ada_lookup_simple_minsym (const char *name)
4890 {
4891   struct bound_minimal_symbol result;
4892
4893   symbol_name_match_type match_type = name_match_type_from_name (name);
4894   lookup_name_info lookup_name (name, match_type);
4895
4896   symbol_name_matcher_ftype *match_name
4897     = ada_get_symbol_name_matcher (lookup_name);
4898
4899   for (objfile *objfile : current_program_space->objfiles ())
4900     {
4901       for (minimal_symbol *msymbol : objfile->msymbols ())
4902         {
4903           if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4904               && msymbol->type () != mst_solib_trampoline)
4905             {
4906               result.minsym = msymbol;
4907               result.objfile = objfile;
4908               break;
4909             }
4910         }
4911     }
4912
4913   return result;
4914 }
4915
4916 /* True if TYPE is definitely an artificial type supplied to a symbol
4917    for which no debugging information was given in the symbol file.  */
4918
4919 static int
4920 is_nondebugging_type (struct type *type)
4921 {
4922   const char *name = ada_type_name (type);
4923
4924   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4925 }
4926
4927 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4928    that are deemed "identical" for practical purposes.
4929
4930    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4931    types and that their number of enumerals is identical (in other
4932    words, type1->num_fields () == type2->num_fields ()).  */
4933
4934 static int
4935 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4936 {
4937   int i;
4938
4939   /* The heuristic we use here is fairly conservative.  We consider
4940      that 2 enumerate types are identical if they have the same
4941      number of enumerals and that all enumerals have the same
4942      underlying value and name.  */
4943
4944   /* All enums in the type should have an identical underlying value.  */
4945   for (i = 0; i < type1->num_fields (); i++)
4946     if (type1->field (i).loc_enumval () != type2->field (i).loc_enumval ())
4947       return 0;
4948
4949   /* All enumerals should also have the same name (modulo any numerical
4950      suffix).  */
4951   for (i = 0; i < type1->num_fields (); i++)
4952     {
4953       const char *name_1 = type1->field (i).name ();
4954       const char *name_2 = type2->field (i).name ();
4955       int len_1 = strlen (name_1);
4956       int len_2 = strlen (name_2);
4957
4958       ada_remove_trailing_digits (type1->field (i).name (), &len_1);
4959       ada_remove_trailing_digits (type2->field (i).name (), &len_2);
4960       if (len_1 != len_2
4961           || strncmp (type1->field (i).name (),
4962                       type2->field (i).name (),
4963                       len_1) != 0)
4964         return 0;
4965     }
4966
4967   return 1;
4968 }
4969
4970 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4971    that are deemed "identical" for practical purposes.  Sometimes,
4972    enumerals are not strictly identical, but their types are so similar
4973    that they can be considered identical.
4974
4975    For instance, consider the following code:
4976
4977       type Color is (Black, Red, Green, Blue, White);
4978       type RGB_Color is new Color range Red .. Blue;
4979
4980    Type RGB_Color is a subrange of an implicit type which is a copy
4981    of type Color. If we call that implicit type RGB_ColorB ("B" is
4982    for "Base Type"), then type RGB_ColorB is a copy of type Color.
4983    As a result, when an expression references any of the enumeral
4984    by name (Eg. "print green"), the expression is technically
4985    ambiguous and the user should be asked to disambiguate. But
4986    doing so would only hinder the user, since it wouldn't matter
4987    what choice he makes, the outcome would always be the same.
4988    So, for practical purposes, we consider them as the same.  */
4989
4990 static int
4991 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
4992 {
4993   int i;
4994
4995   /* Before performing a thorough comparison check of each type,
4996      we perform a series of inexpensive checks.  We expect that these
4997      checks will quickly fail in the vast majority of cases, and thus
4998      help prevent the unnecessary use of a more expensive comparison.
4999      Said comparison also expects us to make some of these checks
5000      (see ada_identical_enum_types_p).  */
5001
5002   /* Quick check: All symbols should have an enum type.  */
5003   for (i = 0; i < syms.size (); i++)
5004     if (syms[i].symbol->type ()->code () != TYPE_CODE_ENUM)
5005       return 0;
5006
5007   /* Quick check: They should all have the same value.  */
5008   for (i = 1; i < syms.size (); i++)
5009     if (syms[i].symbol->value_longest () != syms[0].symbol->value_longest ())
5010       return 0;
5011
5012   /* Quick check: They should all have the same number of enumerals.  */
5013   for (i = 1; i < syms.size (); i++)
5014     if (syms[i].symbol->type ()->num_fields ()
5015         != syms[0].symbol->type ()->num_fields ())
5016       return 0;
5017
5018   /* All the sanity checks passed, so we might have a set of
5019      identical enumeration types.  Perform a more complete
5020      comparison of the type of each symbol.  */
5021   for (i = 1; i < syms.size (); i++)
5022     if (!ada_identical_enum_types_p (syms[i].symbol->type (),
5023                                      syms[0].symbol->type ()))
5024       return 0;
5025
5026   return 1;
5027 }
5028
5029 /* Remove any non-debugging symbols in SYMS that definitely
5030    duplicate other symbols in the list (The only case I know of where
5031    this happens is when object files containing stabs-in-ecoff are
5032    linked with files containing ordinary ecoff debugging symbols (or no
5033    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.  */
5034
5035 static void
5036 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5037 {
5038   int i, j;
5039
5040   /* We should never be called with less than 2 symbols, as there
5041      cannot be any extra symbol in that case.  But it's easy to
5042      handle, since we have nothing to do in that case.  */
5043   if (syms->size () < 2)
5044     return;
5045
5046   i = 0;
5047   while (i < syms->size ())
5048     {
5049       int remove_p = 0;
5050
5051       /* If two symbols have the same name and one of them is a stub type,
5052          the get rid of the stub.  */
5053
5054       if ((*syms)[i].symbol->type ()->is_stub ()
5055           && (*syms)[i].symbol->linkage_name () != NULL)
5056         {
5057           for (j = 0; j < syms->size (); j++)
5058             {
5059               if (j != i
5060                   && !(*syms)[j].symbol->type ()->is_stub ()
5061                   && (*syms)[j].symbol->linkage_name () != NULL
5062                   && strcmp ((*syms)[i].symbol->linkage_name (),
5063                              (*syms)[j].symbol->linkage_name ()) == 0)
5064                 remove_p = 1;
5065             }
5066         }
5067
5068       /* Two symbols with the same name, same class and same address
5069          should be identical.  */
5070
5071       else if ((*syms)[i].symbol->linkage_name () != NULL
5072           && (*syms)[i].symbol->aclass () == LOC_STATIC
5073           && is_nondebugging_type ((*syms)[i].symbol->type ()))
5074         {
5075           for (j = 0; j < syms->size (); j += 1)
5076             {
5077               if (i != j
5078                   && (*syms)[j].symbol->linkage_name () != NULL
5079                   && strcmp ((*syms)[i].symbol->linkage_name (),
5080                              (*syms)[j].symbol->linkage_name ()) == 0
5081                   && ((*syms)[i].symbol->aclass ()
5082                       == (*syms)[j].symbol->aclass ())
5083                   && (*syms)[i].symbol->value_address ()
5084                   == (*syms)[j].symbol->value_address ())
5085                 remove_p = 1;
5086             }
5087         }
5088       
5089       if (remove_p)
5090         syms->erase (syms->begin () + i);
5091       else
5092         i += 1;
5093     }
5094
5095   /* If all the remaining symbols are identical enumerals, then
5096      just keep the first one and discard the rest.
5097
5098      Unlike what we did previously, we do not discard any entry
5099      unless they are ALL identical.  This is because the symbol
5100      comparison is not a strict comparison, but rather a practical
5101      comparison.  If all symbols are considered identical, then
5102      we can just go ahead and use the first one and discard the rest.
5103      But if we cannot reduce the list to a single element, we have
5104      to ask the user to disambiguate anyways.  And if we have to
5105      present a multiple-choice menu, it's less confusing if the list
5106      isn't missing some choices that were identical and yet distinct.  */
5107   if (symbols_are_identical_enums (*syms))
5108     syms->resize (1);
5109 }
5110
5111 /* Given a type that corresponds to a renaming entity, use the type name
5112    to extract the scope (package name or function name, fully qualified,
5113    and following the GNAT encoding convention) where this renaming has been
5114    defined.  */
5115
5116 static std::string
5117 xget_renaming_scope (struct type *renaming_type)
5118 {
5119   /* The renaming types adhere to the following convention:
5120      <scope>__<rename>___<XR extension>.
5121      So, to extract the scope, we search for the "___XR" extension,
5122      and then backtrack until we find the first "__".  */
5123
5124   const char *name = renaming_type->name ();
5125   const char *suffix = strstr (name, "___XR");
5126   const char *last;
5127
5128   /* Now, backtrack a bit until we find the first "__".  Start looking
5129      at suffix - 3, as the <rename> part is at least one character long.  */
5130
5131   for (last = suffix - 3; last > name; last--)
5132     if (last[0] == '_' && last[1] == '_')
5133       break;
5134
5135   /* Make a copy of scope and return it.  */
5136   return std::string (name, last);
5137 }
5138
5139 /* Return nonzero if NAME corresponds to a package name.  */
5140
5141 static int
5142 is_package_name (const char *name)
5143 {
5144   /* Here, We take advantage of the fact that no symbols are generated
5145      for packages, while symbols are generated for each function.
5146      So the condition for NAME represent a package becomes equivalent
5147      to NAME not existing in our list of symbols.  There is only one
5148      small complication with library-level functions (see below).  */
5149
5150   /* If it is a function that has not been defined at library level,
5151      then we should be able to look it up in the symbols.  */
5152   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5153     return 0;
5154
5155   /* Library-level function names start with "_ada_".  See if function
5156      "_ada_" followed by NAME can be found.  */
5157
5158   /* Do a quick check that NAME does not contain "__", since library-level
5159      functions names cannot contain "__" in them.  */
5160   if (strstr (name, "__") != NULL)
5161     return 0;
5162
5163   std::string fun_name = string_printf ("_ada_%s", name);
5164
5165   return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5166 }
5167
5168 /* Return nonzero if SYM corresponds to a renaming entity that is
5169    not visible from FUNCTION_NAME.  */
5170
5171 static int
5172 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5173 {
5174   if (sym->aclass () != LOC_TYPEDEF)
5175     return 0;
5176
5177   std::string scope = xget_renaming_scope (sym->type ());
5178
5179   /* If the rename has been defined in a package, then it is visible.  */
5180   if (is_package_name (scope.c_str ()))
5181     return 0;
5182
5183   /* Check that the rename is in the current function scope by checking
5184      that its name starts with SCOPE.  */
5185
5186   /* If the function name starts with "_ada_", it means that it is
5187      a library-level function.  Strip this prefix before doing the
5188      comparison, as the encoding for the renaming does not contain
5189      this prefix.  */
5190   if (startswith (function_name, "_ada_"))
5191     function_name += 5;
5192
5193   return !startswith (function_name, scope.c_str ());
5194 }
5195
5196 /* Remove entries from SYMS that corresponds to a renaming entity that
5197    is not visible from the function associated with CURRENT_BLOCK or
5198    that is superfluous due to the presence of more specific renaming
5199    information.  Places surviving symbols in the initial entries of
5200    SYMS.
5201
5202    Rationale:
5203    First, in cases where an object renaming is implemented as a
5204    reference variable, GNAT may produce both the actual reference
5205    variable and the renaming encoding.  In this case, we discard the
5206    latter.
5207
5208    Second, GNAT emits a type following a specified encoding for each renaming
5209    entity.  Unfortunately, STABS currently does not support the definition
5210    of types that are local to a given lexical block, so all renamings types
5211    are emitted at library level.  As a consequence, if an application
5212    contains two renaming entities using the same name, and a user tries to
5213    print the value of one of these entities, the result of the ada symbol
5214    lookup will also contain the wrong renaming type.
5215
5216    This function partially covers for this limitation by attempting to
5217    remove from the SYMS list renaming symbols that should be visible
5218    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
5219    method with the current information available.  The implementation
5220    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
5221    
5222       - When the user tries to print a rename in a function while there
5223         is another rename entity defined in a package:  Normally, the
5224         rename in the function has precedence over the rename in the
5225         package, so the latter should be removed from the list.  This is
5226         currently not the case.
5227         
5228       - This function will incorrectly remove valid renames if
5229         the CURRENT_BLOCK corresponds to a function which symbol name
5230         has been changed by an "Export" pragma.  As a consequence,
5231         the user will be unable to print such rename entities.  */
5232
5233 static void
5234 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5235                              const struct block *current_block)
5236 {
5237   struct symbol *current_function;
5238   const char *current_function_name;
5239   int i;
5240   int is_new_style_renaming;
5241
5242   /* If there is both a renaming foo___XR... encoded as a variable and
5243      a simple variable foo in the same block, discard the latter.
5244      First, zero out such symbols, then compress.  */
5245   is_new_style_renaming = 0;
5246   for (i = 0; i < syms->size (); i += 1)
5247     {
5248       struct symbol *sym = (*syms)[i].symbol;
5249       const struct block *block = (*syms)[i].block;
5250       const char *name;
5251       const char *suffix;
5252
5253       if (sym == NULL || sym->aclass () == LOC_TYPEDEF)
5254         continue;
5255       name = sym->linkage_name ();
5256       suffix = strstr (name, "___XR");
5257
5258       if (suffix != NULL)
5259         {
5260           int name_len = suffix - name;
5261           int j;
5262
5263           is_new_style_renaming = 1;
5264           for (j = 0; j < syms->size (); j += 1)
5265             if (i != j && (*syms)[j].symbol != NULL
5266                 && strncmp (name, (*syms)[j].symbol->linkage_name (),
5267                             name_len) == 0
5268                 && block == (*syms)[j].block)
5269               (*syms)[j].symbol = NULL;
5270         }
5271     }
5272   if (is_new_style_renaming)
5273     {
5274       int j, k;
5275
5276       for (j = k = 0; j < syms->size (); j += 1)
5277         if ((*syms)[j].symbol != NULL)
5278             {
5279               (*syms)[k] = (*syms)[j];
5280               k += 1;
5281             }
5282       syms->resize (k);
5283       return;
5284     }
5285
5286   /* Extract the function name associated to CURRENT_BLOCK.
5287      Abort if unable to do so.  */
5288
5289   if (current_block == NULL)
5290     return;
5291
5292   current_function = block_linkage_function (current_block);
5293   if (current_function == NULL)
5294     return;
5295
5296   current_function_name = current_function->linkage_name ();
5297   if (current_function_name == NULL)
5298     return;
5299
5300   /* Check each of the symbols, and remove it from the list if it is
5301      a type corresponding to a renaming that is out of the scope of
5302      the current block.  */
5303
5304   i = 0;
5305   while (i < syms->size ())
5306     {
5307       if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5308           == ADA_OBJECT_RENAMING
5309           && old_renaming_is_invisible ((*syms)[i].symbol,
5310                                         current_function_name))
5311         syms->erase (syms->begin () + i);
5312       else
5313         i += 1;
5314     }
5315 }
5316
5317 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5318    whose name and domain match LOOKUP_NAME and DOMAIN respectively.
5319
5320    Note: This function assumes that RESULT is empty.  */
5321
5322 static void
5323 ada_add_local_symbols (std::vector<struct block_symbol> &result,
5324                        const lookup_name_info &lookup_name,
5325                        const struct block *block, domain_enum domain)
5326 {
5327   while (block != NULL)
5328     {
5329       ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5330
5331       /* If we found a non-function match, assume that's the one.  We
5332          only check this when finding a function boundary, so that we
5333          can accumulate all results from intervening blocks first.  */
5334       if (BLOCK_FUNCTION (block) != nullptr && is_nonfunction (result))
5335         return;
5336
5337       block = BLOCK_SUPERBLOCK (block);
5338     }
5339 }
5340
5341 /* An object of this type is used as the callback argument when
5342    calling the map_matching_symbols method.  */
5343
5344 struct match_data
5345 {
5346   explicit match_data (std::vector<struct block_symbol> *rp)
5347     : resultp (rp)
5348   {
5349   }
5350   DISABLE_COPY_AND_ASSIGN (match_data);
5351
5352   bool operator() (struct block_symbol *bsym);
5353
5354   struct objfile *objfile = nullptr;
5355   std::vector<struct block_symbol> *resultp;
5356   struct symbol *arg_sym = nullptr;
5357   bool found_sym = false;
5358 };
5359
5360 /* A callback for add_nonlocal_symbols that adds symbol, found in
5361    BSYM, to a list of symbols.  */
5362
5363 bool
5364 match_data::operator() (struct block_symbol *bsym)
5365 {
5366   const struct block *block = bsym->block;
5367   struct symbol *sym = bsym->symbol;
5368
5369   if (sym == NULL)
5370     {
5371       if (!found_sym && arg_sym != NULL)
5372         add_defn_to_vec (*resultp,
5373                          fixup_symbol_section (arg_sym, objfile),
5374                          block);
5375       found_sym = false;
5376       arg_sym = NULL;
5377     }
5378   else 
5379     {
5380       if (sym->aclass () == LOC_UNRESOLVED)
5381         return true;
5382       else if (sym->is_argument ())
5383         arg_sym = sym;
5384       else
5385         {
5386           found_sym = true;
5387           add_defn_to_vec (*resultp,
5388                            fixup_symbol_section (sym, objfile),
5389                            block);
5390         }
5391     }
5392   return true;
5393 }
5394
5395 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5396    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5397    symbols to RESULT.  Return whether we found such symbols.  */
5398
5399 static int
5400 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5401                          const struct block *block,
5402                          const lookup_name_info &lookup_name,
5403                          domain_enum domain)
5404 {
5405   struct using_direct *renaming;
5406   int defns_mark = result.size ();
5407
5408   symbol_name_matcher_ftype *name_match
5409     = ada_get_symbol_name_matcher (lookup_name);
5410
5411   for (renaming = block_using (block);
5412        renaming != NULL;
5413        renaming = renaming->next)
5414     {
5415       const char *r_name;
5416
5417       /* Avoid infinite recursions: skip this renaming if we are actually
5418          already traversing it.
5419
5420          Currently, symbol lookup in Ada don't use the namespace machinery from
5421          C++/Fortran support: skip namespace imports that use them.  */
5422       if (renaming->searched
5423           || (renaming->import_src != NULL
5424               && renaming->import_src[0] != '\0')
5425           || (renaming->import_dest != NULL
5426               && renaming->import_dest[0] != '\0'))
5427         continue;
5428       renaming->searched = 1;
5429
5430       /* TODO: here, we perform another name-based symbol lookup, which can
5431          pull its own multiple overloads.  In theory, we should be able to do
5432          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5433          not a simple name.  But in order to do this, we would need to enhance
5434          the DWARF reader to associate a symbol to this renaming, instead of a
5435          name.  So, for now, we do something simpler: re-use the C++/Fortran
5436          namespace machinery.  */
5437       r_name = (renaming->alias != NULL
5438                 ? renaming->alias
5439                 : renaming->declaration);
5440       if (name_match (r_name, lookup_name, NULL))
5441         {
5442           lookup_name_info decl_lookup_name (renaming->declaration,
5443                                              lookup_name.match_type ());
5444           ada_add_all_symbols (result, block, decl_lookup_name, domain,
5445                                1, NULL);
5446         }
5447       renaming->searched = 0;
5448     }
5449   return result.size () != defns_mark;
5450 }
5451
5452 /* Implements compare_names, but only applying the comparision using
5453    the given CASING.  */
5454
5455 static int
5456 compare_names_with_case (const char *string1, const char *string2,
5457                          enum case_sensitivity casing)
5458 {
5459   while (*string1 != '\0' && *string2 != '\0')
5460     {
5461       char c1, c2;
5462
5463       if (isspace (*string1) || isspace (*string2))
5464         return strcmp_iw_ordered (string1, string2);
5465
5466       if (casing == case_sensitive_off)
5467         {
5468           c1 = tolower (*string1);
5469           c2 = tolower (*string2);
5470         }
5471       else
5472         {
5473           c1 = *string1;
5474           c2 = *string2;
5475         }
5476       if (c1 != c2)
5477         break;
5478
5479       string1 += 1;
5480       string2 += 1;
5481     }
5482
5483   switch (*string1)
5484     {
5485     case '(':
5486       return strcmp_iw_ordered (string1, string2);
5487     case '_':
5488       if (*string2 == '\0')
5489         {
5490           if (is_name_suffix (string1))
5491             return 0;
5492           else
5493             return 1;
5494         }
5495       /* FALLTHROUGH */
5496     default:
5497       if (*string2 == '(')
5498         return strcmp_iw_ordered (string1, string2);
5499       else
5500         {
5501           if (casing == case_sensitive_off)
5502             return tolower (*string1) - tolower (*string2);
5503           else
5504             return *string1 - *string2;
5505         }
5506     }
5507 }
5508
5509 /* Compare STRING1 to STRING2, with results as for strcmp.
5510    Compatible with strcmp_iw_ordered in that...
5511
5512        strcmp_iw_ordered (STRING1, STRING2) <= 0
5513
5514    ... implies...
5515
5516        compare_names (STRING1, STRING2) <= 0
5517
5518    (they may differ as to what symbols compare equal).  */
5519
5520 static int
5521 compare_names (const char *string1, const char *string2)
5522 {
5523   int result;
5524
5525   /* Similar to what strcmp_iw_ordered does, we need to perform
5526      a case-insensitive comparison first, and only resort to
5527      a second, case-sensitive, comparison if the first one was
5528      not sufficient to differentiate the two strings.  */
5529
5530   result = compare_names_with_case (string1, string2, case_sensitive_off);
5531   if (result == 0)
5532     result = compare_names_with_case (string1, string2, case_sensitive_on);
5533
5534   return result;
5535 }
5536
5537 /* Convenience function to get at the Ada encoded lookup name for
5538    LOOKUP_NAME, as a C string.  */
5539
5540 static const char *
5541 ada_lookup_name (const lookup_name_info &lookup_name)
5542 {
5543   return lookup_name.ada ().lookup_name ().c_str ();
5544 }
5545
5546 /* A helper for add_nonlocal_symbols.  Call expand_matching_symbols
5547    for OBJFILE, then walk the objfile's symtabs and update the
5548    results.  */
5549
5550 static void
5551 map_matching_symbols (struct objfile *objfile,
5552                       const lookup_name_info &lookup_name,
5553                       bool is_wild_match,
5554                       domain_enum domain,
5555                       int global,
5556                       match_data &data)
5557 {
5558   data.objfile = objfile;
5559   objfile->expand_matching_symbols (lookup_name, domain, global,
5560                                     is_wild_match ? nullptr : compare_names);
5561
5562   const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5563   for (compunit_symtab *symtab : objfile->compunits ())
5564     {
5565       const struct block *block
5566         = BLOCKVECTOR_BLOCK (symtab->blockvector (), block_kind);
5567       if (!iterate_over_symbols_terminated (block, lookup_name,
5568                                             domain, data))
5569         break;
5570     }
5571 }
5572
5573 /* Add to RESULT all non-local symbols whose name and domain match
5574    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5575    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5576    symbols otherwise.  */
5577
5578 static void
5579 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5580                       const lookup_name_info &lookup_name,
5581                       domain_enum domain, int global)
5582 {
5583   struct match_data data (&result);
5584
5585   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5586
5587   for (objfile *objfile : current_program_space->objfiles ())
5588     {
5589       map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5590                             global, data);
5591
5592       for (compunit_symtab *cu : objfile->compunits ())
5593         {
5594           const struct block *global_block
5595             = BLOCKVECTOR_BLOCK (cu->blockvector (), GLOBAL_BLOCK);
5596
5597           if (ada_add_block_renamings (result, global_block, lookup_name,
5598                                        domain))
5599             data.found_sym = true;
5600         }
5601     }
5602
5603   if (result.empty () && global && !is_wild_match)
5604     {
5605       const char *name = ada_lookup_name (lookup_name);
5606       std::string bracket_name = std::string ("<_ada_") + name + '>';
5607       lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5608
5609       for (objfile *objfile : current_program_space->objfiles ())
5610         map_matching_symbols (objfile, name1, false, domain, global, data);
5611     }
5612 }
5613
5614 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5615    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5616    returning the number of matches.  Add these to RESULT.
5617
5618    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5619    symbol match within the nest of blocks whose innermost member is BLOCK,
5620    is the one match returned (no other matches in that or
5621    enclosing blocks is returned).  If there are any matches in or
5622    surrounding BLOCK, then these alone are returned.
5623
5624    Names prefixed with "standard__" are handled specially:
5625    "standard__" is first stripped off (by the lookup_name
5626    constructor), and only static and global symbols are searched.
5627
5628    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5629    to lookup global symbols.  */
5630
5631 static void
5632 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5633                      const struct block *block,
5634                      const lookup_name_info &lookup_name,
5635                      domain_enum domain,
5636                      int full_search,
5637                      int *made_global_lookup_p)
5638 {
5639   struct symbol *sym;
5640
5641   if (made_global_lookup_p)
5642     *made_global_lookup_p = 0;
5643
5644   /* Special case: If the user specifies a symbol name inside package
5645      Standard, do a non-wild matching of the symbol name without
5646      the "standard__" prefix.  This was primarily introduced in order
5647      to allow the user to specifically access the standard exceptions
5648      using, for instance, Standard.Constraint_Error when Constraint_Error
5649      is ambiguous (due to the user defining its own Constraint_Error
5650      entity inside its program).  */
5651   if (lookup_name.ada ().standard_p ())
5652     block = NULL;
5653
5654   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5655
5656   if (block != NULL)
5657     {
5658       if (full_search)
5659         ada_add_local_symbols (result, lookup_name, block, domain);
5660       else
5661         {
5662           /* In the !full_search case we're are being called by
5663              iterate_over_symbols, and we don't want to search
5664              superblocks.  */
5665           ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5666         }
5667       if (!result.empty () || !full_search)
5668         return;
5669     }
5670
5671   /* No non-global symbols found.  Check our cache to see if we have
5672      already performed this search before.  If we have, then return
5673      the same result.  */
5674
5675   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5676                             domain, &sym, &block))
5677     {
5678       if (sym != NULL)
5679         add_defn_to_vec (result, sym, block);
5680       return;
5681     }
5682
5683   if (made_global_lookup_p)
5684     *made_global_lookup_p = 1;
5685
5686   /* Search symbols from all global blocks.  */
5687  
5688   add_nonlocal_symbols (result, lookup_name, domain, 1);
5689
5690   /* Now add symbols from all per-file blocks if we've gotten no hits
5691      (not strictly correct, but perhaps better than an error).  */
5692
5693   if (result.empty ())
5694     add_nonlocal_symbols (result, lookup_name, domain, 0);
5695 }
5696
5697 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5698    is non-zero, enclosing scope and in global scopes.
5699
5700    Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5701    blocks and symbol tables (if any) in which they were found.
5702
5703    When full_search is non-zero, any non-function/non-enumeral
5704    symbol match within the nest of blocks whose innermost member is BLOCK,
5705    is the one match returned (no other matches in that or
5706    enclosing blocks is returned).  If there are any matches in or
5707    surrounding BLOCK, then these alone are returned.
5708
5709    Names prefixed with "standard__" are handled specially: "standard__"
5710    is first stripped off, and only static and global symbols are searched.  */
5711
5712 static std::vector<struct block_symbol>
5713 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5714                                const struct block *block,
5715                                domain_enum domain,
5716                                int full_search)
5717 {
5718   int syms_from_global_search;
5719   std::vector<struct block_symbol> results;
5720
5721   ada_add_all_symbols (results, block, lookup_name,
5722                        domain, full_search, &syms_from_global_search);
5723
5724   remove_extra_symbols (&results);
5725
5726   if (results.empty () && full_search && syms_from_global_search)
5727     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5728
5729   if (results.size () == 1 && full_search && syms_from_global_search)
5730     cache_symbol (ada_lookup_name (lookup_name), domain,
5731                   results[0].symbol, results[0].block);
5732
5733   remove_irrelevant_renamings (&results, block);
5734   return results;
5735 }
5736
5737 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5738    in global scopes, returning (SYM,BLOCK) tuples.
5739
5740    See ada_lookup_symbol_list_worker for further details.  */
5741
5742 std::vector<struct block_symbol>
5743 ada_lookup_symbol_list (const char *name, const struct block *block,
5744                         domain_enum domain)
5745 {
5746   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5747   lookup_name_info lookup_name (name, name_match_type);
5748
5749   return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5750 }
5751
5752 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5753    to 1, but choosing the first symbol found if there are multiple
5754    choices.
5755
5756    The result is stored in *INFO, which must be non-NULL.
5757    If no match is found, INFO->SYM is set to NULL.  */
5758
5759 void
5760 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5761                            domain_enum domain,
5762                            struct block_symbol *info)
5763 {
5764   /* Since we already have an encoded name, wrap it in '<>' to force a
5765      verbatim match.  Otherwise, if the name happens to not look like
5766      an encoded name (because it doesn't include a "__"),
5767      ada_lookup_name_info would re-encode/fold it again, and that
5768      would e.g., incorrectly lowercase object renaming names like
5769      "R28b" -> "r28b".  */
5770   std::string verbatim = add_angle_brackets (name);
5771
5772   gdb_assert (info != NULL);
5773   *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5774 }
5775
5776 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5777    scope and in global scopes, or NULL if none.  NAME is folded and
5778    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5779    choosing the first symbol if there are multiple choices.  */
5780
5781 struct block_symbol
5782 ada_lookup_symbol (const char *name, const struct block *block0,
5783                    domain_enum domain)
5784 {
5785   std::vector<struct block_symbol> candidates
5786     = ada_lookup_symbol_list (name, block0, domain);
5787
5788   if (candidates.empty ())
5789     return {};
5790
5791   block_symbol info = candidates[0];
5792   info.symbol = fixup_symbol_section (info.symbol, NULL);
5793   return info;
5794 }
5795
5796
5797 /* True iff STR is a possible encoded suffix of a normal Ada name
5798    that is to be ignored for matching purposes.  Suffixes of parallel
5799    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5800    are given by any of the regular expressions:
5801
5802    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5803    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5804    TKB              [subprogram suffix for task bodies]
5805    _E[0-9]+[bs]$    [protected object entry suffixes]
5806    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5807
5808    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5809    match is performed.  This sequence is used to differentiate homonyms,
5810    is an optional part of a valid name suffix.  */
5811
5812 static int
5813 is_name_suffix (const char *str)
5814 {
5815   int k;
5816   const char *matching;
5817   const int len = strlen (str);
5818
5819   /* Skip optional leading __[0-9]+.  */
5820
5821   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5822     {
5823       str += 3;
5824       while (isdigit (str[0]))
5825         str += 1;
5826     }
5827   
5828   /* [.$][0-9]+ */
5829
5830   if (str[0] == '.' || str[0] == '$')
5831     {
5832       matching = str + 1;
5833       while (isdigit (matching[0]))
5834         matching += 1;
5835       if (matching[0] == '\0')
5836         return 1;
5837     }
5838
5839   /* ___[0-9]+ */
5840
5841   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5842     {
5843       matching = str + 3;
5844       while (isdigit (matching[0]))
5845         matching += 1;
5846       if (matching[0] == '\0')
5847         return 1;
5848     }
5849
5850   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
5851
5852   if (strcmp (str, "TKB") == 0)
5853     return 1;
5854
5855 #if 0
5856   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5857      with a N at the end.  Unfortunately, the compiler uses the same
5858      convention for other internal types it creates.  So treating
5859      all entity names that end with an "N" as a name suffix causes
5860      some regressions.  For instance, consider the case of an enumerated
5861      type.  To support the 'Image attribute, it creates an array whose
5862      name ends with N.
5863      Having a single character like this as a suffix carrying some
5864      information is a bit risky.  Perhaps we should change the encoding
5865      to be something like "_N" instead.  In the meantime, do not do
5866      the following check.  */
5867   /* Protected Object Subprograms */
5868   if (len == 1 && str [0] == 'N')
5869     return 1;
5870 #endif
5871
5872   /* _E[0-9]+[bs]$ */
5873   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5874     {
5875       matching = str + 3;
5876       while (isdigit (matching[0]))
5877         matching += 1;
5878       if ((matching[0] == 'b' || matching[0] == 's')
5879           && matching [1] == '\0')
5880         return 1;
5881     }
5882
5883   /* ??? We should not modify STR directly, as we are doing below.  This
5884      is fine in this case, but may become problematic later if we find
5885      that this alternative did not work, and want to try matching
5886      another one from the begining of STR.  Since we modified it, we
5887      won't be able to find the begining of the string anymore!  */
5888   if (str[0] == 'X')
5889     {
5890       str += 1;
5891       while (str[0] != '_' && str[0] != '\0')
5892         {
5893           if (str[0] != 'n' && str[0] != 'b')
5894             return 0;
5895           str += 1;
5896         }
5897     }
5898
5899   if (str[0] == '\000')
5900     return 1;
5901
5902   if (str[0] == '_')
5903     {
5904       if (str[1] != '_' || str[2] == '\000')
5905         return 0;
5906       if (str[2] == '_')
5907         {
5908           if (strcmp (str + 3, "JM") == 0)
5909             return 1;
5910           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5911              the LJM suffix in favor of the JM one.  But we will
5912              still accept LJM as a valid suffix for a reasonable
5913              amount of time, just to allow ourselves to debug programs
5914              compiled using an older version of GNAT.  */
5915           if (strcmp (str + 3, "LJM") == 0)
5916             return 1;
5917           if (str[3] != 'X')
5918             return 0;
5919           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5920               || str[4] == 'U' || str[4] == 'P')
5921             return 1;
5922           if (str[4] == 'R' && str[5] != 'T')
5923             return 1;
5924           return 0;
5925         }
5926       if (!isdigit (str[2]))
5927         return 0;
5928       for (k = 3; str[k] != '\0'; k += 1)
5929         if (!isdigit (str[k]) && str[k] != '_')
5930           return 0;
5931       return 1;
5932     }
5933   if (str[0] == '$' && isdigit (str[1]))
5934     {
5935       for (k = 2; str[k] != '\0'; k += 1)
5936         if (!isdigit (str[k]) && str[k] != '_')
5937           return 0;
5938       return 1;
5939     }
5940   return 0;
5941 }
5942
5943 /* Return non-zero if the string starting at NAME and ending before
5944    NAME_END contains no capital letters.  */
5945
5946 static int
5947 is_valid_name_for_wild_match (const char *name0)
5948 {
5949   std::string decoded_name = ada_decode (name0);
5950   int i;
5951
5952   /* If the decoded name starts with an angle bracket, it means that
5953      NAME0 does not follow the GNAT encoding format.  It should then
5954      not be allowed as a possible wild match.  */
5955   if (decoded_name[0] == '<')
5956     return 0;
5957
5958   for (i=0; decoded_name[i] != '\0'; i++)
5959     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5960       return 0;
5961
5962   return 1;
5963 }
5964
5965 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5966    character which could start a simple name.  Assumes that *NAMEP points
5967    somewhere inside the string beginning at NAME0.  */
5968
5969 static int
5970 advance_wild_match (const char **namep, const char *name0, char target0)
5971 {
5972   const char *name = *namep;
5973
5974   while (1)
5975     {
5976       char t0, t1;
5977
5978       t0 = *name;
5979       if (t0 == '_')
5980         {
5981           t1 = name[1];
5982           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5983             {
5984               name += 1;
5985               if (name == name0 + 5 && startswith (name0, "_ada"))
5986                 break;
5987               else
5988                 name += 1;
5989             }
5990           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5991                                  || name[2] == target0))
5992             {
5993               name += 2;
5994               break;
5995             }
5996           else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
5997             {
5998               /* Names like "pkg__B_N__name", where N is a number, are
5999                  block-local.  We can handle these by simply skipping
6000                  the "B_" here.  */
6001               name += 4;
6002             }
6003           else
6004             return 0;
6005         }
6006       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6007         name += 1;
6008       else
6009         return 0;
6010     }
6011
6012   *namep = name;
6013   return 1;
6014 }
6015
6016 /* Return true iff NAME encodes a name of the form prefix.PATN.
6017    Ignores any informational suffixes of NAME (i.e., for which
6018    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
6019    simple name.  */
6020
6021 static bool
6022 wild_match (const char *name, const char *patn)
6023 {
6024   const char *p;
6025   const char *name0 = name;
6026
6027   if (startswith (name, "___ghost_"))
6028     name += 9;
6029
6030   while (1)
6031     {
6032       const char *match = name;
6033
6034       if (*name == *patn)
6035         {
6036           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6037             if (*p != *name)
6038               break;
6039           if (*p == '\0' && is_name_suffix (name))
6040             return match == name0 || is_valid_name_for_wild_match (name0);
6041
6042           if (name[-1] == '_')
6043             name -= 1;
6044         }
6045       if (!advance_wild_match (&name, name0, *patn))
6046         return false;
6047     }
6048 }
6049
6050 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
6051    necessary).  OBJFILE is the section containing BLOCK.  */
6052
6053 static void
6054 ada_add_block_symbols (std::vector<struct block_symbol> &result,
6055                        const struct block *block,
6056                        const lookup_name_info &lookup_name,
6057                        domain_enum domain, struct objfile *objfile)
6058 {
6059   struct block_iterator iter;
6060   /* A matching argument symbol, if any.  */
6061   struct symbol *arg_sym;
6062   /* Set true when we find a matching non-argument symbol.  */
6063   bool found_sym;
6064   struct symbol *sym;
6065
6066   arg_sym = NULL;
6067   found_sym = false;
6068   for (sym = block_iter_match_first (block, lookup_name, &iter);
6069        sym != NULL;
6070        sym = block_iter_match_next (lookup_name, &iter))
6071     {
6072       if (symbol_matches_domain (sym->language (), sym->domain (), domain))
6073         {
6074           if (sym->aclass () != LOC_UNRESOLVED)
6075             {
6076               if (sym->is_argument ())
6077                 arg_sym = sym;
6078               else
6079                 {
6080                   found_sym = true;
6081                   add_defn_to_vec (result,
6082                                    fixup_symbol_section (sym, objfile),
6083                                    block);
6084                 }
6085             }
6086         }
6087     }
6088
6089   /* Handle renamings.  */
6090
6091   if (ada_add_block_renamings (result, block, lookup_name, domain))
6092     found_sym = true;
6093
6094   if (!found_sym && arg_sym != NULL)
6095     {
6096       add_defn_to_vec (result,
6097                        fixup_symbol_section (arg_sym, objfile),
6098                        block);
6099     }
6100
6101   if (!lookup_name.ada ().wild_match_p ())
6102     {
6103       arg_sym = NULL;
6104       found_sym = false;
6105       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6106       const char *name = ada_lookup_name.c_str ();
6107       size_t name_len = ada_lookup_name.size ();
6108
6109       ALL_BLOCK_SYMBOLS (block, iter, sym)
6110       {
6111         if (symbol_matches_domain (sym->language (),
6112                                    sym->domain (), domain))
6113           {
6114             int cmp;
6115
6116             cmp = (int) '_' - (int) sym->linkage_name ()[0];
6117             if (cmp == 0)
6118               {
6119                 cmp = !startswith (sym->linkage_name (), "_ada_");
6120                 if (cmp == 0)
6121                   cmp = strncmp (name, sym->linkage_name () + 5,
6122                                  name_len);
6123               }
6124
6125             if (cmp == 0
6126                 && is_name_suffix (sym->linkage_name () + name_len + 5))
6127               {
6128                 if (sym->aclass () != LOC_UNRESOLVED)
6129                   {
6130                     if (sym->is_argument ())
6131                       arg_sym = sym;
6132                     else
6133                       {
6134                         found_sym = true;
6135                         add_defn_to_vec (result,
6136                                          fixup_symbol_section (sym, objfile),
6137                                          block);
6138                       }
6139                   }
6140               }
6141           }
6142       }
6143
6144       /* NOTE: This really shouldn't be needed for _ada_ symbols.
6145          They aren't parameters, right?  */
6146       if (!found_sym && arg_sym != NULL)
6147         {
6148           add_defn_to_vec (result,
6149                            fixup_symbol_section (arg_sym, objfile),
6150                            block);
6151         }
6152     }
6153 }
6154 \f
6155
6156                                 /* Symbol Completion */
6157
6158 /* See symtab.h.  */
6159
6160 bool
6161 ada_lookup_name_info::matches
6162   (const char *sym_name,
6163    symbol_name_match_type match_type,
6164    completion_match_result *comp_match_res) const
6165 {
6166   bool match = false;
6167   const char *text = m_encoded_name.c_str ();
6168   size_t text_len = m_encoded_name.size ();
6169
6170   /* First, test against the fully qualified name of the symbol.  */
6171
6172   if (strncmp (sym_name, text, text_len) == 0)
6173     match = true;
6174
6175   std::string decoded_name = ada_decode (sym_name);
6176   if (match && !m_encoded_p)
6177     {
6178       /* One needed check before declaring a positive match is to verify
6179          that iff we are doing a verbatim match, the decoded version
6180          of the symbol name starts with '<'.  Otherwise, this symbol name
6181          is not a suitable completion.  */
6182
6183       bool has_angle_bracket = (decoded_name[0] == '<');
6184       match = (has_angle_bracket == m_verbatim_p);
6185     }
6186
6187   if (match && !m_verbatim_p)
6188     {
6189       /* When doing non-verbatim match, another check that needs to
6190          be done is to verify that the potentially matching symbol name
6191          does not include capital letters, because the ada-mode would
6192          not be able to understand these symbol names without the
6193          angle bracket notation.  */
6194       const char *tmp;
6195
6196       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6197       if (*tmp != '\0')
6198         match = false;
6199     }
6200
6201   /* Second: Try wild matching...  */
6202
6203   if (!match && m_wild_match_p)
6204     {
6205       /* Since we are doing wild matching, this means that TEXT
6206          may represent an unqualified symbol name.  We therefore must
6207          also compare TEXT against the unqualified name of the symbol.  */
6208       sym_name = ada_unqualified_name (decoded_name.c_str ());
6209
6210       if (strncmp (sym_name, text, text_len) == 0)
6211         match = true;
6212     }
6213
6214   /* Finally: If we found a match, prepare the result to return.  */
6215
6216   if (!match)
6217     return false;
6218
6219   if (comp_match_res != NULL)
6220     {
6221       std::string &match_str = comp_match_res->match.storage ();
6222
6223       if (!m_encoded_p)
6224         match_str = ada_decode (sym_name);
6225       else
6226         {
6227           if (m_verbatim_p)
6228             match_str = add_angle_brackets (sym_name);
6229           else
6230             match_str = sym_name;
6231
6232         }
6233
6234       comp_match_res->set_match (match_str.c_str ());
6235     }
6236
6237   return true;
6238 }
6239
6240                                 /* Field Access */
6241
6242 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6243    for tagged types.  */
6244
6245 static int
6246 ada_is_dispatch_table_ptr_type (struct type *type)
6247 {
6248   const char *name;
6249
6250   if (type->code () != TYPE_CODE_PTR)
6251     return 0;
6252
6253   name = TYPE_TARGET_TYPE (type)->name ();
6254   if (name == NULL)
6255     return 0;
6256
6257   return (strcmp (name, "ada__tags__dispatch_table") == 0);
6258 }
6259
6260 /* Return non-zero if TYPE is an interface tag.  */
6261
6262 static int
6263 ada_is_interface_tag (struct type *type)
6264 {
6265   const char *name = type->name ();
6266
6267   if (name == NULL)
6268     return 0;
6269
6270   return (strcmp (name, "ada__tags__interface_tag") == 0);
6271 }
6272
6273 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6274    to be invisible to users.  */
6275
6276 int
6277 ada_is_ignored_field (struct type *type, int field_num)
6278 {
6279   if (field_num < 0 || field_num > type->num_fields ())
6280     return 1;
6281
6282   /* Check the name of that field.  */
6283   {
6284     const char *name = type->field (field_num).name ();
6285
6286     /* Anonymous field names should not be printed.
6287        brobecker/2007-02-20: I don't think this can actually happen
6288        but we don't want to print the value of anonymous fields anyway.  */
6289     if (name == NULL)
6290       return 1;
6291
6292     /* Normally, fields whose name start with an underscore ("_")
6293        are fields that have been internally generated by the compiler,
6294        and thus should not be printed.  The "_parent" field is special,
6295        however: This is a field internally generated by the compiler
6296        for tagged types, and it contains the components inherited from
6297        the parent type.  This field should not be printed as is, but
6298        should not be ignored either.  */
6299     if (name[0] == '_' && !startswith (name, "_parent"))
6300       return 1;
6301
6302     /* The compiler doesn't document this, but sometimes it emits
6303        a field whose name starts with a capital letter, like 'V148s'.
6304        These aren't marked as artificial in any way, but we know they
6305        should be ignored.  However, wrapper fields should not be
6306        ignored.  */
6307     if (name[0] == 'S' || name[0] == 'R' || name[0] == 'O')
6308       {
6309         /* Wrapper field.  */
6310       }
6311     else if (isupper (name[0]))
6312       return 1;
6313   }
6314
6315   /* If this is the dispatch table of a tagged type or an interface tag,
6316      then ignore.  */
6317   if (ada_is_tagged_type (type, 1)
6318       && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
6319           || ada_is_interface_tag (type->field (field_num).type ())))
6320     return 1;
6321
6322   /* Not a special field, so it should not be ignored.  */
6323   return 0;
6324 }
6325
6326 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
6327    pointer or reference type whose ultimate target has a tag field.  */
6328
6329 int
6330 ada_is_tagged_type (struct type *type, int refok)
6331 {
6332   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6333 }
6334
6335 /* True iff TYPE represents the type of X'Tag */
6336
6337 int
6338 ada_is_tag_type (struct type *type)
6339 {
6340   type = ada_check_typedef (type);
6341
6342   if (type == NULL || type->code () != TYPE_CODE_PTR)
6343     return 0;
6344   else
6345     {
6346       const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6347
6348       return (name != NULL
6349               && strcmp (name, "ada__tags__dispatch_table") == 0);
6350     }
6351 }
6352
6353 /* The type of the tag on VAL.  */
6354
6355 static struct type *
6356 ada_tag_type (struct value *val)
6357 {
6358   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6359 }
6360
6361 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6362    retired at Ada 05).  */
6363
6364 static int
6365 is_ada95_tag (struct value *tag)
6366 {
6367   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6368 }
6369
6370 /* The value of the tag on VAL.  */
6371
6372 static struct value *
6373 ada_value_tag (struct value *val)
6374 {
6375   return ada_value_struct_elt (val, "_tag", 0);
6376 }
6377
6378 /* The value of the tag on the object of type TYPE whose contents are
6379    saved at VALADDR, if it is non-null, or is at memory address
6380    ADDRESS.  */
6381
6382 static struct value *
6383 value_tag_from_contents_and_address (struct type *type,
6384                                      const gdb_byte *valaddr,
6385                                      CORE_ADDR address)
6386 {
6387   int tag_byte_offset;
6388   struct type *tag_type;
6389
6390   gdb::array_view<const gdb_byte> contents;
6391   if (valaddr != nullptr)
6392     contents = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
6393   struct type *resolved_type = resolve_dynamic_type (type, contents, address);
6394   if (find_struct_field ("_tag", resolved_type, 0, &tag_type, &tag_byte_offset,
6395                          NULL, NULL, NULL))
6396     {
6397       const gdb_byte *valaddr1 = ((valaddr == NULL)
6398                                   ? NULL
6399                                   : valaddr + tag_byte_offset);
6400       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6401
6402       return value_from_contents_and_address (tag_type, valaddr1, address1);
6403     }
6404   return NULL;
6405 }
6406
6407 static struct type *
6408 type_from_tag (struct value *tag)
6409 {
6410   gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6411
6412   if (type_name != NULL)
6413     return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6414   return NULL;
6415 }
6416
6417 /* Given a value OBJ of a tagged type, return a value of this
6418    type at the base address of the object.  The base address, as
6419    defined in Ada.Tags, it is the address of the primary tag of
6420    the object, and therefore where the field values of its full
6421    view can be fetched.  */
6422
6423 struct value *
6424 ada_tag_value_at_base_address (struct value *obj)
6425 {
6426   struct value *val;
6427   LONGEST offset_to_top = 0;
6428   struct type *ptr_type, *obj_type;
6429   struct value *tag;
6430   CORE_ADDR base_address;
6431
6432   obj_type = value_type (obj);
6433
6434   /* It is the responsability of the caller to deref pointers.  */
6435
6436   if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6437     return obj;
6438
6439   tag = ada_value_tag (obj);
6440   if (!tag)
6441     return obj;
6442
6443   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6444
6445   if (is_ada95_tag (tag))
6446     return obj;
6447
6448   struct type *offset_type
6449     = language_lookup_primitive_type (language_def (language_ada),
6450                                       target_gdbarch(), "storage_offset");
6451   ptr_type = lookup_pointer_type (offset_type);
6452   val = value_cast (ptr_type, tag);
6453   if (!val)
6454     return obj;
6455
6456   /* It is perfectly possible that an exception be raised while
6457      trying to determine the base address, just like for the tag;
6458      see ada_tag_name for more details.  We do not print the error
6459      message for the same reason.  */
6460
6461   try
6462     {
6463       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6464     }
6465
6466   catch (const gdb_exception_error &e)
6467     {
6468       return obj;
6469     }
6470
6471   /* If offset is null, nothing to do.  */
6472
6473   if (offset_to_top == 0)
6474     return obj;
6475
6476   /* -1 is a special case in Ada.Tags; however, what should be done
6477      is not quite clear from the documentation.  So do nothing for
6478      now.  */
6479
6480   if (offset_to_top == -1)
6481     return obj;
6482
6483   /* Storage_Offset'Last is used to indicate that a dynamic offset to
6484      top is used.  In this situation the offset is stored just after
6485      the tag, in the object itself.  */
6486   ULONGEST last = (((ULONGEST) 1) << (8 * TYPE_LENGTH (offset_type) - 1)) - 1;
6487   if (offset_to_top == last)
6488     {
6489       struct value *tem = value_addr (tag);
6490       tem = value_ptradd (tem, 1);
6491       tem = value_cast (ptr_type, tem);
6492       offset_to_top = value_as_long (value_ind (tem));
6493     }
6494   else if (offset_to_top > 0)
6495     {
6496       /* OFFSET_TO_TOP used to be a positive value to be subtracted
6497          from the base address.  This was however incompatible with
6498          C++ dispatch table: C++ uses a *negative* value to *add*
6499          to the base address.  Ada's convention has therefore been
6500          changed in GNAT 19.0w 20171023: since then, C++ and Ada
6501          use the same convention.  Here, we support both cases by
6502          checking the sign of OFFSET_TO_TOP.  */
6503       offset_to_top = -offset_to_top;
6504     }
6505
6506   base_address = value_address (obj) + offset_to_top;
6507   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6508
6509   /* Make sure that we have a proper tag at the new address.
6510      Otherwise, offset_to_top is bogus (which can happen when
6511      the object is not initialized yet).  */
6512
6513   if (!tag)
6514     return obj;
6515
6516   obj_type = type_from_tag (tag);
6517
6518   if (!obj_type)
6519     return obj;
6520
6521   return value_from_contents_and_address (obj_type, NULL, base_address);
6522 }
6523
6524 /* Return the "ada__tags__type_specific_data" type.  */
6525
6526 static struct type *
6527 ada_get_tsd_type (struct inferior *inf)
6528 {
6529   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6530
6531   if (data->tsd_type == 0)
6532     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6533   return data->tsd_type;
6534 }
6535
6536 /* Return the TSD (type-specific data) associated to the given TAG.
6537    TAG is assumed to be the tag of a tagged-type entity.
6538
6539    May return NULL if we are unable to get the TSD.  */
6540
6541 static struct value *
6542 ada_get_tsd_from_tag (struct value *tag)
6543 {
6544   struct value *val;
6545   struct type *type;
6546
6547   /* First option: The TSD is simply stored as a field of our TAG.
6548      Only older versions of GNAT would use this format, but we have
6549      to test it first, because there are no visible markers for
6550      the current approach except the absence of that field.  */
6551
6552   val = ada_value_struct_elt (tag, "tsd", 1);
6553   if (val)
6554     return val;
6555
6556   /* Try the second representation for the dispatch table (in which
6557      there is no explicit 'tsd' field in the referent of the tag pointer,
6558      and instead the tsd pointer is stored just before the dispatch
6559      table.  */
6560
6561   type = ada_get_tsd_type (current_inferior());
6562   if (type == NULL)
6563     return NULL;
6564   type = lookup_pointer_type (lookup_pointer_type (type));
6565   val = value_cast (type, tag);
6566   if (val == NULL)
6567     return NULL;
6568   return value_ind (value_ptradd (val, -1));
6569 }
6570
6571 /* Given the TSD of a tag (type-specific data), return a string
6572    containing the name of the associated type.
6573
6574    May return NULL if we are unable to determine the tag name.  */
6575
6576 static gdb::unique_xmalloc_ptr<char>
6577 ada_tag_name_from_tsd (struct value *tsd)
6578 {
6579   struct value *val;
6580
6581   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6582   if (val == NULL)
6583     return NULL;
6584   gdb::unique_xmalloc_ptr<char> buffer
6585     = target_read_string (value_as_address (val), INT_MAX);
6586   if (buffer == nullptr)
6587     return nullptr;
6588
6589   try
6590     {
6591       /* Let this throw an exception on error.  If the data is
6592          uninitialized, we'd rather not have the user see a
6593          warning.  */
6594       const char *folded = ada_fold_name (buffer.get (), true);
6595       return make_unique_xstrdup (folded);
6596     }
6597   catch (const gdb_exception &)
6598     {
6599       return nullptr;
6600     }
6601 }
6602
6603 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6604    a C string.
6605
6606    Return NULL if the TAG is not an Ada tag, or if we were unable to
6607    determine the name of that tag.  */
6608
6609 gdb::unique_xmalloc_ptr<char>
6610 ada_tag_name (struct value *tag)
6611 {
6612   gdb::unique_xmalloc_ptr<char> name;
6613
6614   if (!ada_is_tag_type (value_type (tag)))
6615     return NULL;
6616
6617   /* It is perfectly possible that an exception be raised while trying
6618      to determine the TAG's name, even under normal circumstances:
6619      The associated variable may be uninitialized or corrupted, for
6620      instance. We do not let any exception propagate past this point.
6621      instead we return NULL.
6622
6623      We also do not print the error message either (which often is very
6624      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6625      the caller print a more meaningful message if necessary.  */
6626   try
6627     {
6628       struct value *tsd = ada_get_tsd_from_tag (tag);
6629
6630       if (tsd != NULL)
6631         name = ada_tag_name_from_tsd (tsd);
6632     }
6633   catch (const gdb_exception_error &e)
6634     {
6635     }
6636
6637   return name;
6638 }
6639
6640 /* The parent type of TYPE, or NULL if none.  */
6641
6642 struct type *
6643 ada_parent_type (struct type *type)
6644 {
6645   int i;
6646
6647   type = ada_check_typedef (type);
6648
6649   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6650     return NULL;
6651
6652   for (i = 0; i < type->num_fields (); i += 1)
6653     if (ada_is_parent_field (type, i))
6654       {
6655         struct type *parent_type = type->field (i).type ();
6656
6657         /* If the _parent field is a pointer, then dereference it.  */
6658         if (parent_type->code () == TYPE_CODE_PTR)
6659           parent_type = TYPE_TARGET_TYPE (parent_type);
6660         /* If there is a parallel XVS type, get the actual base type.  */
6661         parent_type = ada_get_base_type (parent_type);
6662
6663         return ada_check_typedef (parent_type);
6664       }
6665
6666   return NULL;
6667 }
6668
6669 /* True iff field number FIELD_NUM of structure type TYPE contains the
6670    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6671    a structure type with at least FIELD_NUM+1 fields.  */
6672
6673 int
6674 ada_is_parent_field (struct type *type, int field_num)
6675 {
6676   const char *name = ada_check_typedef (type)->field (field_num).name ();
6677
6678   return (name != NULL
6679           && (startswith (name, "PARENT")
6680               || startswith (name, "_parent")));
6681 }
6682
6683 /* True iff field number FIELD_NUM of structure type TYPE is a
6684    transparent wrapper field (which should be silently traversed when doing
6685    field selection and flattened when printing).  Assumes TYPE is a
6686    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6687    structures.  */
6688
6689 int
6690 ada_is_wrapper_field (struct type *type, int field_num)
6691 {
6692   const char *name = type->field (field_num).name ();
6693
6694   if (name != NULL && strcmp (name, "RETVAL") == 0)
6695     {
6696       /* This happens in functions with "out" or "in out" parameters
6697          which are passed by copy.  For such functions, GNAT describes
6698          the function's return type as being a struct where the return
6699          value is in a field called RETVAL, and where the other "out"
6700          or "in out" parameters are fields of that struct.  This is not
6701          a wrapper.  */
6702       return 0;
6703     }
6704
6705   return (name != NULL
6706           && (startswith (name, "PARENT")
6707               || strcmp (name, "REP") == 0
6708               || startswith (name, "_parent")
6709               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6710 }
6711
6712 /* True iff field number FIELD_NUM of structure or union type TYPE
6713    is a variant wrapper.  Assumes TYPE is a structure type with at least
6714    FIELD_NUM+1 fields.  */
6715
6716 int
6717 ada_is_variant_part (struct type *type, int field_num)
6718 {
6719   /* Only Ada types are eligible.  */
6720   if (!ADA_TYPE_P (type))
6721     return 0;
6722
6723   struct type *field_type = type->field (field_num).type ();
6724
6725   return (field_type->code () == TYPE_CODE_UNION
6726           || (is_dynamic_field (type, field_num)
6727               && (TYPE_TARGET_TYPE (field_type)->code ()
6728                   == TYPE_CODE_UNION)));
6729 }
6730
6731 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6732    whose discriminants are contained in the record type OUTER_TYPE,
6733    returns the type of the controlling discriminant for the variant.
6734    May return NULL if the type could not be found.  */
6735
6736 struct type *
6737 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6738 {
6739   const char *name = ada_variant_discrim_name (var_type);
6740
6741   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6742 }
6743
6744 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6745    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6746    represents a 'when others' clause; otherwise 0.  */
6747
6748 static int
6749 ada_is_others_clause (struct type *type, int field_num)
6750 {
6751   const char *name = type->field (field_num).name ();
6752
6753   return (name != NULL && name[0] == 'O');
6754 }
6755
6756 /* Assuming that TYPE0 is the type of the variant part of a record,
6757    returns the name of the discriminant controlling the variant.
6758    The value is valid until the next call to ada_variant_discrim_name.  */
6759
6760 const char *
6761 ada_variant_discrim_name (struct type *type0)
6762 {
6763   static std::string result;
6764   struct type *type;
6765   const char *name;
6766   const char *discrim_end;
6767   const char *discrim_start;
6768
6769   if (type0->code () == TYPE_CODE_PTR)
6770     type = TYPE_TARGET_TYPE (type0);
6771   else
6772     type = type0;
6773
6774   name = ada_type_name (type);
6775
6776   if (name == NULL || name[0] == '\000')
6777     return "";
6778
6779   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6780        discrim_end -= 1)
6781     {
6782       if (startswith (discrim_end, "___XVN"))
6783         break;
6784     }
6785   if (discrim_end == name)
6786     return "";
6787
6788   for (discrim_start = discrim_end; discrim_start != name + 3;
6789        discrim_start -= 1)
6790     {
6791       if (discrim_start == name + 1)
6792         return "";
6793       if ((discrim_start > name + 3
6794            && startswith (discrim_start - 3, "___"))
6795           || discrim_start[-1] == '.')
6796         break;
6797     }
6798
6799   result = std::string (discrim_start, discrim_end - discrim_start);
6800   return result.c_str ();
6801 }
6802
6803 /* Scan STR for a subtype-encoded number, beginning at position K.
6804    Put the position of the character just past the number scanned in
6805    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
6806    Return 1 if there was a valid number at the given position, and 0
6807    otherwise.  A "subtype-encoded" number consists of the absolute value
6808    in decimal, followed by the letter 'm' to indicate a negative number.
6809    Assumes 0m does not occur.  */
6810
6811 int
6812 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6813 {
6814   ULONGEST RU;
6815
6816   if (!isdigit (str[k]))
6817     return 0;
6818
6819   /* Do it the hard way so as not to make any assumption about
6820      the relationship of unsigned long (%lu scan format code) and
6821      LONGEST.  */
6822   RU = 0;
6823   while (isdigit (str[k]))
6824     {
6825       RU = RU * 10 + (str[k] - '0');
6826       k += 1;
6827     }
6828
6829   if (str[k] == 'm')
6830     {
6831       if (R != NULL)
6832         *R = (-(LONGEST) (RU - 1)) - 1;
6833       k += 1;
6834     }
6835   else if (R != NULL)
6836     *R = (LONGEST) RU;
6837
6838   /* NOTE on the above: Technically, C does not say what the results of
6839      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6840      number representable as a LONGEST (although either would probably work
6841      in most implementations).  When RU>0, the locution in the then branch
6842      above is always equivalent to the negative of RU.  */
6843
6844   if (new_k != NULL)
6845     *new_k = k;
6846   return 1;
6847 }
6848
6849 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6850    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6851    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
6852
6853 static int
6854 ada_in_variant (LONGEST val, struct type *type, int field_num)
6855 {
6856   const char *name = type->field (field_num).name ();
6857   int p;
6858
6859   p = 0;
6860   while (1)
6861     {
6862       switch (name[p])
6863         {
6864         case '\0':
6865           return 0;
6866         case 'S':
6867           {
6868             LONGEST W;
6869
6870             if (!ada_scan_number (name, p + 1, &W, &p))
6871               return 0;
6872             if (val == W)
6873               return 1;
6874             break;
6875           }
6876         case 'R':
6877           {
6878             LONGEST L, U;
6879
6880             if (!ada_scan_number (name, p + 1, &L, &p)
6881                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6882               return 0;
6883             if (val >= L && val <= U)
6884               return 1;
6885             break;
6886           }
6887         case 'O':
6888           return 1;
6889         default:
6890           return 0;
6891         }
6892     }
6893 }
6894
6895 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
6896
6897 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6898    ARG_TYPE, extract and return the value of one of its (non-static)
6899    fields.  FIELDNO says which field.   Differs from value_primitive_field
6900    only in that it can handle packed values of arbitrary type.  */
6901
6902 struct value *
6903 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6904                            struct type *arg_type)
6905 {
6906   struct type *type;
6907
6908   arg_type = ada_check_typedef (arg_type);
6909   type = arg_type->field (fieldno).type ();
6910
6911   /* Handle packed fields.  It might be that the field is not packed
6912      relative to its containing structure, but the structure itself is
6913      packed; in this case we must take the bit-field path.  */
6914   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6915     {
6916       int bit_pos = arg_type->field (fieldno).loc_bitpos ();
6917       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6918
6919       return ada_value_primitive_packed_val (arg1,
6920                                              value_contents (arg1).data (),
6921                                              offset + bit_pos / 8,
6922                                              bit_pos % 8, bit_size, type);
6923     }
6924   else
6925     return value_primitive_field (arg1, offset, fieldno, arg_type);
6926 }
6927
6928 /* Find field with name NAME in object of type TYPE.  If found, 
6929    set the following for each argument that is non-null:
6930     - *FIELD_TYPE_P to the field's type; 
6931     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
6932       an object of that type;
6933     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
6934     - *BIT_SIZE_P to its size in bits if the field is packed, and 
6935       0 otherwise;
6936    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6937    fields up to but not including the desired field, or by the total
6938    number of fields if not found.   A NULL value of NAME never
6939    matches; the function just counts visible fields in this case.
6940    
6941    Notice that we need to handle when a tagged record hierarchy
6942    has some components with the same name, like in this scenario:
6943
6944       type Top_T is tagged record
6945          N : Integer := 1;
6946          U : Integer := 974;
6947          A : Integer := 48;
6948       end record;
6949
6950       type Middle_T is new Top.Top_T with record
6951          N : Character := 'a';
6952          C : Integer := 3;
6953       end record;
6954
6955      type Bottom_T is new Middle.Middle_T with record
6956         N : Float := 4.0;
6957         C : Character := '5';
6958         X : Integer := 6;
6959         A : Character := 'J';
6960      end record;
6961
6962    Let's say we now have a variable declared and initialized as follow:
6963
6964      TC : Top_A := new Bottom_T;
6965
6966    And then we use this variable to call this function
6967
6968      procedure Assign (Obj: in out Top_T; TV : Integer);
6969
6970    as follow:
6971
6972       Assign (Top_T (B), 12);
6973
6974    Now, we're in the debugger, and we're inside that procedure
6975    then and we want to print the value of obj.c:
6976
6977    Usually, the tagged record or one of the parent type owns the
6978    component to print and there's no issue but in this particular
6979    case, what does it mean to ask for Obj.C? Since the actual
6980    type for object is type Bottom_T, it could mean two things: type
6981    component C from the Middle_T view, but also component C from
6982    Bottom_T.  So in that "undefined" case, when the component is
6983    not found in the non-resolved type (which includes all the
6984    components of the parent type), then resolve it and see if we
6985    get better luck once expanded.
6986
6987    In the case of homonyms in the derived tagged type, we don't
6988    guaranty anything, and pick the one that's easiest for us
6989    to program.
6990
6991    Returns 1 if found, 0 otherwise.  */
6992
6993 static int
6994 find_struct_field (const char *name, struct type *type, int offset,
6995                    struct type **field_type_p,
6996                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6997                    int *index_p)
6998 {
6999   int i;
7000   int parent_offset = -1;
7001
7002   type = ada_check_typedef (type);
7003
7004   if (field_type_p != NULL)
7005     *field_type_p = NULL;
7006   if (byte_offset_p != NULL)
7007     *byte_offset_p = 0;
7008   if (bit_offset_p != NULL)
7009     *bit_offset_p = 0;
7010   if (bit_size_p != NULL)
7011     *bit_size_p = 0;
7012
7013   for (i = 0; i < type->num_fields (); i += 1)
7014     {
7015       /* These can't be computed using TYPE_FIELD_BITPOS for a dynamic
7016          type.  However, we only need the values to be correct when
7017          the caller asks for them.  */
7018       int bit_pos = 0, fld_offset = 0;
7019       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7020         {
7021           bit_pos = type->field (i).loc_bitpos ();
7022           fld_offset = offset + bit_pos / 8;
7023         }
7024
7025       const char *t_field_name = type->field (i).name ();
7026
7027       if (t_field_name == NULL)
7028         continue;
7029
7030       else if (ada_is_parent_field (type, i))
7031         {
7032           /* This is a field pointing us to the parent type of a tagged
7033              type.  As hinted in this function's documentation, we give
7034              preference to fields in the current record first, so what
7035              we do here is just record the index of this field before
7036              we skip it.  If it turns out we couldn't find our field
7037              in the current record, then we'll get back to it and search
7038              inside it whether the field might exist in the parent.  */
7039
7040           parent_offset = i;
7041           continue;
7042         }
7043
7044       else if (name != NULL && field_name_match (t_field_name, name))
7045         {
7046           int bit_size = TYPE_FIELD_BITSIZE (type, i);
7047
7048           if (field_type_p != NULL)
7049             *field_type_p = type->field (i).type ();
7050           if (byte_offset_p != NULL)
7051             *byte_offset_p = fld_offset;
7052           if (bit_offset_p != NULL)
7053             *bit_offset_p = bit_pos % 8;
7054           if (bit_size_p != NULL)
7055             *bit_size_p = bit_size;
7056           return 1;
7057         }
7058       else if (ada_is_wrapper_field (type, i))
7059         {
7060           if (find_struct_field (name, type->field (i).type (), fld_offset,
7061                                  field_type_p, byte_offset_p, bit_offset_p,
7062                                  bit_size_p, index_p))
7063             return 1;
7064         }
7065       else if (ada_is_variant_part (type, i))
7066         {
7067           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
7068              fixed type?? */
7069           int j;
7070           struct type *field_type
7071             = ada_check_typedef (type->field (i).type ());
7072
7073           for (j = 0; j < field_type->num_fields (); j += 1)
7074             {
7075               if (find_struct_field (name, field_type->field (j).type (),
7076                                      fld_offset
7077                                      + field_type->field (j).loc_bitpos () / 8,
7078                                      field_type_p, byte_offset_p,
7079                                      bit_offset_p, bit_size_p, index_p))
7080                 return 1;
7081             }
7082         }
7083       else if (index_p != NULL)
7084         *index_p += 1;
7085     }
7086
7087   /* Field not found so far.  If this is a tagged type which
7088      has a parent, try finding that field in the parent now.  */
7089
7090   if (parent_offset != -1)
7091     {
7092       /* As above, only compute the offset when truly needed.  */
7093       int fld_offset = offset;
7094       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7095         {
7096           int bit_pos = type->field (parent_offset).loc_bitpos ();
7097           fld_offset += bit_pos / 8;
7098         }
7099
7100       if (find_struct_field (name, type->field (parent_offset).type (),
7101                              fld_offset, field_type_p, byte_offset_p,
7102                              bit_offset_p, bit_size_p, index_p))
7103         return 1;
7104     }
7105
7106   return 0;
7107 }
7108
7109 /* Number of user-visible fields in record type TYPE.  */
7110
7111 static int
7112 num_visible_fields (struct type *type)
7113 {
7114   int n;
7115
7116   n = 0;
7117   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7118   return n;
7119 }
7120
7121 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
7122    and search in it assuming it has (class) type TYPE.
7123    If found, return value, else return NULL.
7124
7125    Searches recursively through wrapper fields (e.g., '_parent').
7126
7127    In the case of homonyms in the tagged types, please refer to the
7128    long explanation in find_struct_field's function documentation.  */
7129
7130 static struct value *
7131 ada_search_struct_field (const char *name, struct value *arg, int offset,
7132                          struct type *type)
7133 {
7134   int i;
7135   int parent_offset = -1;
7136
7137   type = ada_check_typedef (type);
7138   for (i = 0; i < type->num_fields (); i += 1)
7139     {
7140       const char *t_field_name = type->field (i).name ();
7141
7142       if (t_field_name == NULL)
7143         continue;
7144
7145       else if (ada_is_parent_field (type, i))
7146         {
7147           /* This is a field pointing us to the parent type of a tagged
7148              type.  As hinted in this function's documentation, we give
7149              preference to fields in the current record first, so what
7150              we do here is just record the index of this field before
7151              we skip it.  If it turns out we couldn't find our field
7152              in the current record, then we'll get back to it and search
7153              inside it whether the field might exist in the parent.  */
7154
7155           parent_offset = i;
7156           continue;
7157         }
7158
7159       else if (field_name_match (t_field_name, name))
7160         return ada_value_primitive_field (arg, offset, i, type);
7161
7162       else if (ada_is_wrapper_field (type, i))
7163         {
7164           struct value *v =     /* Do not let indent join lines here.  */
7165             ada_search_struct_field (name, arg,
7166                                      offset + type->field (i).loc_bitpos () / 8,
7167                                      type->field (i).type ());
7168
7169           if (v != NULL)
7170             return v;
7171         }
7172
7173       else if (ada_is_variant_part (type, i))
7174         {
7175           /* PNH: Do we ever get here?  See find_struct_field.  */
7176           int j;
7177           struct type *field_type = ada_check_typedef (type->field (i).type ());
7178           int var_offset = offset + type->field (i).loc_bitpos () / 8;
7179
7180           for (j = 0; j < field_type->num_fields (); j += 1)
7181             {
7182               struct value *v = ada_search_struct_field /* Force line
7183                                                            break.  */
7184                 (name, arg,
7185                  var_offset + field_type->field (j).loc_bitpos () / 8,
7186                  field_type->field (j).type ());
7187
7188               if (v != NULL)
7189                 return v;
7190             }
7191         }
7192     }
7193
7194   /* Field not found so far.  If this is a tagged type which
7195      has a parent, try finding that field in the parent now.  */
7196
7197   if (parent_offset != -1)
7198     {
7199       struct value *v = ada_search_struct_field (
7200         name, arg, offset + type->field (parent_offset).loc_bitpos () / 8,
7201         type->field (parent_offset).type ());
7202
7203       if (v != NULL)
7204         return v;
7205     }
7206
7207   return NULL;
7208 }
7209
7210 static struct value *ada_index_struct_field_1 (int *, struct value *,
7211                                                int, struct type *);
7212
7213
7214 /* Return field #INDEX in ARG, where the index is that returned by
7215  * find_struct_field through its INDEX_P argument.  Adjust the address
7216  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7217  * If found, return value, else return NULL.  */
7218
7219 static struct value *
7220 ada_index_struct_field (int index, struct value *arg, int offset,
7221                         struct type *type)
7222 {
7223   return ada_index_struct_field_1 (&index, arg, offset, type);
7224 }
7225
7226
7227 /* Auxiliary function for ada_index_struct_field.  Like
7228  * ada_index_struct_field, but takes index from *INDEX_P and modifies
7229  * *INDEX_P.  */
7230
7231 static struct value *
7232 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7233                           struct type *type)
7234 {
7235   int i;
7236   type = ada_check_typedef (type);
7237
7238   for (i = 0; i < type->num_fields (); i += 1)
7239     {
7240       if (type->field (i).name () == NULL)
7241         continue;
7242       else if (ada_is_wrapper_field (type, i))
7243         {
7244           struct value *v =     /* Do not let indent join lines here.  */
7245             ada_index_struct_field_1 (index_p, arg,
7246                                       offset + type->field (i).loc_bitpos () / 8,
7247                                       type->field (i).type ());
7248
7249           if (v != NULL)
7250             return v;
7251         }
7252
7253       else if (ada_is_variant_part (type, i))
7254         {
7255           /* PNH: Do we ever get here?  See ada_search_struct_field,
7256              find_struct_field.  */
7257           error (_("Cannot assign this kind of variant record"));
7258         }
7259       else if (*index_p == 0)
7260         return ada_value_primitive_field (arg, offset, i, type);
7261       else
7262         *index_p -= 1;
7263     }
7264   return NULL;
7265 }
7266
7267 /* Return a string representation of type TYPE.  */
7268
7269 static std::string
7270 type_as_string (struct type *type)
7271 {
7272   string_file tmp_stream;
7273
7274   type_print (type, "", &tmp_stream, -1);
7275
7276   return tmp_stream.release ();
7277 }
7278
7279 /* Given a type TYPE, look up the type of the component of type named NAME.
7280    If DISPP is non-null, add its byte displacement from the beginning of a
7281    structure (pointed to by a value) of type TYPE to *DISPP (does not
7282    work for packed fields).
7283
7284    Matches any field whose name has NAME as a prefix, possibly
7285    followed by "___".
7286
7287    TYPE can be either a struct or union.  If REFOK, TYPE may also 
7288    be a (pointer or reference)+ to a struct or union, and the
7289    ultimate target type will be searched.
7290
7291    Looks recursively into variant clauses and parent types.
7292
7293    In the case of homonyms in the tagged types, please refer to the
7294    long explanation in find_struct_field's function documentation.
7295
7296    If NOERR is nonzero, return NULL if NAME is not suitably defined or
7297    TYPE is not a type of the right kind.  */
7298
7299 static struct type *
7300 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7301                             int noerr)
7302 {
7303   int i;
7304   int parent_offset = -1;
7305
7306   if (name == NULL)
7307     goto BadName;
7308
7309   if (refok && type != NULL)
7310     while (1)
7311       {
7312         type = ada_check_typedef (type);
7313         if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
7314           break;
7315         type = TYPE_TARGET_TYPE (type);
7316       }
7317
7318   if (type == NULL
7319       || (type->code () != TYPE_CODE_STRUCT
7320           && type->code () != TYPE_CODE_UNION))
7321     {
7322       if (noerr)
7323         return NULL;
7324
7325       error (_("Type %s is not a structure or union type"),
7326              type != NULL ? type_as_string (type).c_str () : _("(null)"));
7327     }
7328
7329   type = to_static_fixed_type (type);
7330
7331   for (i = 0; i < type->num_fields (); i += 1)
7332     {
7333       const char *t_field_name = type->field (i).name ();
7334       struct type *t;
7335
7336       if (t_field_name == NULL)
7337         continue;
7338
7339       else if (ada_is_parent_field (type, i))
7340         {
7341           /* This is a field pointing us to the parent type of a tagged
7342              type.  As hinted in this function's documentation, we give
7343              preference to fields in the current record first, so what
7344              we do here is just record the index of this field before
7345              we skip it.  If it turns out we couldn't find our field
7346              in the current record, then we'll get back to it and search
7347              inside it whether the field might exist in the parent.  */
7348
7349           parent_offset = i;
7350           continue;
7351         }
7352
7353       else if (field_name_match (t_field_name, name))
7354         return type->field (i).type ();
7355
7356       else if (ada_is_wrapper_field (type, i))
7357         {
7358           t = ada_lookup_struct_elt_type (type->field (i).type (), name,
7359                                           0, 1);
7360           if (t != NULL)
7361             return t;
7362         }
7363
7364       else if (ada_is_variant_part (type, i))
7365         {
7366           int j;
7367           struct type *field_type = ada_check_typedef (type->field (i).type ());
7368
7369           for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
7370             {
7371               /* FIXME pnh 2008/01/26: We check for a field that is
7372                  NOT wrapped in a struct, since the compiler sometimes
7373                  generates these for unchecked variant types.  Revisit
7374                  if the compiler changes this practice.  */
7375               const char *v_field_name = field_type->field (j).name ();
7376
7377               if (v_field_name != NULL 
7378                   && field_name_match (v_field_name, name))
7379                 t = field_type->field (j).type ();
7380               else
7381                 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
7382                                                 name, 0, 1);
7383
7384               if (t != NULL)
7385                 return t;
7386             }
7387         }
7388
7389     }
7390
7391     /* Field not found so far.  If this is a tagged type which
7392        has a parent, try finding that field in the parent now.  */
7393
7394     if (parent_offset != -1)
7395       {
7396         struct type *t;
7397
7398         t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
7399                                         name, 0, 1);
7400         if (t != NULL)
7401           return t;
7402       }
7403
7404 BadName:
7405   if (!noerr)
7406     {
7407       const char *name_str = name != NULL ? name : _("<null>");
7408
7409       error (_("Type %s has no component named %s"),
7410              type_as_string (type).c_str (), name_str);
7411     }
7412
7413   return NULL;
7414 }
7415
7416 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7417    within a value of type OUTER_TYPE, return true iff VAR_TYPE
7418    represents an unchecked union (that is, the variant part of a
7419    record that is named in an Unchecked_Union pragma).  */
7420
7421 static int
7422 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7423 {
7424   const char *discrim_name = ada_variant_discrim_name (var_type);
7425
7426   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7427 }
7428
7429
7430 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7431    within OUTER, determine which variant clause (field number in VAR_TYPE,
7432    numbering from 0) is applicable.  Returns -1 if none are.  */
7433
7434 int
7435 ada_which_variant_applies (struct type *var_type, struct value *outer)
7436 {
7437   int others_clause;
7438   int i;
7439   const char *discrim_name = ada_variant_discrim_name (var_type);
7440   struct value *discrim;
7441   LONGEST discrim_val;
7442
7443   /* Using plain value_from_contents_and_address here causes problems
7444      because we will end up trying to resolve a type that is currently
7445      being constructed.  */
7446   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7447   if (discrim == NULL)
7448     return -1;
7449   discrim_val = value_as_long (discrim);
7450
7451   others_clause = -1;
7452   for (i = 0; i < var_type->num_fields (); i += 1)
7453     {
7454       if (ada_is_others_clause (var_type, i))
7455         others_clause = i;
7456       else if (ada_in_variant (discrim_val, var_type, i))
7457         return i;
7458     }
7459
7460   return others_clause;
7461 }
7462 \f
7463
7464
7465                                 /* Dynamic-Sized Records */
7466
7467 /* Strategy: The type ostensibly attached to a value with dynamic size
7468    (i.e., a size that is not statically recorded in the debugging
7469    data) does not accurately reflect the size or layout of the value.
7470    Our strategy is to convert these values to values with accurate,
7471    conventional types that are constructed on the fly.  */
7472
7473 /* There is a subtle and tricky problem here.  In general, we cannot
7474    determine the size of dynamic records without its data.  However,
7475    the 'struct value' data structure, which GDB uses to represent
7476    quantities in the inferior process (the target), requires the size
7477    of the type at the time of its allocation in order to reserve space
7478    for GDB's internal copy of the data.  That's why the
7479    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7480    rather than struct value*s.
7481
7482    However, GDB's internal history variables ($1, $2, etc.) are
7483    struct value*s containing internal copies of the data that are not, in
7484    general, the same as the data at their corresponding addresses in
7485    the target.  Fortunately, the types we give to these values are all
7486    conventional, fixed-size types (as per the strategy described
7487    above), so that we don't usually have to perform the
7488    'to_fixed_xxx_type' conversions to look at their values.
7489    Unfortunately, there is one exception: if one of the internal
7490    history variables is an array whose elements are unconstrained
7491    records, then we will need to create distinct fixed types for each
7492    element selected.  */
7493
7494 /* The upshot of all of this is that many routines take a (type, host
7495    address, target address) triple as arguments to represent a value.
7496    The host address, if non-null, is supposed to contain an internal
7497    copy of the relevant data; otherwise, the program is to consult the
7498    target at the target address.  */
7499
7500 /* Assuming that VAL0 represents a pointer value, the result of
7501    dereferencing it.  Differs from value_ind in its treatment of
7502    dynamic-sized types.  */
7503
7504 struct value *
7505 ada_value_ind (struct value *val0)
7506 {
7507   struct value *val = value_ind (val0);
7508
7509   if (ada_is_tagged_type (value_type (val), 0))
7510     val = ada_tag_value_at_base_address (val);
7511
7512   return ada_to_fixed_value (val);
7513 }
7514
7515 /* The value resulting from dereferencing any "reference to"
7516    qualifiers on VAL0.  */
7517
7518 static struct value *
7519 ada_coerce_ref (struct value *val0)
7520 {
7521   if (value_type (val0)->code () == TYPE_CODE_REF)
7522     {
7523       struct value *val = val0;
7524
7525       val = coerce_ref (val);
7526
7527       if (ada_is_tagged_type (value_type (val), 0))
7528         val = ada_tag_value_at_base_address (val);
7529
7530       return ada_to_fixed_value (val);
7531     }
7532   else
7533     return val0;
7534 }
7535
7536 /* Return the bit alignment required for field #F of template type TYPE.  */
7537
7538 static unsigned int
7539 field_alignment (struct type *type, int f)
7540 {
7541   const char *name = type->field (f).name ();
7542   int len;
7543   int align_offset;
7544
7545   /* The field name should never be null, unless the debugging information
7546      is somehow malformed.  In this case, we assume the field does not
7547      require any alignment.  */
7548   if (name == NULL)
7549     return 1;
7550
7551   len = strlen (name);
7552
7553   if (!isdigit (name[len - 1]))
7554     return 1;
7555
7556   if (isdigit (name[len - 2]))
7557     align_offset = len - 2;
7558   else
7559     align_offset = len - 1;
7560
7561   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7562     return TARGET_CHAR_BIT;
7563
7564   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7565 }
7566
7567 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7568
7569 static struct symbol *
7570 ada_find_any_type_symbol (const char *name)
7571 {
7572   struct symbol *sym;
7573
7574   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7575   if (sym != NULL && sym->aclass () == LOC_TYPEDEF)
7576     return sym;
7577
7578   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7579   return sym;
7580 }
7581
7582 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7583    solely for types defined by debug info, it will not search the GDB
7584    primitive types.  */
7585
7586 static struct type *
7587 ada_find_any_type (const char *name)
7588 {
7589   struct symbol *sym = ada_find_any_type_symbol (name);
7590
7591   if (sym != NULL)
7592     return sym->type ();
7593
7594   return NULL;
7595 }
7596
7597 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7598    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
7599    symbol, in which case it is returned.  Otherwise, this looks for
7600    symbols whose name is that of NAME_SYM suffixed with  "___XR".
7601    Return symbol if found, and NULL otherwise.  */
7602
7603 static bool
7604 ada_is_renaming_symbol (struct symbol *name_sym)
7605 {
7606   const char *name = name_sym->linkage_name ();
7607   return strstr (name, "___XR") != NULL;
7608 }
7609
7610 /* Because of GNAT encoding conventions, several GDB symbols may match a
7611    given type name.  If the type denoted by TYPE0 is to be preferred to
7612    that of TYPE1 for purposes of type printing, return non-zero;
7613    otherwise return 0.  */
7614
7615 int
7616 ada_prefer_type (struct type *type0, struct type *type1)
7617 {
7618   if (type1 == NULL)
7619     return 1;
7620   else if (type0 == NULL)
7621     return 0;
7622   else if (type1->code () == TYPE_CODE_VOID)
7623     return 1;
7624   else if (type0->code () == TYPE_CODE_VOID)
7625     return 0;
7626   else if (type1->name () == NULL && type0->name () != NULL)
7627     return 1;
7628   else if (ada_is_constrained_packed_array_type (type0))
7629     return 1;
7630   else if (ada_is_array_descriptor_type (type0)
7631            && !ada_is_array_descriptor_type (type1))
7632     return 1;
7633   else
7634     {
7635       const char *type0_name = type0->name ();
7636       const char *type1_name = type1->name ();
7637
7638       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7639           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7640         return 1;
7641     }
7642   return 0;
7643 }
7644
7645 /* The name of TYPE, which is its TYPE_NAME.  Null if TYPE is
7646    null.  */
7647
7648 const char *
7649 ada_type_name (struct type *type)
7650 {
7651   if (type == NULL)
7652     return NULL;
7653   return type->name ();
7654 }
7655
7656 /* Search the list of "descriptive" types associated to TYPE for a type
7657    whose name is NAME.  */
7658
7659 static struct type *
7660 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7661 {
7662   struct type *result, *tmp;
7663
7664   if (ada_ignore_descriptive_types_p)
7665     return NULL;
7666
7667   /* If there no descriptive-type info, then there is no parallel type
7668      to be found.  */
7669   if (!HAVE_GNAT_AUX_INFO (type))
7670     return NULL;
7671
7672   result = TYPE_DESCRIPTIVE_TYPE (type);
7673   while (result != NULL)
7674     {
7675       const char *result_name = ada_type_name (result);
7676
7677       if (result_name == NULL)
7678         {
7679           warning (_("unexpected null name on descriptive type"));
7680           return NULL;
7681         }
7682
7683       /* If the names match, stop.  */
7684       if (strcmp (result_name, name) == 0)
7685         break;
7686
7687       /* Otherwise, look at the next item on the list, if any.  */
7688       if (HAVE_GNAT_AUX_INFO (result))
7689         tmp = TYPE_DESCRIPTIVE_TYPE (result);
7690       else
7691         tmp = NULL;
7692
7693       /* If not found either, try after having resolved the typedef.  */
7694       if (tmp != NULL)
7695         result = tmp;
7696       else
7697         {
7698           result = check_typedef (result);
7699           if (HAVE_GNAT_AUX_INFO (result))
7700             result = TYPE_DESCRIPTIVE_TYPE (result);
7701           else
7702             result = NULL;
7703         }
7704     }
7705
7706   /* If we didn't find a match, see whether this is a packed array.  With
7707      older compilers, the descriptive type information is either absent or
7708      irrelevant when it comes to packed arrays so the above lookup fails.
7709      Fall back to using a parallel lookup by name in this case.  */
7710   if (result == NULL && ada_is_constrained_packed_array_type (type))
7711     return ada_find_any_type (name);
7712
7713   return result;
7714 }
7715
7716 /* Find a parallel type to TYPE with the specified NAME, using the
7717    descriptive type taken from the debugging information, if available,
7718    and otherwise using the (slower) name-based method.  */
7719
7720 static struct type *
7721 ada_find_parallel_type_with_name (struct type *type, const char *name)
7722 {
7723   struct type *result = NULL;
7724
7725   if (HAVE_GNAT_AUX_INFO (type))
7726     result = find_parallel_type_by_descriptive_type (type, name);
7727   else
7728     result = ada_find_any_type (name);
7729
7730   return result;
7731 }
7732
7733 /* Same as above, but specify the name of the parallel type by appending
7734    SUFFIX to the name of TYPE.  */
7735
7736 struct type *
7737 ada_find_parallel_type (struct type *type, const char *suffix)
7738 {
7739   char *name;
7740   const char *type_name = ada_type_name (type);
7741   int len;
7742
7743   if (type_name == NULL)
7744     return NULL;
7745
7746   len = strlen (type_name);
7747
7748   name = (char *) alloca (len + strlen (suffix) + 1);
7749
7750   strcpy (name, type_name);
7751   strcpy (name + len, suffix);
7752
7753   return ada_find_parallel_type_with_name (type, name);
7754 }
7755
7756 /* If TYPE is a variable-size record type, return the corresponding template
7757    type describing its fields.  Otherwise, return NULL.  */
7758
7759 static struct type *
7760 dynamic_template_type (struct type *type)
7761 {
7762   type = ada_check_typedef (type);
7763
7764   if (type == NULL || type->code () != TYPE_CODE_STRUCT
7765       || ada_type_name (type) == NULL)
7766     return NULL;
7767   else
7768     {
7769       int len = strlen (ada_type_name (type));
7770
7771       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7772         return type;
7773       else
7774         return ada_find_parallel_type (type, "___XVE");
7775     }
7776 }
7777
7778 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7779    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
7780
7781 static int
7782 is_dynamic_field (struct type *templ_type, int field_num)
7783 {
7784   const char *name = templ_type->field (field_num).name ();
7785
7786   return name != NULL
7787     && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7788     && strstr (name, "___XVL") != NULL;
7789 }
7790
7791 /* The index of the variant field of TYPE, or -1 if TYPE does not
7792    represent a variant record type.  */
7793
7794 static int
7795 variant_field_index (struct type *type)
7796 {
7797   int f;
7798
7799   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7800     return -1;
7801
7802   for (f = 0; f < type->num_fields (); f += 1)
7803     {
7804       if (ada_is_variant_part (type, f))
7805         return f;
7806     }
7807   return -1;
7808 }
7809
7810 /* A record type with no fields.  */
7811
7812 static struct type *
7813 empty_record (struct type *templ)
7814 {
7815   struct type *type = alloc_type_copy (templ);
7816
7817   type->set_code (TYPE_CODE_STRUCT);
7818   INIT_NONE_SPECIFIC (type);
7819   type->set_name ("<empty>");
7820   TYPE_LENGTH (type) = 0;
7821   return type;
7822 }
7823
7824 /* An ordinary record type (with fixed-length fields) that describes
7825    the value of type TYPE at VALADDR or ADDRESS (see comments at
7826    the beginning of this section) VAL according to GNAT conventions.
7827    DVAL0 should describe the (portion of a) record that contains any
7828    necessary discriminants.  It should be NULL if value_type (VAL) is
7829    an outer-level type (i.e., as opposed to a branch of a variant.)  A
7830    variant field (unless unchecked) is replaced by a particular branch
7831    of the variant.
7832
7833    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7834    length are not statically known are discarded.  As a consequence,
7835    VALADDR, ADDRESS and DVAL0 are ignored.
7836
7837    NOTE: Limitations: For now, we assume that dynamic fields and
7838    variants occupy whole numbers of bytes.  However, they need not be
7839    byte-aligned.  */
7840
7841 struct type *
7842 ada_template_to_fixed_record_type_1 (struct type *type,
7843                                      const gdb_byte *valaddr,
7844                                      CORE_ADDR address, struct value *dval0,
7845                                      int keep_dynamic_fields)
7846 {
7847   struct value *mark = value_mark ();
7848   struct value *dval;
7849   struct type *rtype;
7850   int nfields, bit_len;
7851   int variant_field;
7852   long off;
7853   int fld_bit_len;
7854   int f;
7855
7856   /* Compute the number of fields in this record type that are going
7857      to be processed: unless keep_dynamic_fields, this includes only
7858      fields whose position and length are static will be processed.  */
7859   if (keep_dynamic_fields)
7860     nfields = type->num_fields ();
7861   else
7862     {
7863       nfields = 0;
7864       while (nfields < type->num_fields ()
7865              && !ada_is_variant_part (type, nfields)
7866              && !is_dynamic_field (type, nfields))
7867         nfields++;
7868     }
7869
7870   rtype = alloc_type_copy (type);
7871   rtype->set_code (TYPE_CODE_STRUCT);
7872   INIT_NONE_SPECIFIC (rtype);
7873   rtype->set_num_fields (nfields);
7874   rtype->set_fields
7875    ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7876   rtype->set_name (ada_type_name (type));
7877   rtype->set_is_fixed_instance (true);
7878
7879   off = 0;
7880   bit_len = 0;
7881   variant_field = -1;
7882
7883   for (f = 0; f < nfields; f += 1)
7884     {
7885       off = align_up (off, field_alignment (type, f))
7886         + type->field (f).loc_bitpos ();
7887       rtype->field (f).set_loc_bitpos (off);
7888       TYPE_FIELD_BITSIZE (rtype, f) = 0;
7889
7890       if (ada_is_variant_part (type, f))
7891         {
7892           variant_field = f;
7893           fld_bit_len = 0;
7894         }
7895       else if (is_dynamic_field (type, f))
7896         {
7897           const gdb_byte *field_valaddr = valaddr;
7898           CORE_ADDR field_address = address;
7899           struct type *field_type =
7900             TYPE_TARGET_TYPE (type->field (f).type ());
7901
7902           if (dval0 == NULL)
7903             {
7904               /* Using plain value_from_contents_and_address here
7905                  causes problems because we will end up trying to
7906                  resolve a type that is currently being
7907                  constructed.  */
7908               dval = value_from_contents_and_address_unresolved (rtype,
7909                                                                  valaddr,
7910                                                                  address);
7911               rtype = value_type (dval);
7912             }
7913           else
7914             dval = dval0;
7915
7916           /* If the type referenced by this field is an aligner type, we need
7917              to unwrap that aligner type, because its size might not be set.
7918              Keeping the aligner type would cause us to compute the wrong
7919              size for this field, impacting the offset of the all the fields
7920              that follow this one.  */
7921           if (ada_is_aligner_type (field_type))
7922             {
7923               long field_offset = type->field (f).loc_bitpos ();
7924
7925               field_valaddr = cond_offset_host (field_valaddr, field_offset);
7926               field_address = cond_offset_target (field_address, field_offset);
7927               field_type = ada_aligned_type (field_type);
7928             }
7929
7930           field_valaddr = cond_offset_host (field_valaddr,
7931                                             off / TARGET_CHAR_BIT);
7932           field_address = cond_offset_target (field_address,
7933                                               off / TARGET_CHAR_BIT);
7934
7935           /* Get the fixed type of the field.  Note that, in this case,
7936              we do not want to get the real type out of the tag: if
7937              the current field is the parent part of a tagged record,
7938              we will get the tag of the object.  Clearly wrong: the real
7939              type of the parent is not the real type of the child.  We
7940              would end up in an infinite loop.  */
7941           field_type = ada_get_base_type (field_type);
7942           field_type = ada_to_fixed_type (field_type, field_valaddr,
7943                                           field_address, dval, 0);
7944
7945           rtype->field (f).set_type (field_type);
7946           rtype->field (f).set_name (type->field (f).name ());
7947           /* The multiplication can potentially overflow.  But because
7948              the field length has been size-checked just above, and
7949              assuming that the maximum size is a reasonable value,
7950              an overflow should not happen in practice.  So rather than
7951              adding overflow recovery code to this already complex code,
7952              we just assume that it's not going to happen.  */
7953           fld_bit_len =
7954             TYPE_LENGTH (rtype->field (f).type ()) * TARGET_CHAR_BIT;
7955         }
7956       else
7957         {
7958           /* Note: If this field's type is a typedef, it is important
7959              to preserve the typedef layer.
7960
7961              Otherwise, we might be transforming a typedef to a fat
7962              pointer (encoding a pointer to an unconstrained array),
7963              into a basic fat pointer (encoding an unconstrained
7964              array).  As both types are implemented using the same
7965              structure, the typedef is the only clue which allows us
7966              to distinguish between the two options.  Stripping it
7967              would prevent us from printing this field appropriately.  */
7968           rtype->field (f).set_type (type->field (f).type ());
7969           rtype->field (f).set_name (type->field (f).name ());
7970           if (TYPE_FIELD_BITSIZE (type, f) > 0)
7971             fld_bit_len =
7972               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7973           else
7974             {
7975               struct type *field_type = type->field (f).type ();
7976
7977               /* We need to be careful of typedefs when computing
7978                  the length of our field.  If this is a typedef,
7979                  get the length of the target type, not the length
7980                  of the typedef.  */
7981               if (field_type->code () == TYPE_CODE_TYPEDEF)
7982                 field_type = ada_typedef_target_type (field_type);
7983
7984               fld_bit_len =
7985                 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7986             }
7987         }
7988       if (off + fld_bit_len > bit_len)
7989         bit_len = off + fld_bit_len;
7990       off += fld_bit_len;
7991       TYPE_LENGTH (rtype) =
7992         align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7993     }
7994
7995   /* We handle the variant part, if any, at the end because of certain
7996      odd cases in which it is re-ordered so as NOT to be the last field of
7997      the record.  This can happen in the presence of representation
7998      clauses.  */
7999   if (variant_field >= 0)
8000     {
8001       struct type *branch_type;
8002
8003       off = rtype->field (variant_field).loc_bitpos ();
8004
8005       if (dval0 == NULL)
8006         {
8007           /* Using plain value_from_contents_and_address here causes
8008              problems because we will end up trying to resolve a type
8009              that is currently being constructed.  */
8010           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8011                                                              address);
8012           rtype = value_type (dval);
8013         }
8014       else
8015         dval = dval0;
8016
8017       branch_type =
8018         to_fixed_variant_branch_type
8019         (type->field (variant_field).type (),
8020          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8021          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8022       if (branch_type == NULL)
8023         {
8024           for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
8025             rtype->field (f - 1) = rtype->field (f);
8026           rtype->set_num_fields (rtype->num_fields () - 1);
8027         }
8028       else
8029         {
8030           rtype->field (variant_field).set_type (branch_type);
8031           rtype->field (variant_field).set_name ("S");
8032           fld_bit_len =
8033             TYPE_LENGTH (rtype->field (variant_field).type ()) *
8034             TARGET_CHAR_BIT;
8035           if (off + fld_bit_len > bit_len)
8036             bit_len = off + fld_bit_len;
8037           TYPE_LENGTH (rtype) =
8038             align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8039         }
8040     }
8041
8042   /* According to exp_dbug.ads, the size of TYPE for variable-size records
8043      should contain the alignment of that record, which should be a strictly
8044      positive value.  If null or negative, then something is wrong, most
8045      probably in the debug info.  In that case, we don't round up the size
8046      of the resulting type.  If this record is not part of another structure,
8047      the current RTYPE length might be good enough for our purposes.  */
8048   if (TYPE_LENGTH (type) <= 0)
8049     {
8050       if (rtype->name ())
8051         warning (_("Invalid type size for `%s' detected: %s."),
8052                  rtype->name (), pulongest (TYPE_LENGTH (type)));
8053       else
8054         warning (_("Invalid type size for <unnamed> detected: %s."),
8055                  pulongest (TYPE_LENGTH (type)));
8056     }
8057   else
8058     {
8059       TYPE_LENGTH (rtype) = align_up (TYPE_LENGTH (rtype),
8060                                       TYPE_LENGTH (type));
8061     }
8062
8063   value_free_to_mark (mark);
8064   return rtype;
8065 }
8066
8067 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8068    of 1.  */
8069
8070 static struct type *
8071 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8072                                CORE_ADDR address, struct value *dval0)
8073 {
8074   return ada_template_to_fixed_record_type_1 (type, valaddr,
8075                                               address, dval0, 1);
8076 }
8077
8078 /* An ordinary record type in which ___XVL-convention fields and
8079    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8080    static approximations, containing all possible fields.  Uses
8081    no runtime values.  Useless for use in values, but that's OK,
8082    since the results are used only for type determinations.   Works on both
8083    structs and unions.  Representation note: to save space, we memorize
8084    the result of this function in the TYPE_TARGET_TYPE of the
8085    template type.  */
8086
8087 static struct type *
8088 template_to_static_fixed_type (struct type *type0)
8089 {
8090   struct type *type;
8091   int nfields;
8092   int f;
8093
8094   /* No need no do anything if the input type is already fixed.  */
8095   if (type0->is_fixed_instance ())
8096     return type0;
8097
8098   /* Likewise if we already have computed the static approximation.  */
8099   if (TYPE_TARGET_TYPE (type0) != NULL)
8100     return TYPE_TARGET_TYPE (type0);
8101
8102   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
8103   type = type0;
8104   nfields = type0->num_fields ();
8105
8106   /* Whether or not we cloned TYPE0, cache the result so that we don't do
8107      recompute all over next time.  */
8108   TYPE_TARGET_TYPE (type0) = type;
8109
8110   for (f = 0; f < nfields; f += 1)
8111     {
8112       struct type *field_type = type0->field (f).type ();
8113       struct type *new_type;
8114
8115       if (is_dynamic_field (type0, f))
8116         {
8117           field_type = ada_check_typedef (field_type);
8118           new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8119         }
8120       else
8121         new_type = static_unwrap_type (field_type);
8122
8123       if (new_type != field_type)
8124         {
8125           /* Clone TYPE0 only the first time we get a new field type.  */
8126           if (type == type0)
8127             {
8128               TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8129               type->set_code (type0->code ());
8130               INIT_NONE_SPECIFIC (type);
8131               type->set_num_fields (nfields);
8132
8133               field *fields =
8134                 ((struct field *)
8135                  TYPE_ALLOC (type, nfields * sizeof (struct field)));
8136               memcpy (fields, type0->fields (),
8137                       sizeof (struct field) * nfields);
8138               type->set_fields (fields);
8139
8140               type->set_name (ada_type_name (type0));
8141               type->set_is_fixed_instance (true);
8142               TYPE_LENGTH (type) = 0;
8143             }
8144           type->field (f).set_type (new_type);
8145           type->field (f).set_name (type0->field (f).name ());
8146         }
8147     }
8148
8149   return type;
8150 }
8151
8152 /* Given an object of type TYPE whose contents are at VALADDR and
8153    whose address in memory is ADDRESS, returns a revision of TYPE,
8154    which should be a non-dynamic-sized record, in which the variant
8155    part, if any, is replaced with the appropriate branch.  Looks
8156    for discriminant values in DVAL0, which can be NULL if the record
8157    contains the necessary discriminant values.  */
8158
8159 static struct type *
8160 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8161                                    CORE_ADDR address, struct value *dval0)
8162 {
8163   struct value *mark = value_mark ();
8164   struct value *dval;
8165   struct type *rtype;
8166   struct type *branch_type;
8167   int nfields = type->num_fields ();
8168   int variant_field = variant_field_index (type);
8169
8170   if (variant_field == -1)
8171     return type;
8172
8173   if (dval0 == NULL)
8174     {
8175       dval = value_from_contents_and_address (type, valaddr, address);
8176       type = value_type (dval);
8177     }
8178   else
8179     dval = dval0;
8180
8181   rtype = alloc_type_copy (type);
8182   rtype->set_code (TYPE_CODE_STRUCT);
8183   INIT_NONE_SPECIFIC (rtype);
8184   rtype->set_num_fields (nfields);
8185
8186   field *fields =
8187     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8188   memcpy (fields, type->fields (), sizeof (struct field) * nfields);
8189   rtype->set_fields (fields);
8190
8191   rtype->set_name (ada_type_name (type));
8192   rtype->set_is_fixed_instance (true);
8193   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8194
8195   branch_type = to_fixed_variant_branch_type
8196     (type->field (variant_field).type (),
8197      cond_offset_host (valaddr,
8198                        type->field (variant_field).loc_bitpos ()
8199                        / TARGET_CHAR_BIT),
8200      cond_offset_target (address,
8201                          type->field (variant_field).loc_bitpos ()
8202                          / TARGET_CHAR_BIT), dval);
8203   if (branch_type == NULL)
8204     {
8205       int f;
8206
8207       for (f = variant_field + 1; f < nfields; f += 1)
8208         rtype->field (f - 1) = rtype->field (f);
8209       rtype->set_num_fields (rtype->num_fields () - 1);
8210     }
8211   else
8212     {
8213       rtype->field (variant_field).set_type (branch_type);
8214       rtype->field (variant_field).set_name ("S");
8215       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8216       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8217     }
8218   TYPE_LENGTH (rtype) -= TYPE_LENGTH (type->field (variant_field).type ());
8219
8220   value_free_to_mark (mark);
8221   return rtype;
8222 }
8223
8224 /* An ordinary record type (with fixed-length fields) that describes
8225    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8226    beginning of this section].   Any necessary discriminants' values
8227    should be in DVAL, a record value; it may be NULL if the object
8228    at ADDR itself contains any necessary discriminant values.
8229    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8230    values from the record are needed.  Except in the case that DVAL,
8231    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8232    unchecked) is replaced by a particular branch of the variant.
8233
8234    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8235    is questionable and may be removed.  It can arise during the
8236    processing of an unconstrained-array-of-record type where all the
8237    variant branches have exactly the same size.  This is because in
8238    such cases, the compiler does not bother to use the XVS convention
8239    when encoding the record.  I am currently dubious of this
8240    shortcut and suspect the compiler should be altered.  FIXME.  */
8241
8242 static struct type *
8243 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8244                       CORE_ADDR address, struct value *dval)
8245 {
8246   struct type *templ_type;
8247
8248   if (type0->is_fixed_instance ())
8249     return type0;
8250
8251   templ_type = dynamic_template_type (type0);
8252
8253   if (templ_type != NULL)
8254     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8255   else if (variant_field_index (type0) >= 0)
8256     {
8257       if (dval == NULL && valaddr == NULL && address == 0)
8258         return type0;
8259       return to_record_with_fixed_variant_part (type0, valaddr, address,
8260                                                 dval);
8261     }
8262   else
8263     {
8264       type0->set_is_fixed_instance (true);
8265       return type0;
8266     }
8267
8268 }
8269
8270 /* An ordinary record type (with fixed-length fields) that describes
8271    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8272    union type.  Any necessary discriminants' values should be in DVAL,
8273    a record value.  That is, this routine selects the appropriate
8274    branch of the union at ADDR according to the discriminant value
8275    indicated in the union's type name.  Returns VAR_TYPE0 itself if
8276    it represents a variant subject to a pragma Unchecked_Union.  */
8277
8278 static struct type *
8279 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8280                               CORE_ADDR address, struct value *dval)
8281 {
8282   int which;
8283   struct type *templ_type;
8284   struct type *var_type;
8285
8286   if (var_type0->code () == TYPE_CODE_PTR)
8287     var_type = TYPE_TARGET_TYPE (var_type0);
8288   else
8289     var_type = var_type0;
8290
8291   templ_type = ada_find_parallel_type (var_type, "___XVU");
8292
8293   if (templ_type != NULL)
8294     var_type = templ_type;
8295
8296   if (is_unchecked_variant (var_type, value_type (dval)))
8297       return var_type0;
8298   which = ada_which_variant_applies (var_type, dval);
8299
8300   if (which < 0)
8301     return empty_record (var_type);
8302   else if (is_dynamic_field (var_type, which))
8303     return to_fixed_record_type
8304       (TYPE_TARGET_TYPE (var_type->field (which).type ()),
8305        valaddr, address, dval);
8306   else if (variant_field_index (var_type->field (which).type ()) >= 0)
8307     return
8308       to_fixed_record_type
8309       (var_type->field (which).type (), valaddr, address, dval);
8310   else
8311     return var_type->field (which).type ();
8312 }
8313
8314 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8315    ENCODING_TYPE, a type following the GNAT conventions for discrete
8316    type encodings, only carries redundant information.  */
8317
8318 static int
8319 ada_is_redundant_range_encoding (struct type *range_type,
8320                                  struct type *encoding_type)
8321 {
8322   const char *bounds_str;
8323   int n;
8324   LONGEST lo, hi;
8325
8326   gdb_assert (range_type->code () == TYPE_CODE_RANGE);
8327
8328   if (get_base_type (range_type)->code ()
8329       != get_base_type (encoding_type)->code ())
8330     {
8331       /* The compiler probably used a simple base type to describe
8332          the range type instead of the range's actual base type,
8333          expecting us to get the real base type from the encoding
8334          anyway.  In this situation, the encoding cannot be ignored
8335          as redundant.  */
8336       return 0;
8337     }
8338
8339   if (is_dynamic_type (range_type))
8340     return 0;
8341
8342   if (encoding_type->name () == NULL)
8343     return 0;
8344
8345   bounds_str = strstr (encoding_type->name (), "___XDLU_");
8346   if (bounds_str == NULL)
8347     return 0;
8348
8349   n = 8; /* Skip "___XDLU_".  */
8350   if (!ada_scan_number (bounds_str, n, &lo, &n))
8351     return 0;
8352   if (range_type->bounds ()->low.const_val () != lo)
8353     return 0;
8354
8355   n += 2; /* Skip the "__" separator between the two bounds.  */
8356   if (!ada_scan_number (bounds_str, n, &hi, &n))
8357     return 0;
8358   if (range_type->bounds ()->high.const_val () != hi)
8359     return 0;
8360
8361   return 1;
8362 }
8363
8364 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8365    a type following the GNAT encoding for describing array type
8366    indices, only carries redundant information.  */
8367
8368 static int
8369 ada_is_redundant_index_type_desc (struct type *array_type,
8370                                   struct type *desc_type)
8371 {
8372   struct type *this_layer = check_typedef (array_type);
8373   int i;
8374
8375   for (i = 0; i < desc_type->num_fields (); i++)
8376     {
8377       if (!ada_is_redundant_range_encoding (this_layer->index_type (),
8378                                             desc_type->field (i).type ()))
8379         return 0;
8380       this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8381     }
8382
8383   return 1;
8384 }
8385
8386 /* Assuming that TYPE0 is an array type describing the type of a value
8387    at ADDR, and that DVAL describes a record containing any
8388    discriminants used in TYPE0, returns a type for the value that
8389    contains no dynamic components (that is, no components whose sizes
8390    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
8391    true, gives an error message if the resulting type's size is over
8392    varsize_limit.  */
8393
8394 static struct type *
8395 to_fixed_array_type (struct type *type0, struct value *dval,
8396                      int ignore_too_big)
8397 {
8398   struct type *index_type_desc;
8399   struct type *result;
8400   int constrained_packed_array_p;
8401   static const char *xa_suffix = "___XA";
8402
8403   type0 = ada_check_typedef (type0);
8404   if (type0->is_fixed_instance ())
8405     return type0;
8406
8407   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8408   if (constrained_packed_array_p)
8409     {
8410       type0 = decode_constrained_packed_array_type (type0);
8411       if (type0 == nullptr)
8412         error (_("could not decode constrained packed array type"));
8413     }
8414
8415   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8416
8417   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8418      encoding suffixed with 'P' may still be generated.  If so,
8419      it should be used to find the XA type.  */
8420
8421   if (index_type_desc == NULL)
8422     {
8423       const char *type_name = ada_type_name (type0);
8424
8425       if (type_name != NULL)
8426         {
8427           const int len = strlen (type_name);
8428           char *name = (char *) alloca (len + strlen (xa_suffix));
8429
8430           if (type_name[len - 1] == 'P')
8431             {
8432               strcpy (name, type_name);
8433               strcpy (name + len - 1, xa_suffix);
8434               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8435             }
8436         }
8437     }
8438
8439   ada_fixup_array_indexes_type (index_type_desc);
8440   if (index_type_desc != NULL
8441       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8442     {
8443       /* Ignore this ___XA parallel type, as it does not bring any
8444          useful information.  This allows us to avoid creating fixed
8445          versions of the array's index types, which would be identical
8446          to the original ones.  This, in turn, can also help avoid
8447          the creation of fixed versions of the array itself.  */
8448       index_type_desc = NULL;
8449     }
8450
8451   if (index_type_desc == NULL)
8452     {
8453       struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8454
8455       /* NOTE: elt_type---the fixed version of elt_type0---should never
8456          depend on the contents of the array in properly constructed
8457          debugging data.  */
8458       /* Create a fixed version of the array element type.
8459          We're not providing the address of an element here,
8460          and thus the actual object value cannot be inspected to do
8461          the conversion.  This should not be a problem, since arrays of
8462          unconstrained objects are not allowed.  In particular, all
8463          the elements of an array of a tagged type should all be of
8464          the same type specified in the debugging info.  No need to
8465          consult the object tag.  */
8466       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8467
8468       /* Make sure we always create a new array type when dealing with
8469          packed array types, since we're going to fix-up the array
8470          type length and element bitsize a little further down.  */
8471       if (elt_type0 == elt_type && !constrained_packed_array_p)
8472         result = type0;
8473       else
8474         result = create_array_type (alloc_type_copy (type0),
8475                                     elt_type, type0->index_type ());
8476     }
8477   else
8478     {
8479       int i;
8480       struct type *elt_type0;
8481
8482       elt_type0 = type0;
8483       for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8484         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8485
8486       /* NOTE: result---the fixed version of elt_type0---should never
8487          depend on the contents of the array in properly constructed
8488          debugging data.  */
8489       /* Create a fixed version of the array element type.
8490          We're not providing the address of an element here,
8491          and thus the actual object value cannot be inspected to do
8492          the conversion.  This should not be a problem, since arrays of
8493          unconstrained objects are not allowed.  In particular, all
8494          the elements of an array of a tagged type should all be of
8495          the same type specified in the debugging info.  No need to
8496          consult the object tag.  */
8497       result =
8498         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8499
8500       elt_type0 = type0;
8501       for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8502         {
8503           struct type *range_type =
8504             to_fixed_range_type (index_type_desc->field (i).type (), dval);
8505
8506           result = create_array_type (alloc_type_copy (elt_type0),
8507                                       result, range_type);
8508           elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8509         }
8510     }
8511
8512   /* We want to preserve the type name.  This can be useful when
8513      trying to get the type name of a value that has already been
8514      printed (for instance, if the user did "print VAR; whatis $".  */
8515   result->set_name (type0->name ());
8516
8517   if (constrained_packed_array_p)
8518     {
8519       /* So far, the resulting type has been created as if the original
8520          type was a regular (non-packed) array type.  As a result, the
8521          bitsize of the array elements needs to be set again, and the array
8522          length needs to be recomputed based on that bitsize.  */
8523       int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8524       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8525
8526       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8527       TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8528       if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8529         TYPE_LENGTH (result)++;
8530     }
8531
8532   result->set_is_fixed_instance (true);
8533   return result;
8534 }
8535
8536
8537 /* A standard type (containing no dynamically sized components)
8538    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8539    DVAL describes a record containing any discriminants used in TYPE0,
8540    and may be NULL if there are none, or if the object of type TYPE at
8541    ADDRESS or in VALADDR contains these discriminants.
8542    
8543    If CHECK_TAG is not null, in the case of tagged types, this function
8544    attempts to locate the object's tag and use it to compute the actual
8545    type.  However, when ADDRESS is null, we cannot use it to determine the
8546    location of the tag, and therefore compute the tagged type's actual type.
8547    So we return the tagged type without consulting the tag.  */
8548    
8549 static struct type *
8550 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8551                    CORE_ADDR address, struct value *dval, int check_tag)
8552 {
8553   type = ada_check_typedef (type);
8554
8555   /* Only un-fixed types need to be handled here.  */
8556   if (!HAVE_GNAT_AUX_INFO (type))
8557     return type;
8558
8559   switch (type->code ())
8560     {
8561     default:
8562       return type;
8563     case TYPE_CODE_STRUCT:
8564       {
8565         struct type *static_type = to_static_fixed_type (type);
8566         struct type *fixed_record_type =
8567           to_fixed_record_type (type, valaddr, address, NULL);
8568
8569         /* If STATIC_TYPE is a tagged type and we know the object's address,
8570            then we can determine its tag, and compute the object's actual
8571            type from there.  Note that we have to use the fixed record
8572            type (the parent part of the record may have dynamic fields
8573            and the way the location of _tag is expressed may depend on
8574            them).  */
8575
8576         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8577           {
8578             struct value *tag =
8579               value_tag_from_contents_and_address
8580               (fixed_record_type,
8581                valaddr,
8582                address);
8583             struct type *real_type = type_from_tag (tag);
8584             struct value *obj =
8585               value_from_contents_and_address (fixed_record_type,
8586                                                valaddr,
8587                                                address);
8588             fixed_record_type = value_type (obj);
8589             if (real_type != NULL)
8590               return to_fixed_record_type
8591                 (real_type, NULL,
8592                  value_address (ada_tag_value_at_base_address (obj)), NULL);
8593           }
8594
8595         /* Check to see if there is a parallel ___XVZ variable.
8596            If there is, then it provides the actual size of our type.  */
8597         else if (ada_type_name (fixed_record_type) != NULL)
8598           {
8599             const char *name = ada_type_name (fixed_record_type);
8600             char *xvz_name
8601               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8602             bool xvz_found = false;
8603             LONGEST size;
8604
8605             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8606             try
8607               {
8608                 xvz_found = get_int_var_value (xvz_name, size);
8609               }
8610             catch (const gdb_exception_error &except)
8611               {
8612                 /* We found the variable, but somehow failed to read
8613                    its value.  Rethrow the same error, but with a little
8614                    bit more information, to help the user understand
8615                    what went wrong (Eg: the variable might have been
8616                    optimized out).  */
8617                 throw_error (except.error,
8618                              _("unable to read value of %s (%s)"),
8619                              xvz_name, except.what ());
8620               }
8621
8622             if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8623               {
8624                 fixed_record_type = copy_type (fixed_record_type);
8625                 TYPE_LENGTH (fixed_record_type) = size;
8626
8627                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
8628                    observed this when the debugging info is STABS, and
8629                    apparently it is something that is hard to fix.
8630
8631                    In practice, we don't need the actual type definition
8632                    at all, because the presence of the XVZ variable allows us
8633                    to assume that there must be a XVS type as well, which we
8634                    should be able to use later, when we need the actual type
8635                    definition.
8636
8637                    In the meantime, pretend that the "fixed" type we are
8638                    returning is NOT a stub, because this can cause trouble
8639                    when using this type to create new types targeting it.
8640                    Indeed, the associated creation routines often check
8641                    whether the target type is a stub and will try to replace
8642                    it, thus using a type with the wrong size.  This, in turn,
8643                    might cause the new type to have the wrong size too.
8644                    Consider the case of an array, for instance, where the size
8645                    of the array is computed from the number of elements in
8646                    our array multiplied by the size of its element.  */
8647                 fixed_record_type->set_is_stub (false);
8648               }
8649           }
8650         return fixed_record_type;
8651       }
8652     case TYPE_CODE_ARRAY:
8653       return to_fixed_array_type (type, dval, 1);
8654     case TYPE_CODE_UNION:
8655       if (dval == NULL)
8656         return type;
8657       else
8658         return to_fixed_variant_branch_type (type, valaddr, address, dval);
8659     }
8660 }
8661
8662 /* The same as ada_to_fixed_type_1, except that it preserves the type
8663    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8664
8665    The typedef layer needs be preserved in order to differentiate between
8666    arrays and array pointers when both types are implemented using the same
8667    fat pointer.  In the array pointer case, the pointer is encoded as
8668    a typedef of the pointer type.  For instance, considering:
8669
8670           type String_Access is access String;
8671           S1 : String_Access := null;
8672
8673    To the debugger, S1 is defined as a typedef of type String.  But
8674    to the user, it is a pointer.  So if the user tries to print S1,
8675    we should not dereference the array, but print the array address
8676    instead.
8677
8678    If we didn't preserve the typedef layer, we would lose the fact that
8679    the type is to be presented as a pointer (needs de-reference before
8680    being printed).  And we would also use the source-level type name.  */
8681
8682 struct type *
8683 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8684                    CORE_ADDR address, struct value *dval, int check_tag)
8685
8686 {
8687   struct type *fixed_type =
8688     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8689
8690   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8691       then preserve the typedef layer.
8692
8693       Implementation note: We can only check the main-type portion of
8694       the TYPE and FIXED_TYPE, because eliminating the typedef layer
8695       from TYPE now returns a type that has the same instance flags
8696       as TYPE.  For instance, if TYPE is a "typedef const", and its
8697       target type is a "struct", then the typedef elimination will return
8698       a "const" version of the target type.  See check_typedef for more
8699       details about how the typedef layer elimination is done.
8700
8701       brobecker/2010-11-19: It seems to me that the only case where it is
8702       useful to preserve the typedef layer is when dealing with fat pointers.
8703       Perhaps, we could add a check for that and preserve the typedef layer
8704       only in that situation.  But this seems unnecessary so far, probably
8705       because we call check_typedef/ada_check_typedef pretty much everywhere.
8706       */
8707   if (type->code () == TYPE_CODE_TYPEDEF
8708       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8709           == TYPE_MAIN_TYPE (fixed_type)))
8710     return type;
8711
8712   return fixed_type;
8713 }
8714
8715 /* A standard (static-sized) type corresponding as well as possible to
8716    TYPE0, but based on no runtime data.  */
8717
8718 static struct type *
8719 to_static_fixed_type (struct type *type0)
8720 {
8721   struct type *type;
8722
8723   if (type0 == NULL)
8724     return NULL;
8725
8726   if (type0->is_fixed_instance ())
8727     return type0;
8728
8729   type0 = ada_check_typedef (type0);
8730
8731   switch (type0->code ())
8732     {
8733     default:
8734       return type0;
8735     case TYPE_CODE_STRUCT:
8736       type = dynamic_template_type (type0);
8737       if (type != NULL)
8738         return template_to_static_fixed_type (type);
8739       else
8740         return template_to_static_fixed_type (type0);
8741     case TYPE_CODE_UNION:
8742       type = ada_find_parallel_type (type0, "___XVU");
8743       if (type != NULL)
8744         return template_to_static_fixed_type (type);
8745       else
8746         return template_to_static_fixed_type (type0);
8747     }
8748 }
8749
8750 /* A static approximation of TYPE with all type wrappers removed.  */
8751
8752 static struct type *
8753 static_unwrap_type (struct type *type)
8754 {
8755   if (ada_is_aligner_type (type))
8756     {
8757       struct type *type1 = ada_check_typedef (type)->field (0).type ();
8758       if (ada_type_name (type1) == NULL)
8759         type1->set_name (ada_type_name (type));
8760
8761       return static_unwrap_type (type1);
8762     }
8763   else
8764     {
8765       struct type *raw_real_type = ada_get_base_type (type);
8766
8767       if (raw_real_type == type)
8768         return type;
8769       else
8770         return to_static_fixed_type (raw_real_type);
8771     }
8772 }
8773
8774 /* In some cases, incomplete and private types require
8775    cross-references that are not resolved as records (for example,
8776       type Foo;
8777       type FooP is access Foo;
8778       V: FooP;
8779       type Foo is array ...;
8780    ).  In these cases, since there is no mechanism for producing
8781    cross-references to such types, we instead substitute for FooP a
8782    stub enumeration type that is nowhere resolved, and whose tag is
8783    the name of the actual type.  Call these types "non-record stubs".  */
8784
8785 /* A type equivalent to TYPE that is not a non-record stub, if one
8786    exists, otherwise TYPE.  */
8787
8788 struct type *
8789 ada_check_typedef (struct type *type)
8790 {
8791   if (type == NULL)
8792     return NULL;
8793
8794   /* If our type is an access to an unconstrained array, which is encoded
8795      as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8796      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8797      what allows us to distinguish between fat pointers that represent
8798      array types, and fat pointers that represent array access types
8799      (in both cases, the compiler implements them as fat pointers).  */
8800   if (ada_is_access_to_unconstrained_array (type))
8801     return type;
8802
8803   type = check_typedef (type);
8804   if (type == NULL || type->code () != TYPE_CODE_ENUM
8805       || !type->is_stub ()
8806       || type->name () == NULL)
8807     return type;
8808   else
8809     {
8810       const char *name = type->name ();
8811       struct type *type1 = ada_find_any_type (name);
8812
8813       if (type1 == NULL)
8814         return type;
8815
8816       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8817          stubs pointing to arrays, as we don't create symbols for array
8818          types, only for the typedef-to-array types).  If that's the case,
8819          strip the typedef layer.  */
8820       if (type1->code () == TYPE_CODE_TYPEDEF)
8821         type1 = ada_check_typedef (type1);
8822
8823       return type1;
8824     }
8825 }
8826
8827 /* A value representing the data at VALADDR/ADDRESS as described by
8828    type TYPE0, but with a standard (static-sized) type that correctly
8829    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
8830    type, then return VAL0 [this feature is simply to avoid redundant
8831    creation of struct values].  */
8832
8833 static struct value *
8834 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8835                            struct value *val0)
8836 {
8837   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8838
8839   if (type == type0 && val0 != NULL)
8840     return val0;
8841
8842   if (VALUE_LVAL (val0) != lval_memory)
8843     {
8844       /* Our value does not live in memory; it could be a convenience
8845          variable, for instance.  Create a not_lval value using val0's
8846          contents.  */
8847       return value_from_contents (type, value_contents (val0).data ());
8848     }
8849
8850   return value_from_contents_and_address (type, 0, address);
8851 }
8852
8853 /* A value representing VAL, but with a standard (static-sized) type
8854    that correctly describes it.  Does not necessarily create a new
8855    value.  */
8856
8857 struct value *
8858 ada_to_fixed_value (struct value *val)
8859 {
8860   val = unwrap_value (val);
8861   val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8862   return val;
8863 }
8864 \f
8865
8866 /* Attributes */
8867
8868 /* Table mapping attribute numbers to names.
8869    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
8870
8871 static const char * const attribute_names[] = {
8872   "<?>",
8873
8874   "first",
8875   "last",
8876   "length",
8877   "image",
8878   "max",
8879   "min",
8880   "modulus",
8881   "pos",
8882   "size",
8883   "tag",
8884   "val",
8885   0
8886 };
8887
8888 static const char *
8889 ada_attribute_name (enum exp_opcode n)
8890 {
8891   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8892     return attribute_names[n - OP_ATR_FIRST + 1];
8893   else
8894     return attribute_names[0];
8895 }
8896
8897 /* Evaluate the 'POS attribute applied to ARG.  */
8898
8899 static LONGEST
8900 pos_atr (struct value *arg)
8901 {
8902   struct value *val = coerce_ref (arg);
8903   struct type *type = value_type (val);
8904
8905   if (!discrete_type_p (type))
8906     error (_("'POS only defined on discrete types"));
8907
8908   gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8909   if (!result.has_value ())
8910     error (_("enumeration value is invalid: can't find 'POS"));
8911
8912   return *result;
8913 }
8914
8915 struct value *
8916 ada_pos_atr (struct type *expect_type,
8917              struct expression *exp,
8918              enum noside noside, enum exp_opcode op,
8919              struct value *arg)
8920 {
8921   struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8922   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8923     return value_zero (type, not_lval);
8924   return value_from_longest (type, pos_atr (arg));
8925 }
8926
8927 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
8928
8929 static struct value *
8930 val_atr (struct type *type, LONGEST val)
8931 {
8932   gdb_assert (discrete_type_p (type));
8933   if (type->code () == TYPE_CODE_RANGE)
8934     type = TYPE_TARGET_TYPE (type);
8935   if (type->code () == TYPE_CODE_ENUM)
8936     {
8937       if (val < 0 || val >= type->num_fields ())
8938         error (_("argument to 'VAL out of range"));
8939       val = type->field (val).loc_enumval ();
8940     }
8941   return value_from_longest (type, val);
8942 }
8943
8944 struct value *
8945 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8946 {
8947   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8948     return value_zero (type, not_lval);
8949
8950   if (!discrete_type_p (type))
8951     error (_("'VAL only defined on discrete types"));
8952   if (!integer_type_p (value_type (arg)))
8953     error (_("'VAL requires integral argument"));
8954
8955   return val_atr (type, value_as_long (arg));
8956 }
8957 \f
8958
8959                                 /* Evaluation */
8960
8961 /* True if TYPE appears to be an Ada character type.
8962    [At the moment, this is true only for Character and Wide_Character;
8963    It is a heuristic test that could stand improvement].  */
8964
8965 bool
8966 ada_is_character_type (struct type *type)
8967 {
8968   const char *name;
8969
8970   /* If the type code says it's a character, then assume it really is,
8971      and don't check any further.  */
8972   if (type->code () == TYPE_CODE_CHAR)
8973     return true;
8974   
8975   /* Otherwise, assume it's a character type iff it is a discrete type
8976      with a known character type name.  */
8977   name = ada_type_name (type);
8978   return (name != NULL
8979           && (type->code () == TYPE_CODE_INT
8980               || type->code () == TYPE_CODE_RANGE)
8981           && (strcmp (name, "character") == 0
8982               || strcmp (name, "wide_character") == 0
8983               || strcmp (name, "wide_wide_character") == 0
8984               || strcmp (name, "unsigned char") == 0));
8985 }
8986
8987 /* True if TYPE appears to be an Ada string type.  */
8988
8989 bool
8990 ada_is_string_type (struct type *type)
8991 {
8992   type = ada_check_typedef (type);
8993   if (type != NULL
8994       && type->code () != TYPE_CODE_PTR
8995       && (ada_is_simple_array_type (type)
8996           || ada_is_array_descriptor_type (type))
8997       && ada_array_arity (type) == 1)
8998     {
8999       struct type *elttype = ada_array_element_type (type, 1);
9000
9001       return ada_is_character_type (elttype);
9002     }
9003   else
9004     return false;
9005 }
9006
9007 /* The compiler sometimes provides a parallel XVS type for a given
9008    PAD type.  Normally, it is safe to follow the PAD type directly,
9009    but older versions of the compiler have a bug that causes the offset
9010    of its "F" field to be wrong.  Following that field in that case
9011    would lead to incorrect results, but this can be worked around
9012    by ignoring the PAD type and using the associated XVS type instead.
9013
9014    Set to True if the debugger should trust the contents of PAD types.
9015    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
9016 static bool trust_pad_over_xvs = true;
9017
9018 /* True if TYPE is a struct type introduced by the compiler to force the
9019    alignment of a value.  Such types have a single field with a
9020    distinctive name.  */
9021
9022 int
9023 ada_is_aligner_type (struct type *type)
9024 {
9025   type = ada_check_typedef (type);
9026
9027   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9028     return 0;
9029
9030   return (type->code () == TYPE_CODE_STRUCT
9031           && type->num_fields () == 1
9032           && strcmp (type->field (0).name (), "F") == 0);
9033 }
9034
9035 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9036    the parallel type.  */
9037
9038 struct type *
9039 ada_get_base_type (struct type *raw_type)
9040 {
9041   struct type *real_type_namer;
9042   struct type *raw_real_type;
9043
9044   if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
9045     return raw_type;
9046
9047   if (ada_is_aligner_type (raw_type))
9048     /* The encoding specifies that we should always use the aligner type.
9049        So, even if this aligner type has an associated XVS type, we should
9050        simply ignore it.
9051
9052        According to the compiler gurus, an XVS type parallel to an aligner
9053        type may exist because of a stabs limitation.  In stabs, aligner
9054        types are empty because the field has a variable-sized type, and
9055        thus cannot actually be used as an aligner type.  As a result,
9056        we need the associated parallel XVS type to decode the type.
9057        Since the policy in the compiler is to not change the internal
9058        representation based on the debugging info format, we sometimes
9059        end up having a redundant XVS type parallel to the aligner type.  */
9060     return raw_type;
9061
9062   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9063   if (real_type_namer == NULL
9064       || real_type_namer->code () != TYPE_CODE_STRUCT
9065       || real_type_namer->num_fields () != 1)
9066     return raw_type;
9067
9068   if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
9069     {
9070       /* This is an older encoding form where the base type needs to be
9071          looked up by name.  We prefer the newer encoding because it is
9072          more efficient.  */
9073       raw_real_type = ada_find_any_type (real_type_namer->field (0).name ());
9074       if (raw_real_type == NULL)
9075         return raw_type;
9076       else
9077         return raw_real_type;
9078     }
9079
9080   /* The field in our XVS type is a reference to the base type.  */
9081   return TYPE_TARGET_TYPE (real_type_namer->field (0).type ());
9082 }
9083
9084 /* The type of value designated by TYPE, with all aligners removed.  */
9085
9086 struct type *
9087 ada_aligned_type (struct type *type)
9088 {
9089   if (ada_is_aligner_type (type))
9090     return ada_aligned_type (type->field (0).type ());
9091   else
9092     return ada_get_base_type (type);
9093 }
9094
9095
9096 /* The address of the aligned value in an object at address VALADDR
9097    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
9098
9099 const gdb_byte *
9100 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9101 {
9102   if (ada_is_aligner_type (type))
9103     return ada_aligned_value_addr
9104       (type->field (0).type (),
9105        valaddr + type->field (0).loc_bitpos () / TARGET_CHAR_BIT);
9106   else
9107     return valaddr;
9108 }
9109
9110
9111
9112 /* The printed representation of an enumeration literal with encoded
9113    name NAME.  The value is good to the next call of ada_enum_name.  */
9114 const char *
9115 ada_enum_name (const char *name)
9116 {
9117   static std::string storage;
9118   const char *tmp;
9119
9120   /* First, unqualify the enumeration name:
9121      1. Search for the last '.' character.  If we find one, then skip
9122      all the preceding characters, the unqualified name starts
9123      right after that dot.
9124      2. Otherwise, we may be debugging on a target where the compiler
9125      translates dots into "__".  Search forward for double underscores,
9126      but stop searching when we hit an overloading suffix, which is
9127      of the form "__" followed by digits.  */
9128
9129   tmp = strrchr (name, '.');
9130   if (tmp != NULL)
9131     name = tmp + 1;
9132   else
9133     {
9134       while ((tmp = strstr (name, "__")) != NULL)
9135         {
9136           if (isdigit (tmp[2]))
9137             break;
9138           else
9139             name = tmp + 2;
9140         }
9141     }
9142
9143   if (name[0] == 'Q')
9144     {
9145       int v;
9146
9147       if (name[1] == 'U' || name[1] == 'W')
9148         {
9149           int offset = 2;
9150           if (name[1] == 'W' && name[2] == 'W')
9151             {
9152               /* Also handle the QWW case.  */
9153               ++offset;
9154             }
9155           if (sscanf (name + offset, "%x", &v) != 1)
9156             return name;
9157         }
9158       else if (((name[1] >= '0' && name[1] <= '9')
9159                 || (name[1] >= 'a' && name[1] <= 'z'))
9160                && name[2] == '\0')
9161         {
9162           storage = string_printf ("'%c'", name[1]);
9163           return storage.c_str ();
9164         }
9165       else
9166         return name;
9167
9168       if (isascii (v) && isprint (v))
9169         storage = string_printf ("'%c'", v);
9170       else if (name[1] == 'U')
9171         storage = string_printf ("'[\"%02x\"]'", v);
9172       else if (name[2] != 'W')
9173         storage = string_printf ("'[\"%04x\"]'", v);
9174       else
9175         storage = string_printf ("'[\"%06x\"]'", v);
9176
9177       return storage.c_str ();
9178     }
9179   else
9180     {
9181       tmp = strstr (name, "__");
9182       if (tmp == NULL)
9183         tmp = strstr (name, "$");
9184       if (tmp != NULL)
9185         {
9186           storage = std::string (name, tmp - name);
9187           return storage.c_str ();
9188         }
9189
9190       return name;
9191     }
9192 }
9193
9194 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9195    value it wraps.  */
9196
9197 static struct value *
9198 unwrap_value (struct value *val)
9199 {
9200   struct type *type = ada_check_typedef (value_type (val));
9201
9202   if (ada_is_aligner_type (type))
9203     {
9204       struct value *v = ada_value_struct_elt (val, "F", 0);
9205       struct type *val_type = ada_check_typedef (value_type (v));
9206
9207       if (ada_type_name (val_type) == NULL)
9208         val_type->set_name (ada_type_name (type));
9209
9210       return unwrap_value (v);
9211     }
9212   else
9213     {
9214       struct type *raw_real_type =
9215         ada_check_typedef (ada_get_base_type (type));
9216
9217       /* If there is no parallel XVS or XVE type, then the value is
9218          already unwrapped.  Return it without further modification.  */
9219       if ((type == raw_real_type)
9220           && ada_find_parallel_type (type, "___XVE") == NULL)
9221         return val;
9222
9223       return
9224         coerce_unspec_val_to_type
9225         (val, ada_to_fixed_type (raw_real_type, 0,
9226                                  value_address (val),
9227                                  NULL, 1));
9228     }
9229 }
9230
9231 /* Given two array types T1 and T2, return nonzero iff both arrays
9232    contain the same number of elements.  */
9233
9234 static int
9235 ada_same_array_size_p (struct type *t1, struct type *t2)
9236 {
9237   LONGEST lo1, hi1, lo2, hi2;
9238
9239   /* Get the array bounds in order to verify that the size of
9240      the two arrays match.  */
9241   if (!get_array_bounds (t1, &lo1, &hi1)
9242       || !get_array_bounds (t2, &lo2, &hi2))
9243     error (_("unable to determine array bounds"));
9244
9245   /* To make things easier for size comparison, normalize a bit
9246      the case of empty arrays by making sure that the difference
9247      between upper bound and lower bound is always -1.  */
9248   if (lo1 > hi1)
9249     hi1 = lo1 - 1;
9250   if (lo2 > hi2)
9251     hi2 = lo2 - 1;
9252
9253   return (hi1 - lo1 == hi2 - lo2);
9254 }
9255
9256 /* Assuming that VAL is an array of integrals, and TYPE represents
9257    an array with the same number of elements, but with wider integral
9258    elements, return an array "casted" to TYPE.  In practice, this
9259    means that the returned array is built by casting each element
9260    of the original array into TYPE's (wider) element type.  */
9261
9262 static struct value *
9263 ada_promote_array_of_integrals (struct type *type, struct value *val)
9264 {
9265   struct type *elt_type = TYPE_TARGET_TYPE (type);
9266   LONGEST lo, hi;
9267   LONGEST i;
9268
9269   /* Verify that both val and type are arrays of scalars, and
9270      that the size of val's elements is smaller than the size
9271      of type's element.  */
9272   gdb_assert (type->code () == TYPE_CODE_ARRAY);
9273   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9274   gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
9275   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9276   gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9277               > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9278
9279   if (!get_array_bounds (type, &lo, &hi))
9280     error (_("unable to determine array bounds"));
9281
9282   value *res = allocate_value (type);
9283   gdb::array_view<gdb_byte> res_contents = value_contents_writeable (res);
9284
9285   /* Promote each array element.  */
9286   for (i = 0; i < hi - lo + 1; i++)
9287     {
9288       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9289       int elt_len = TYPE_LENGTH (elt_type);
9290
9291       copy (value_contents_all (elt), res_contents.slice (elt_len * i, elt_len));
9292     }
9293
9294   return res;
9295 }
9296
9297 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9298    return the converted value.  */
9299
9300 static struct value *
9301 coerce_for_assign (struct type *type, struct value *val)
9302 {
9303   struct type *type2 = value_type (val);
9304
9305   if (type == type2)
9306     return val;
9307
9308   type2 = ada_check_typedef (type2);
9309   type = ada_check_typedef (type);
9310
9311   if (type2->code () == TYPE_CODE_PTR
9312       && type->code () == TYPE_CODE_ARRAY)
9313     {
9314       val = ada_value_ind (val);
9315       type2 = value_type (val);
9316     }
9317
9318   if (type2->code () == TYPE_CODE_ARRAY
9319       && type->code () == TYPE_CODE_ARRAY)
9320     {
9321       if (!ada_same_array_size_p (type, type2))
9322         error (_("cannot assign arrays of different length"));
9323
9324       if (is_integral_type (TYPE_TARGET_TYPE (type))
9325           && is_integral_type (TYPE_TARGET_TYPE (type2))
9326           && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9327                < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9328         {
9329           /* Allow implicit promotion of the array elements to
9330              a wider type.  */
9331           return ada_promote_array_of_integrals (type, val);
9332         }
9333
9334       if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9335           != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9336         error (_("Incompatible types in assignment"));
9337       deprecated_set_value_type (val, type);
9338     }
9339   return val;
9340 }
9341
9342 static struct value *
9343 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9344 {
9345   struct value *val;
9346   struct type *type1, *type2;
9347   LONGEST v, v1, v2;
9348
9349   arg1 = coerce_ref (arg1);
9350   arg2 = coerce_ref (arg2);
9351   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9352   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9353
9354   if (type1->code () != TYPE_CODE_INT
9355       || type2->code () != TYPE_CODE_INT)
9356     return value_binop (arg1, arg2, op);
9357
9358   switch (op)
9359     {
9360     case BINOP_MOD:
9361     case BINOP_DIV:
9362     case BINOP_REM:
9363       break;
9364     default:
9365       return value_binop (arg1, arg2, op);
9366     }
9367
9368   v2 = value_as_long (arg2);
9369   if (v2 == 0)
9370     {
9371       const char *name;
9372       if (op == BINOP_MOD)
9373         name = "mod";
9374       else if (op == BINOP_DIV)
9375         name = "/";
9376       else
9377         {
9378           gdb_assert (op == BINOP_REM);
9379           name = "rem";
9380         }
9381
9382       error (_("second operand of %s must not be zero."), name);
9383     }
9384
9385   if (type1->is_unsigned () || op == BINOP_MOD)
9386     return value_binop (arg1, arg2, op);
9387
9388   v1 = value_as_long (arg1);
9389   switch (op)
9390     {
9391     case BINOP_DIV:
9392       v = v1 / v2;
9393       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9394         v += v > 0 ? -1 : 1;
9395       break;
9396     case BINOP_REM:
9397       v = v1 % v2;
9398       if (v * v1 < 0)
9399         v -= v2;
9400       break;
9401     default:
9402       /* Should not reach this point.  */
9403       v = 0;
9404     }
9405
9406   val = allocate_value (type1);
9407   store_unsigned_integer (value_contents_raw (val).data (),
9408                           TYPE_LENGTH (value_type (val)),
9409                           type_byte_order (type1), v);
9410   return val;
9411 }
9412
9413 static int
9414 ada_value_equal (struct value *arg1, struct value *arg2)
9415 {
9416   if (ada_is_direct_array_type (value_type (arg1))
9417       || ada_is_direct_array_type (value_type (arg2)))
9418     {
9419       struct type *arg1_type, *arg2_type;
9420
9421       /* Automatically dereference any array reference before
9422          we attempt to perform the comparison.  */
9423       arg1 = ada_coerce_ref (arg1);
9424       arg2 = ada_coerce_ref (arg2);
9425
9426       arg1 = ada_coerce_to_simple_array (arg1);
9427       arg2 = ada_coerce_to_simple_array (arg2);
9428
9429       arg1_type = ada_check_typedef (value_type (arg1));
9430       arg2_type = ada_check_typedef (value_type (arg2));
9431
9432       if (arg1_type->code () != TYPE_CODE_ARRAY
9433           || arg2_type->code () != TYPE_CODE_ARRAY)
9434         error (_("Attempt to compare array with non-array"));
9435       /* FIXME: The following works only for types whose
9436          representations use all bits (no padding or undefined bits)
9437          and do not have user-defined equality.  */
9438       return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9439               && memcmp (value_contents (arg1).data (),
9440                          value_contents (arg2).data (),
9441                          TYPE_LENGTH (arg1_type)) == 0);
9442     }
9443   return value_equal (arg1, arg2);
9444 }
9445
9446 namespace expr
9447 {
9448
9449 bool
9450 check_objfile (const std::unique_ptr<ada_component> &comp,
9451                struct objfile *objfile)
9452 {
9453   return comp->uses_objfile (objfile);
9454 }
9455
9456 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9457    component of LHS (a simple array or a record).  Does not modify the
9458    inferior's memory, nor does it modify LHS (unless LHS ==
9459    CONTAINER).  */
9460
9461 static void
9462 assign_component (struct value *container, struct value *lhs, LONGEST index,
9463                   struct expression *exp, operation_up &arg)
9464 {
9465   scoped_value_mark mark;
9466
9467   struct value *elt;
9468   struct type *lhs_type = check_typedef (value_type (lhs));
9469
9470   if (lhs_type->code () == TYPE_CODE_ARRAY)
9471     {
9472       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9473       struct value *index_val = value_from_longest (index_type, index);
9474
9475       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9476     }
9477   else
9478     {
9479       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9480       elt = ada_to_fixed_value (elt);
9481     }
9482
9483   ada_aggregate_operation *ag_op
9484     = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9485   if (ag_op != nullptr)
9486     ag_op->assign_aggregate (container, elt, exp);
9487   else
9488     value_assign_to_component (container, elt,
9489                                arg->evaluate (nullptr, exp,
9490                                               EVAL_NORMAL));
9491 }
9492
9493 bool
9494 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9495 {
9496   for (const auto &item : m_components)
9497     if (item->uses_objfile (objfile))
9498       return true;
9499   return false;
9500 }
9501
9502 void
9503 ada_aggregate_component::dump (ui_file *stream, int depth)
9504 {
9505   gdb_printf (stream, _("%*sAggregate\n"), depth, "");
9506   for (const auto &item : m_components)
9507     item->dump (stream, depth + 1);
9508 }
9509
9510 void
9511 ada_aggregate_component::assign (struct value *container,
9512                                  struct value *lhs, struct expression *exp,
9513                                  std::vector<LONGEST> &indices,
9514                                  LONGEST low, LONGEST high)
9515 {
9516   for (auto &item : m_components)
9517     item->assign (container, lhs, exp, indices, low, high);
9518 }
9519
9520 /* See ada-exp.h.  */
9521
9522 value *
9523 ada_aggregate_operation::assign_aggregate (struct value *container,
9524                                            struct value *lhs,
9525                                            struct expression *exp)
9526 {
9527   struct type *lhs_type;
9528   LONGEST low_index, high_index;
9529
9530   container = ada_coerce_ref (container);
9531   if (ada_is_direct_array_type (value_type (container)))
9532     container = ada_coerce_to_simple_array (container);
9533   lhs = ada_coerce_ref (lhs);
9534   if (!deprecated_value_modifiable (lhs))
9535     error (_("Left operand of assignment is not a modifiable lvalue."));
9536
9537   lhs_type = check_typedef (value_type (lhs));
9538   if (ada_is_direct_array_type (lhs_type))
9539     {
9540       lhs = ada_coerce_to_simple_array (lhs);
9541       lhs_type = check_typedef (value_type (lhs));
9542       low_index = lhs_type->bounds ()->low.const_val ();
9543       high_index = lhs_type->bounds ()->high.const_val ();
9544     }
9545   else if (lhs_type->code () == TYPE_CODE_STRUCT)
9546     {
9547       low_index = 0;
9548       high_index = num_visible_fields (lhs_type) - 1;
9549     }
9550   else
9551     error (_("Left-hand side must be array or record."));
9552
9553   std::vector<LONGEST> indices (4);
9554   indices[0] = indices[1] = low_index - 1;
9555   indices[2] = indices[3] = high_index + 1;
9556
9557   std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9558                                    low_index, high_index);
9559
9560   return container;
9561 }
9562
9563 bool
9564 ada_positional_component::uses_objfile (struct objfile *objfile)
9565 {
9566   return m_op->uses_objfile (objfile);
9567 }
9568
9569 void
9570 ada_positional_component::dump (ui_file *stream, int depth)
9571 {
9572   gdb_printf (stream, _("%*sPositional, index = %d\n"),
9573               depth, "", m_index);
9574   m_op->dump (stream, depth + 1);
9575 }
9576
9577 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9578    construct, given that the positions are relative to lower bound
9579    LOW, where HIGH is the upper bound.  Record the position in
9580    INDICES.  CONTAINER is as for assign_aggregate.  */
9581 void
9582 ada_positional_component::assign (struct value *container,
9583                                   struct value *lhs, struct expression *exp,
9584                                   std::vector<LONGEST> &indices,
9585                                   LONGEST low, LONGEST high)
9586 {
9587   LONGEST ind = m_index + low;
9588
9589   if (ind - 1 == high)
9590     warning (_("Extra components in aggregate ignored."));
9591   if (ind <= high)
9592     {
9593       add_component_interval (ind, ind, indices);
9594       assign_component (container, lhs, ind, exp, m_op);
9595     }
9596 }
9597
9598 bool
9599 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9600 {
9601   return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9602 }
9603
9604 void
9605 ada_discrete_range_association::dump (ui_file *stream, int depth)
9606 {
9607   gdb_printf (stream, _("%*sDiscrete range:\n"), depth, "");
9608   m_low->dump (stream, depth + 1);
9609   m_high->dump (stream, depth + 1);
9610 }
9611
9612 void
9613 ada_discrete_range_association::assign (struct value *container,
9614                                         struct value *lhs,
9615                                         struct expression *exp,
9616                                         std::vector<LONGEST> &indices,
9617                                         LONGEST low, LONGEST high,
9618                                         operation_up &op)
9619 {
9620   LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9621   LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9622
9623   if (lower <= upper && (lower < low || upper > high))
9624     error (_("Index in component association out of bounds."));
9625
9626   add_component_interval (lower, upper, indices);
9627   while (lower <= upper)
9628     {
9629       assign_component (container, lhs, lower, exp, op);
9630       lower += 1;
9631     }
9632 }
9633
9634 bool
9635 ada_name_association::uses_objfile (struct objfile *objfile)
9636 {
9637   return m_val->uses_objfile (objfile);
9638 }
9639
9640 void
9641 ada_name_association::dump (ui_file *stream, int depth)
9642 {
9643   gdb_printf (stream, _("%*sName:\n"), depth, "");
9644   m_val->dump (stream, depth + 1);
9645 }
9646
9647 void
9648 ada_name_association::assign (struct value *container,
9649                               struct value *lhs,
9650                               struct expression *exp,
9651                               std::vector<LONGEST> &indices,
9652                               LONGEST low, LONGEST high,
9653                               operation_up &op)
9654 {
9655   int index;
9656
9657   if (ada_is_direct_array_type (value_type (lhs)))
9658     index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9659                                                             EVAL_NORMAL)));
9660   else
9661     {
9662       ada_string_operation *strop
9663         = dynamic_cast<ada_string_operation *> (m_val.get ());
9664
9665       const char *name;
9666       if (strop != nullptr)
9667         name = strop->get_name ();
9668       else
9669         {
9670           ada_var_value_operation *vvo
9671             = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9672           if (vvo != nullptr)
9673             error (_("Invalid record component association."));
9674           name = vvo->get_symbol ()->natural_name ();
9675         }
9676
9677       index = 0;
9678       if (! find_struct_field (name, value_type (lhs), 0,
9679                                NULL, NULL, NULL, NULL, &index))
9680         error (_("Unknown component name: %s."), name);
9681     }
9682
9683   add_component_interval (index, index, indices);
9684   assign_component (container, lhs, index, exp, op);
9685 }
9686
9687 bool
9688 ada_choices_component::uses_objfile (struct objfile *objfile)
9689 {
9690   if (m_op->uses_objfile (objfile))
9691     return true;
9692   for (const auto &item : m_assocs)
9693     if (item->uses_objfile (objfile))
9694       return true;
9695   return false;
9696 }
9697
9698 void
9699 ada_choices_component::dump (ui_file *stream, int depth)
9700 {
9701   gdb_printf (stream, _("%*sChoices:\n"), depth, "");
9702   m_op->dump (stream, depth + 1);
9703   for (const auto &item : m_assocs)
9704     item->dump (stream, depth + 1);
9705 }
9706
9707 /* Assign into the components of LHS indexed by the OP_CHOICES
9708    construct at *POS, updating *POS past the construct, given that
9709    the allowable indices are LOW..HIGH.  Record the indices assigned
9710    to in INDICES.  CONTAINER is as for assign_aggregate.  */
9711 void
9712 ada_choices_component::assign (struct value *container,
9713                                struct value *lhs, struct expression *exp,
9714                                std::vector<LONGEST> &indices,
9715                                LONGEST low, LONGEST high)
9716 {
9717   for (auto &item : m_assocs)
9718     item->assign (container, lhs, exp, indices, low, high, m_op);
9719 }
9720
9721 bool
9722 ada_others_component::uses_objfile (struct objfile *objfile)
9723 {
9724   return m_op->uses_objfile (objfile);
9725 }
9726
9727 void
9728 ada_others_component::dump (ui_file *stream, int depth)
9729 {
9730   gdb_printf (stream, _("%*sOthers:\n"), depth, "");
9731   m_op->dump (stream, depth + 1);
9732 }
9733
9734 /* Assign the value of the expression in the OP_OTHERS construct in
9735    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9736    have not been previously assigned.  The index intervals already assigned
9737    are in INDICES.  CONTAINER is as for assign_aggregate.  */
9738 void
9739 ada_others_component::assign (struct value *container,
9740                               struct value *lhs, struct expression *exp,
9741                               std::vector<LONGEST> &indices,
9742                               LONGEST low, LONGEST high)
9743 {
9744   int num_indices = indices.size ();
9745   for (int i = 0; i < num_indices - 2; i += 2)
9746     {
9747       for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9748         assign_component (container, lhs, ind, exp, m_op);
9749     }
9750 }
9751
9752 struct value *
9753 ada_assign_operation::evaluate (struct type *expect_type,
9754                                 struct expression *exp,
9755                                 enum noside noside)
9756 {
9757   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9758
9759   ada_aggregate_operation *ag_op
9760     = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9761   if (ag_op != nullptr)
9762     {
9763       if (noside != EVAL_NORMAL)
9764         return arg1;
9765
9766       arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9767       return ada_value_assign (arg1, arg1);
9768     }
9769   /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9770      except if the lhs of our assignment is a convenience variable.
9771      In the case of assigning to a convenience variable, the lhs
9772      should be exactly the result of the evaluation of the rhs.  */
9773   struct type *type = value_type (arg1);
9774   if (VALUE_LVAL (arg1) == lval_internalvar)
9775     type = NULL;
9776   value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9777   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9778     return arg1;
9779   if (VALUE_LVAL (arg1) == lval_internalvar)
9780     {
9781       /* Nothing.  */
9782     }
9783   else
9784     arg2 = coerce_for_assign (value_type (arg1), arg2);
9785   return ada_value_assign (arg1, arg2);
9786 }
9787
9788 } /* namespace expr */
9789
9790 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9791    [ INDICES[0] .. INDICES[1] ],...  The resulting intervals do not
9792    overlap.  */
9793 static void
9794 add_component_interval (LONGEST low, LONGEST high, 
9795                         std::vector<LONGEST> &indices)
9796 {
9797   int i, j;
9798
9799   int size = indices.size ();
9800   for (i = 0; i < size; i += 2) {
9801     if (high >= indices[i] && low <= indices[i + 1])
9802       {
9803         int kh;
9804
9805         for (kh = i + 2; kh < size; kh += 2)
9806           if (high < indices[kh])
9807             break;
9808         if (low < indices[i])
9809           indices[i] = low;
9810         indices[i + 1] = indices[kh - 1];
9811         if (high > indices[i + 1])
9812           indices[i + 1] = high;
9813         memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9814         indices.resize (kh - i - 2);
9815         return;
9816       }
9817     else if (high < indices[i])
9818       break;
9819   }
9820         
9821   indices.resize (indices.size () + 2);
9822   for (j = indices.size () - 1; j >= i + 2; j -= 1)
9823     indices[j] = indices[j - 2];
9824   indices[i] = low;
9825   indices[i + 1] = high;
9826 }
9827
9828 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9829    is different.  */
9830
9831 static struct value *
9832 ada_value_cast (struct type *type, struct value *arg2)
9833 {
9834   if (type == ada_check_typedef (value_type (arg2)))
9835     return arg2;
9836
9837   return value_cast (type, arg2);
9838 }
9839
9840 /*  Evaluating Ada expressions, and printing their result.
9841     ------------------------------------------------------
9842
9843     1. Introduction:
9844     ----------------
9845
9846     We usually evaluate an Ada expression in order to print its value.
9847     We also evaluate an expression in order to print its type, which
9848     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9849     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
9850     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9851     the evaluation compared to the EVAL_NORMAL, but is otherwise very
9852     similar.
9853
9854     Evaluating expressions is a little more complicated for Ada entities
9855     than it is for entities in languages such as C.  The main reason for
9856     this is that Ada provides types whose definition might be dynamic.
9857     One example of such types is variant records.  Or another example
9858     would be an array whose bounds can only be known at run time.
9859
9860     The following description is a general guide as to what should be
9861     done (and what should NOT be done) in order to evaluate an expression
9862     involving such types, and when.  This does not cover how the semantic
9863     information is encoded by GNAT as this is covered separatly.  For the
9864     document used as the reference for the GNAT encoding, see exp_dbug.ads
9865     in the GNAT sources.
9866
9867     Ideally, we should embed each part of this description next to its
9868     associated code.  Unfortunately, the amount of code is so vast right
9869     now that it's hard to see whether the code handling a particular
9870     situation might be duplicated or not.  One day, when the code is
9871     cleaned up, this guide might become redundant with the comments
9872     inserted in the code, and we might want to remove it.
9873
9874     2. ``Fixing'' an Entity, the Simple Case:
9875     -----------------------------------------
9876
9877     When evaluating Ada expressions, the tricky issue is that they may
9878     reference entities whose type contents and size are not statically
9879     known.  Consider for instance a variant record:
9880
9881        type Rec (Empty : Boolean := True) is record
9882           case Empty is
9883              when True => null;
9884              when False => Value : Integer;
9885           end case;
9886        end record;
9887        Yes : Rec := (Empty => False, Value => 1);
9888        No  : Rec := (empty => True);
9889
9890     The size and contents of that record depends on the value of the
9891     descriminant (Rec.Empty).  At this point, neither the debugging
9892     information nor the associated type structure in GDB are able to
9893     express such dynamic types.  So what the debugger does is to create
9894     "fixed" versions of the type that applies to the specific object.
9895     We also informally refer to this operation as "fixing" an object,
9896     which means creating its associated fixed type.
9897
9898     Example: when printing the value of variable "Yes" above, its fixed
9899     type would look like this:
9900
9901        type Rec is record
9902           Empty : Boolean;
9903           Value : Integer;
9904        end record;
9905
9906     On the other hand, if we printed the value of "No", its fixed type
9907     would become:
9908
9909        type Rec is record
9910           Empty : Boolean;
9911        end record;
9912
9913     Things become a little more complicated when trying to fix an entity
9914     with a dynamic type that directly contains another dynamic type,
9915     such as an array of variant records, for instance.  There are
9916     two possible cases: Arrays, and records.
9917
9918     3. ``Fixing'' Arrays:
9919     ---------------------
9920
9921     The type structure in GDB describes an array in terms of its bounds,
9922     and the type of its elements.  By design, all elements in the array
9923     have the same type and we cannot represent an array of variant elements
9924     using the current type structure in GDB.  When fixing an array,
9925     we cannot fix the array element, as we would potentially need one
9926     fixed type per element of the array.  As a result, the best we can do
9927     when fixing an array is to produce an array whose bounds and size
9928     are correct (allowing us to read it from memory), but without having
9929     touched its element type.  Fixing each element will be done later,
9930     when (if) necessary.
9931
9932     Arrays are a little simpler to handle than records, because the same
9933     amount of memory is allocated for each element of the array, even if
9934     the amount of space actually used by each element differs from element
9935     to element.  Consider for instance the following array of type Rec:
9936
9937        type Rec_Array is array (1 .. 2) of Rec;
9938
9939     The actual amount of memory occupied by each element might be different
9940     from element to element, depending on the value of their discriminant.
9941     But the amount of space reserved for each element in the array remains
9942     fixed regardless.  So we simply need to compute that size using
9943     the debugging information available, from which we can then determine
9944     the array size (we multiply the number of elements of the array by
9945     the size of each element).
9946
9947     The simplest case is when we have an array of a constrained element
9948     type. For instance, consider the following type declarations:
9949
9950         type Bounded_String (Max_Size : Integer) is
9951            Length : Integer;
9952            Buffer : String (1 .. Max_Size);
9953         end record;
9954         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9955
9956     In this case, the compiler describes the array as an array of
9957     variable-size elements (identified by its XVS suffix) for which
9958     the size can be read in the parallel XVZ variable.
9959
9960     In the case of an array of an unconstrained element type, the compiler
9961     wraps the array element inside a private PAD type.  This type should not
9962     be shown to the user, and must be "unwrap"'ed before printing.  Note
9963     that we also use the adjective "aligner" in our code to designate
9964     these wrapper types.
9965
9966     In some cases, the size allocated for each element is statically
9967     known.  In that case, the PAD type already has the correct size,
9968     and the array element should remain unfixed.
9969
9970     But there are cases when this size is not statically known.
9971     For instance, assuming that "Five" is an integer variable:
9972
9973         type Dynamic is array (1 .. Five) of Integer;
9974         type Wrapper (Has_Length : Boolean := False) is record
9975            Data : Dynamic;
9976            case Has_Length is
9977               when True => Length : Integer;
9978               when False => null;
9979            end case;
9980         end record;
9981         type Wrapper_Array is array (1 .. 2) of Wrapper;
9982
9983         Hello : Wrapper_Array := (others => (Has_Length => True,
9984                                              Data => (others => 17),
9985                                              Length => 1));
9986
9987
9988     The debugging info would describe variable Hello as being an
9989     array of a PAD type.  The size of that PAD type is not statically
9990     known, but can be determined using a parallel XVZ variable.
9991     In that case, a copy of the PAD type with the correct size should
9992     be used for the fixed array.
9993
9994     3. ``Fixing'' record type objects:
9995     ----------------------------------
9996
9997     Things are slightly different from arrays in the case of dynamic
9998     record types.  In this case, in order to compute the associated
9999     fixed type, we need to determine the size and offset of each of
10000     its components.  This, in turn, requires us to compute the fixed
10001     type of each of these components.
10002
10003     Consider for instance the example:
10004
10005         type Bounded_String (Max_Size : Natural) is record
10006            Str : String (1 .. Max_Size);
10007            Length : Natural;
10008         end record;
10009         My_String : Bounded_String (Max_Size => 10);
10010
10011     In that case, the position of field "Length" depends on the size
10012     of field Str, which itself depends on the value of the Max_Size
10013     discriminant.  In order to fix the type of variable My_String,
10014     we need to fix the type of field Str.  Therefore, fixing a variant
10015     record requires us to fix each of its components.
10016
10017     However, if a component does not have a dynamic size, the component
10018     should not be fixed.  In particular, fields that use a PAD type
10019     should not fixed.  Here is an example where this might happen
10020     (assuming type Rec above):
10021
10022        type Container (Big : Boolean) is record
10023           First : Rec;
10024           After : Integer;
10025           case Big is
10026              when True => Another : Integer;
10027              when False => null;
10028           end case;
10029        end record;
10030        My_Container : Container := (Big => False,
10031                                     First => (Empty => True),
10032                                     After => 42);
10033
10034     In that example, the compiler creates a PAD type for component First,
10035     whose size is constant, and then positions the component After just
10036     right after it.  The offset of component After is therefore constant
10037     in this case.
10038
10039     The debugger computes the position of each field based on an algorithm
10040     that uses, among other things, the actual position and size of the field
10041     preceding it.  Let's now imagine that the user is trying to print
10042     the value of My_Container.  If the type fixing was recursive, we would
10043     end up computing the offset of field After based on the size of the
10044     fixed version of field First.  And since in our example First has
10045     only one actual field, the size of the fixed type is actually smaller
10046     than the amount of space allocated to that field, and thus we would
10047     compute the wrong offset of field After.
10048
10049     To make things more complicated, we need to watch out for dynamic
10050     components of variant records (identified by the ___XVL suffix in
10051     the component name).  Even if the target type is a PAD type, the size
10052     of that type might not be statically known.  So the PAD type needs
10053     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
10054     we might end up with the wrong size for our component.  This can be
10055     observed with the following type declarations:
10056
10057         type Octal is new Integer range 0 .. 7;
10058         type Octal_Array is array (Positive range <>) of Octal;
10059         pragma Pack (Octal_Array);
10060
10061         type Octal_Buffer (Size : Positive) is record
10062            Buffer : Octal_Array (1 .. Size);
10063            Length : Integer;
10064         end record;
10065
10066     In that case, Buffer is a PAD type whose size is unset and needs
10067     to be computed by fixing the unwrapped type.
10068
10069     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10070     ----------------------------------------------------------
10071
10072     Lastly, when should the sub-elements of an entity that remained unfixed
10073     thus far, be actually fixed?
10074
10075     The answer is: Only when referencing that element.  For instance
10076     when selecting one component of a record, this specific component
10077     should be fixed at that point in time.  Or when printing the value
10078     of a record, each component should be fixed before its value gets
10079     printed.  Similarly for arrays, the element of the array should be
10080     fixed when printing each element of the array, or when extracting
10081     one element out of that array.  On the other hand, fixing should
10082     not be performed on the elements when taking a slice of an array!
10083
10084     Note that one of the side effects of miscomputing the offset and
10085     size of each field is that we end up also miscomputing the size
10086     of the containing type.  This can have adverse results when computing
10087     the value of an entity.  GDB fetches the value of an entity based
10088     on the size of its type, and thus a wrong size causes GDB to fetch
10089     the wrong amount of memory.  In the case where the computed size is
10090     too small, GDB fetches too little data to print the value of our
10091     entity.  Results in this case are unpredictable, as we usually read
10092     past the buffer containing the data =:-o.  */
10093
10094 /* A helper function for TERNOP_IN_RANGE.  */
10095
10096 static value *
10097 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
10098                       enum noside noside,
10099                       value *arg1, value *arg2, value *arg3)
10100 {
10101   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10102   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10103   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10104   return
10105     value_from_longest (type,
10106                         (value_less (arg1, arg3)
10107                          || value_equal (arg1, arg3))
10108                         && (value_less (arg2, arg1)
10109                             || value_equal (arg2, arg1)));
10110 }
10111
10112 /* A helper function for UNOP_NEG.  */
10113
10114 value *
10115 ada_unop_neg (struct type *expect_type,
10116               struct expression *exp,
10117               enum noside noside, enum exp_opcode op,
10118               struct value *arg1)
10119 {
10120   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10121   return value_neg (arg1);
10122 }
10123
10124 /* A helper function for UNOP_IN_RANGE.  */
10125
10126 value *
10127 ada_unop_in_range (struct type *expect_type,
10128                    struct expression *exp,
10129                    enum noside noside, enum exp_opcode op,
10130                    struct value *arg1, struct type *type)
10131 {
10132   struct value *arg2, *arg3;
10133   switch (type->code ())
10134     {
10135     default:
10136       lim_warning (_("Membership test incompletely implemented; "
10137                      "always returns true"));
10138       type = language_bool_type (exp->language_defn, exp->gdbarch);
10139       return value_from_longest (type, (LONGEST) 1);
10140
10141     case TYPE_CODE_RANGE:
10142       arg2 = value_from_longest (type,
10143                                  type->bounds ()->low.const_val ());
10144       arg3 = value_from_longest (type,
10145                                  type->bounds ()->high.const_val ());
10146       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10147       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10148       type = language_bool_type (exp->language_defn, exp->gdbarch);
10149       return
10150         value_from_longest (type,
10151                             (value_less (arg1, arg3)
10152                              || value_equal (arg1, arg3))
10153                             && (value_less (arg2, arg1)
10154                                 || value_equal (arg2, arg1)));
10155     }
10156 }
10157
10158 /* A helper function for OP_ATR_TAG.  */
10159
10160 value *
10161 ada_atr_tag (struct type *expect_type,
10162              struct expression *exp,
10163              enum noside noside, enum exp_opcode op,
10164              struct value *arg1)
10165 {
10166   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10167     return value_zero (ada_tag_type (arg1), not_lval);
10168
10169   return ada_value_tag (arg1);
10170 }
10171
10172 /* A helper function for OP_ATR_SIZE.  */
10173
10174 value *
10175 ada_atr_size (struct type *expect_type,
10176               struct expression *exp,
10177               enum noside noside, enum exp_opcode op,
10178               struct value *arg1)
10179 {
10180   struct type *type = value_type (arg1);
10181
10182   /* If the argument is a reference, then dereference its type, since
10183      the user is really asking for the size of the actual object,
10184      not the size of the pointer.  */
10185   if (type->code () == TYPE_CODE_REF)
10186     type = TYPE_TARGET_TYPE (type);
10187
10188   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10189     return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
10190   else
10191     return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
10192                                TARGET_CHAR_BIT * TYPE_LENGTH (type));
10193 }
10194
10195 /* A helper function for UNOP_ABS.  */
10196
10197 value *
10198 ada_abs (struct type *expect_type,
10199          struct expression *exp,
10200          enum noside noside, enum exp_opcode op,
10201          struct value *arg1)
10202 {
10203   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10204   if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
10205     return value_neg (arg1);
10206   else
10207     return arg1;
10208 }
10209
10210 /* A helper function for BINOP_MUL.  */
10211
10212 value *
10213 ada_mult_binop (struct type *expect_type,
10214                 struct expression *exp,
10215                 enum noside noside, enum exp_opcode op,
10216                 struct value *arg1, struct value *arg2)
10217 {
10218   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10219     {
10220       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10221       return value_zero (value_type (arg1), not_lval);
10222     }
10223   else
10224     {
10225       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10226       return ada_value_binop (arg1, arg2, op);
10227     }
10228 }
10229
10230 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL.  */
10231
10232 value *
10233 ada_equal_binop (struct type *expect_type,
10234                  struct expression *exp,
10235                  enum noside noside, enum exp_opcode op,
10236                  struct value *arg1, struct value *arg2)
10237 {
10238   int tem;
10239   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10240     tem = 0;
10241   else
10242     {
10243       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10244       tem = ada_value_equal (arg1, arg2);
10245     }
10246   if (op == BINOP_NOTEQUAL)
10247     tem = !tem;
10248   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10249   return value_from_longest (type, (LONGEST) tem);
10250 }
10251
10252 /* A helper function for TERNOP_SLICE.  */
10253
10254 value *
10255 ada_ternop_slice (struct expression *exp,
10256                   enum noside noside,
10257                   struct value *array, struct value *low_bound_val,
10258                   struct value *high_bound_val)
10259 {
10260   LONGEST low_bound;
10261   LONGEST high_bound;
10262
10263   low_bound_val = coerce_ref (low_bound_val);
10264   high_bound_val = coerce_ref (high_bound_val);
10265   low_bound = value_as_long (low_bound_val);
10266   high_bound = value_as_long (high_bound_val);
10267
10268   /* If this is a reference to an aligner type, then remove all
10269      the aligners.  */
10270   if (value_type (array)->code () == TYPE_CODE_REF
10271       && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10272     TYPE_TARGET_TYPE (value_type (array)) =
10273       ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
10274
10275   if (ada_is_any_packed_array_type (value_type (array)))
10276     error (_("cannot slice a packed array"));
10277
10278   /* If this is a reference to an array or an array lvalue,
10279      convert to a pointer.  */
10280   if (value_type (array)->code () == TYPE_CODE_REF
10281       || (value_type (array)->code () == TYPE_CODE_ARRAY
10282           && VALUE_LVAL (array) == lval_memory))
10283     array = value_addr (array);
10284
10285   if (noside == EVAL_AVOID_SIDE_EFFECTS
10286       && ada_is_array_descriptor_type (ada_check_typedef
10287                                        (value_type (array))))
10288     return empty_array (ada_type_of_array (array, 0), low_bound,
10289                         high_bound);
10290
10291   array = ada_coerce_to_simple_array_ptr (array);
10292
10293   /* If we have more than one level of pointer indirection,
10294      dereference the value until we get only one level.  */
10295   while (value_type (array)->code () == TYPE_CODE_PTR
10296          && (TYPE_TARGET_TYPE (value_type (array))->code ()
10297              == TYPE_CODE_PTR))
10298     array = value_ind (array);
10299
10300   /* Make sure we really do have an array type before going further,
10301      to avoid a SEGV when trying to get the index type or the target
10302      type later down the road if the debug info generated by
10303      the compiler is incorrect or incomplete.  */
10304   if (!ada_is_simple_array_type (value_type (array)))
10305     error (_("cannot take slice of non-array"));
10306
10307   if (ada_check_typedef (value_type (array))->code ()
10308       == TYPE_CODE_PTR)
10309     {
10310       struct type *type0 = ada_check_typedef (value_type (array));
10311
10312       if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10313         return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
10314       else
10315         {
10316           struct type *arr_type0 =
10317             to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
10318
10319           return ada_value_slice_from_ptr (array, arr_type0,
10320                                            longest_to_int (low_bound),
10321                                            longest_to_int (high_bound));
10322         }
10323     }
10324   else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10325     return array;
10326   else if (high_bound < low_bound)
10327     return empty_array (value_type (array), low_bound, high_bound);
10328   else
10329     return ada_value_slice (array, longest_to_int (low_bound),
10330                             longest_to_int (high_bound));
10331 }
10332
10333 /* A helper function for BINOP_IN_BOUNDS.  */
10334
10335 value *
10336 ada_binop_in_bounds (struct expression *exp, enum noside noside,
10337                      struct value *arg1, struct value *arg2, int n)
10338 {
10339   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10340     {
10341       struct type *type = language_bool_type (exp->language_defn,
10342                                               exp->gdbarch);
10343       return value_zero (type, not_lval);
10344     }
10345
10346   struct type *type = ada_index_type (value_type (arg2), n, "range");
10347   if (!type)
10348     type = value_type (arg1);
10349
10350   value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
10351   arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
10352
10353   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10354   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10355   type = language_bool_type (exp->language_defn, exp->gdbarch);
10356   return value_from_longest (type,
10357                              (value_less (arg1, arg3)
10358                               || value_equal (arg1, arg3))
10359                              && (value_less (arg2, arg1)
10360                                  || value_equal (arg2, arg1)));
10361 }
10362
10363 /* A helper function for some attribute operations.  */
10364
10365 static value *
10366 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
10367               struct value *arg1, struct type *type_arg, int tem)
10368 {
10369   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10370     {
10371       if (type_arg == NULL)
10372         type_arg = value_type (arg1);
10373
10374       if (ada_is_constrained_packed_array_type (type_arg))
10375         type_arg = decode_constrained_packed_array_type (type_arg);
10376
10377       if (!discrete_type_p (type_arg))
10378         {
10379           switch (op)
10380             {
10381             default:          /* Should never happen.  */
10382               error (_("unexpected attribute encountered"));
10383             case OP_ATR_FIRST:
10384             case OP_ATR_LAST:
10385               type_arg = ada_index_type (type_arg, tem,
10386                                          ada_attribute_name (op));
10387               break;
10388             case OP_ATR_LENGTH:
10389               type_arg = builtin_type (exp->gdbarch)->builtin_int;
10390               break;
10391             }
10392         }
10393
10394       return value_zero (type_arg, not_lval);
10395     }
10396   else if (type_arg == NULL)
10397     {
10398       arg1 = ada_coerce_ref (arg1);
10399
10400       if (ada_is_constrained_packed_array_type (value_type (arg1)))
10401         arg1 = ada_coerce_to_simple_array (arg1);
10402
10403       struct type *type;
10404       if (op == OP_ATR_LENGTH)
10405         type = builtin_type (exp->gdbarch)->builtin_int;
10406       else
10407         {
10408           type = ada_index_type (value_type (arg1), tem,
10409                                  ada_attribute_name (op));
10410           if (type == NULL)
10411             type = builtin_type (exp->gdbarch)->builtin_int;
10412         }
10413
10414       switch (op)
10415         {
10416         default:          /* Should never happen.  */
10417           error (_("unexpected attribute encountered"));
10418         case OP_ATR_FIRST:
10419           return value_from_longest
10420             (type, ada_array_bound (arg1, tem, 0));
10421         case OP_ATR_LAST:
10422           return value_from_longest
10423             (type, ada_array_bound (arg1, tem, 1));
10424         case OP_ATR_LENGTH:
10425           return value_from_longest
10426             (type, ada_array_length (arg1, tem));
10427         }
10428     }
10429   else if (discrete_type_p (type_arg))
10430     {
10431       struct type *range_type;
10432       const char *name = ada_type_name (type_arg);
10433
10434       range_type = NULL;
10435       if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10436         range_type = to_fixed_range_type (type_arg, NULL);
10437       if (range_type == NULL)
10438         range_type = type_arg;
10439       switch (op)
10440         {
10441         default:
10442           error (_("unexpected attribute encountered"));
10443         case OP_ATR_FIRST:
10444           return value_from_longest 
10445             (range_type, ada_discrete_type_low_bound (range_type));
10446         case OP_ATR_LAST:
10447           return value_from_longest
10448             (range_type, ada_discrete_type_high_bound (range_type));
10449         case OP_ATR_LENGTH:
10450           error (_("the 'length attribute applies only to array types"));
10451         }
10452     }
10453   else if (type_arg->code () == TYPE_CODE_FLT)
10454     error (_("unimplemented type attribute"));
10455   else
10456     {
10457       LONGEST low, high;
10458
10459       if (ada_is_constrained_packed_array_type (type_arg))
10460         type_arg = decode_constrained_packed_array_type (type_arg);
10461
10462       struct type *type;
10463       if (op == OP_ATR_LENGTH)
10464         type = builtin_type (exp->gdbarch)->builtin_int;
10465       else
10466         {
10467           type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10468           if (type == NULL)
10469             type = builtin_type (exp->gdbarch)->builtin_int;
10470         }
10471
10472       switch (op)
10473         {
10474         default:
10475           error (_("unexpected attribute encountered"));
10476         case OP_ATR_FIRST:
10477           low = ada_array_bound_from_type (type_arg, tem, 0);
10478           return value_from_longest (type, low);
10479         case OP_ATR_LAST:
10480           high = ada_array_bound_from_type (type_arg, tem, 1);
10481           return value_from_longest (type, high);
10482         case OP_ATR_LENGTH:
10483           low = ada_array_bound_from_type (type_arg, tem, 0);
10484           high = ada_array_bound_from_type (type_arg, tem, 1);
10485           return value_from_longest (type, high - low + 1);
10486         }
10487     }
10488 }
10489
10490 /* A helper function for OP_ATR_MIN and OP_ATR_MAX.  */
10491
10492 struct value *
10493 ada_binop_minmax (struct type *expect_type,
10494                   struct expression *exp,
10495                   enum noside noside, enum exp_opcode op,
10496                   struct value *arg1, struct value *arg2)
10497 {
10498   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10499     return value_zero (value_type (arg1), not_lval);
10500   else
10501     {
10502       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10503       return value_binop (arg1, arg2, op);
10504     }
10505 }
10506
10507 /* A helper function for BINOP_EXP.  */
10508
10509 struct value *
10510 ada_binop_exp (struct type *expect_type,
10511                struct expression *exp,
10512                enum noside noside, enum exp_opcode op,
10513                struct value *arg1, struct value *arg2)
10514 {
10515   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10516     return value_zero (value_type (arg1), not_lval);
10517   else
10518     {
10519       /* For integer exponentiation operations,
10520          only promote the first argument.  */
10521       if (is_integral_type (value_type (arg2)))
10522         unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10523       else
10524         binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10525
10526       return value_binop (arg1, arg2, op);
10527     }
10528 }
10529
10530 namespace expr
10531 {
10532
10533 /* See ada-exp.h.  */
10534
10535 operation_up
10536 ada_resolvable::replace (operation_up &&owner,
10537                          struct expression *exp,
10538                          bool deprocedure_p,
10539                          bool parse_completion,
10540                          innermost_block_tracker *tracker,
10541                          struct type *context_type)
10542 {
10543   if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10544     return (make_operation<ada_funcall_operation>
10545             (std::move (owner),
10546              std::vector<operation_up> ()));
10547   return std::move (owner);
10548 }
10549
10550 /* Convert the character literal whose value would be VAL to the
10551    appropriate value of type TYPE, if there is a translation.
10552    Otherwise return VAL.  Hence, in an enumeration type ('A', 'B'),
10553    the literal 'A' (VAL == 65), returns 0.  */
10554
10555 static LONGEST
10556 convert_char_literal (struct type *type, LONGEST val)
10557 {
10558   char name[12];
10559   int f;
10560
10561   if (type == NULL)
10562     return val;
10563   type = check_typedef (type);
10564   if (type->code () != TYPE_CODE_ENUM)
10565     return val;
10566
10567   if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10568     xsnprintf (name, sizeof (name), "Q%c", (int) val);
10569   else if (val >= 0 && val < 256)
10570     xsnprintf (name, sizeof (name), "QU%02x", (unsigned) val);
10571   else if (val >= 0 && val < 0x10000)
10572     xsnprintf (name, sizeof (name), "QW%04x", (unsigned) val);
10573   else
10574     xsnprintf (name, sizeof (name), "QWW%08lx", (unsigned long) val);
10575   size_t len = strlen (name);
10576   for (f = 0; f < type->num_fields (); f += 1)
10577     {
10578       /* Check the suffix because an enum constant in a package will
10579          have a name like "pkg__QUxx".  This is safe enough because we
10580          already have the correct type, and because mangling means
10581          there can't be clashes.  */
10582       const char *ename = type->field (f).name ();
10583       size_t elen = strlen (ename);
10584
10585       if (elen >= len && strcmp (name, ename + elen - len) == 0)
10586         return type->field (f).loc_enumval ();
10587     }
10588   return val;
10589 }
10590
10591 value *
10592 ada_char_operation::evaluate (struct type *expect_type,
10593                               struct expression *exp,
10594                               enum noside noside)
10595 {
10596   value *result = long_const_operation::evaluate (expect_type, exp, noside);
10597   if (expect_type != nullptr)
10598     result = ada_value_cast (expect_type, result);
10599   return result;
10600 }
10601
10602 /* See ada-exp.h.  */
10603
10604 operation_up
10605 ada_char_operation::replace (operation_up &&owner,
10606                              struct expression *exp,
10607                              bool deprocedure_p,
10608                              bool parse_completion,
10609                              innermost_block_tracker *tracker,
10610                              struct type *context_type)
10611 {
10612   operation_up result = std::move (owner);
10613
10614   if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10615     {
10616       gdb_assert (result.get () == this);
10617       std::get<0> (m_storage) = context_type;
10618       std::get<1> (m_storage)
10619         = convert_char_literal (context_type, std::get<1> (m_storage));
10620     }
10621
10622   return result;
10623 }
10624
10625 value *
10626 ada_wrapped_operation::evaluate (struct type *expect_type,
10627                                  struct expression *exp,
10628                                  enum noside noside)
10629 {
10630   value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10631   if (noside == EVAL_NORMAL)
10632     result = unwrap_value (result);
10633
10634   /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10635      then we need to perform the conversion manually, because
10636      evaluate_subexp_standard doesn't do it.  This conversion is
10637      necessary in Ada because the different kinds of float/fixed
10638      types in Ada have different representations.
10639
10640      Similarly, we need to perform the conversion from OP_LONG
10641      ourselves.  */
10642   if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10643     result = ada_value_cast (expect_type, result);
10644
10645   return result;
10646 }
10647
10648 value *
10649 ada_string_operation::evaluate (struct type *expect_type,
10650                                 struct expression *exp,
10651                                 enum noside noside)
10652 {
10653   struct type *char_type;
10654   if (expect_type != nullptr && ada_is_string_type (expect_type))
10655     char_type = ada_array_element_type (expect_type, 1);
10656   else
10657     char_type = language_string_char_type (exp->language_defn, exp->gdbarch);
10658
10659   const std::string &str = std::get<0> (m_storage);
10660   const char *encoding;
10661   switch (TYPE_LENGTH (char_type))
10662     {
10663     case 1:
10664       {
10665         /* Simply copy over the data -- this isn't perhaps strictly
10666            correct according to the encodings, but it is gdb's
10667            historical behavior.  */
10668         struct type *stringtype
10669           = lookup_array_range_type (char_type, 1, str.length ());
10670         struct value *val = allocate_value (stringtype);
10671         memcpy (value_contents_raw (val).data (), str.c_str (),
10672                 str.length ());
10673         return val;
10674       }
10675
10676     case 2:
10677       if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10678         encoding = "UTF-16BE";
10679       else
10680         encoding = "UTF-16LE";
10681       break;
10682
10683     case 4:
10684       if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10685         encoding = "UTF-32BE";
10686       else
10687         encoding = "UTF-32LE";
10688       break;
10689
10690     default:
10691       error (_("unexpected character type size %s"),
10692              pulongest (TYPE_LENGTH (char_type)));
10693     }
10694
10695   auto_obstack converted;
10696   convert_between_encodings (host_charset (), encoding,
10697                              (const gdb_byte *) str.c_str (),
10698                              str.length (), 1,
10699                              &converted, translit_none);
10700
10701   struct type *stringtype
10702     = lookup_array_range_type (char_type, 1,
10703                                obstack_object_size (&converted)
10704                                / TYPE_LENGTH (char_type));
10705   struct value *val = allocate_value (stringtype);
10706   memcpy (value_contents_raw (val).data (),
10707           obstack_base (&converted),
10708           obstack_object_size (&converted));
10709   return val;
10710 }
10711
10712 value *
10713 ada_concat_operation::evaluate (struct type *expect_type,
10714                                 struct expression *exp,
10715                                 enum noside noside)
10716 {
10717   /* If one side is a literal, evaluate the other side first so that
10718      the expected type can be set properly.  */
10719   const operation_up &lhs_expr = std::get<0> (m_storage);
10720   const operation_up &rhs_expr = std::get<1> (m_storage);
10721
10722   value *lhs, *rhs;
10723   if (dynamic_cast<ada_string_operation *> (lhs_expr.get ()) != nullptr)
10724     {
10725       rhs = rhs_expr->evaluate (nullptr, exp, noside);
10726       lhs = lhs_expr->evaluate (value_type (rhs), exp, noside);
10727     }
10728   else if (dynamic_cast<ada_char_operation *> (lhs_expr.get ()) != nullptr)
10729     {
10730       rhs = rhs_expr->evaluate (nullptr, exp, noside);
10731       struct type *rhs_type = check_typedef (value_type (rhs));
10732       struct type *elt_type = nullptr;
10733       if (rhs_type->code () == TYPE_CODE_ARRAY)
10734         elt_type = TYPE_TARGET_TYPE (rhs_type);
10735       lhs = lhs_expr->evaluate (elt_type, exp, noside);
10736     }
10737   else if (dynamic_cast<ada_string_operation *> (rhs_expr.get ()) != nullptr)
10738     {
10739       lhs = lhs_expr->evaluate (nullptr, exp, noside);
10740       rhs = rhs_expr->evaluate (value_type (lhs), exp, noside);
10741     }
10742   else if (dynamic_cast<ada_char_operation *> (rhs_expr.get ()) != nullptr)
10743     {
10744       lhs = lhs_expr->evaluate (nullptr, exp, noside);
10745       struct type *lhs_type = check_typedef (value_type (lhs));
10746       struct type *elt_type = nullptr;
10747       if (lhs_type->code () == TYPE_CODE_ARRAY)
10748         elt_type = TYPE_TARGET_TYPE (lhs_type);
10749       rhs = rhs_expr->evaluate (elt_type, exp, noside);
10750     }
10751   else
10752     return concat_operation::evaluate (expect_type, exp, noside);
10753
10754   return value_concat (lhs, rhs);
10755 }
10756
10757 value *
10758 ada_qual_operation::evaluate (struct type *expect_type,
10759                               struct expression *exp,
10760                               enum noside noside)
10761 {
10762   struct type *type = std::get<1> (m_storage);
10763   return std::get<0> (m_storage)->evaluate (type, exp, noside);
10764 }
10765
10766 value *
10767 ada_ternop_range_operation::evaluate (struct type *expect_type,
10768                                       struct expression *exp,
10769                                       enum noside noside)
10770 {
10771   value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10772   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10773   value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10774   return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10775 }
10776
10777 value *
10778 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10779                                       struct expression *exp,
10780                                       enum noside noside)
10781 {
10782   value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10783   value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10784
10785   auto do_op = [=] (LONGEST x, LONGEST y)
10786     {
10787       if (std::get<0> (m_storage) == BINOP_ADD)
10788         return x + y;
10789       return x - y;
10790     };
10791
10792   if (value_type (arg1)->code () == TYPE_CODE_PTR)
10793     return (value_from_longest
10794             (value_type (arg1),
10795              do_op (value_as_long (arg1), value_as_long (arg2))));
10796   if (value_type (arg2)->code () == TYPE_CODE_PTR)
10797     return (value_from_longest
10798             (value_type (arg2),
10799              do_op (value_as_long (arg1), value_as_long (arg2))));
10800   /* Preserve the original type for use by the range case below.
10801      We cannot cast the result to a reference type, so if ARG1 is
10802      a reference type, find its underlying type.  */
10803   struct type *type = value_type (arg1);
10804   while (type->code () == TYPE_CODE_REF)
10805     type = TYPE_TARGET_TYPE (type);
10806   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10807   arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10808   /* We need to special-case the result with a range.
10809      This is done for the benefit of "ptype".  gdb's Ada support
10810      historically used the LHS to set the result type here, so
10811      preserve this behavior.  */
10812   if (type->code () == TYPE_CODE_RANGE)
10813     arg1 = value_cast (type, arg1);
10814   return arg1;
10815 }
10816
10817 value *
10818 ada_unop_atr_operation::evaluate (struct type *expect_type,
10819                                   struct expression *exp,
10820                                   enum noside noside)
10821 {
10822   struct type *type_arg = nullptr;
10823   value *val = nullptr;
10824
10825   if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10826     {
10827       value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10828                                                       EVAL_AVOID_SIDE_EFFECTS);
10829       type_arg = value_type (tem);
10830     }
10831   else
10832     val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10833
10834   return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10835                        val, type_arg, std::get<2> (m_storage));
10836 }
10837
10838 value *
10839 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10840                                                  struct expression *exp,
10841                                                  enum noside noside)
10842 {
10843   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10844     return value_zero (expect_type, not_lval);
10845
10846   const bound_minimal_symbol &b = std::get<0> (m_storage);
10847   value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10848
10849   val = ada_value_cast (expect_type, val);
10850
10851   /* Follow the Ada language semantics that do not allow taking
10852      an address of the result of a cast (view conversion in Ada).  */
10853   if (VALUE_LVAL (val) == lval_memory)
10854     {
10855       if (value_lazy (val))
10856         value_fetch_lazy (val);
10857       VALUE_LVAL (val) = not_lval;
10858     }
10859   return val;
10860 }
10861
10862 value *
10863 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10864                                             struct expression *exp,
10865                                             enum noside noside)
10866 {
10867   value *val = evaluate_var_value (noside,
10868                                    std::get<0> (m_storage).block,
10869                                    std::get<0> (m_storage).symbol);
10870
10871   val = ada_value_cast (expect_type, val);
10872
10873   /* Follow the Ada language semantics that do not allow taking
10874      an address of the result of a cast (view conversion in Ada).  */
10875   if (VALUE_LVAL (val) == lval_memory)
10876     {
10877       if (value_lazy (val))
10878         value_fetch_lazy (val);
10879       VALUE_LVAL (val) = not_lval;
10880     }
10881   return val;
10882 }
10883
10884 value *
10885 ada_var_value_operation::evaluate (struct type *expect_type,
10886                                    struct expression *exp,
10887                                    enum noside noside)
10888 {
10889   symbol *sym = std::get<0> (m_storage).symbol;
10890
10891   if (sym->domain () == UNDEF_DOMAIN)
10892     /* Only encountered when an unresolved symbol occurs in a
10893        context other than a function call, in which case, it is
10894        invalid.  */
10895     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10896            sym->print_name ());
10897
10898   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10899     {
10900       struct type *type = static_unwrap_type (sym->type ());
10901       /* Check to see if this is a tagged type.  We also need to handle
10902          the case where the type is a reference to a tagged type, but
10903          we have to be careful to exclude pointers to tagged types.
10904          The latter should be shown as usual (as a pointer), whereas
10905          a reference should mostly be transparent to the user.  */
10906       if (ada_is_tagged_type (type, 0)
10907           || (type->code () == TYPE_CODE_REF
10908               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10909         {
10910           /* Tagged types are a little special in the fact that the real
10911              type is dynamic and can only be determined by inspecting the
10912              object's tag.  This means that we need to get the object's
10913              value first (EVAL_NORMAL) and then extract the actual object
10914              type from its tag.
10915
10916              Note that we cannot skip the final step where we extract
10917              the object type from its tag, because the EVAL_NORMAL phase
10918              results in dynamic components being resolved into fixed ones.
10919              This can cause problems when trying to print the type
10920              description of tagged types whose parent has a dynamic size:
10921              We use the type name of the "_parent" component in order
10922              to print the name of the ancestor type in the type description.
10923              If that component had a dynamic size, the resolution into
10924              a fixed type would result in the loss of that type name,
10925              thus preventing us from printing the name of the ancestor
10926              type in the type description.  */
10927           value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10928
10929           if (type->code () != TYPE_CODE_REF)
10930             {
10931               struct type *actual_type;
10932
10933               actual_type = type_from_tag (ada_value_tag (arg1));
10934               if (actual_type == NULL)
10935                 /* If, for some reason, we were unable to determine
10936                    the actual type from the tag, then use the static
10937                    approximation that we just computed as a fallback.
10938                    This can happen if the debugging information is
10939                    incomplete, for instance.  */
10940                 actual_type = type;
10941               return value_zero (actual_type, not_lval);
10942             }
10943           else
10944             {
10945               /* In the case of a ref, ada_coerce_ref takes care
10946                  of determining the actual type.  But the evaluation
10947                  should return a ref as it should be valid to ask
10948                  for its address; so rebuild a ref after coerce.  */
10949               arg1 = ada_coerce_ref (arg1);
10950               return value_ref (arg1, TYPE_CODE_REF);
10951             }
10952         }
10953
10954       /* Records and unions for which GNAT encodings have been
10955          generated need to be statically fixed as well.
10956          Otherwise, non-static fixing produces a type where
10957          all dynamic properties are removed, which prevents "ptype"
10958          from being able to completely describe the type.
10959          For instance, a case statement in a variant record would be
10960          replaced by the relevant components based on the actual
10961          value of the discriminants.  */
10962       if ((type->code () == TYPE_CODE_STRUCT
10963            && dynamic_template_type (type) != NULL)
10964           || (type->code () == TYPE_CODE_UNION
10965               && ada_find_parallel_type (type, "___XVU") != NULL))
10966         return value_zero (to_static_fixed_type (type), not_lval);
10967     }
10968
10969   value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10970   return ada_to_fixed_value (arg1);
10971 }
10972
10973 bool
10974 ada_var_value_operation::resolve (struct expression *exp,
10975                                   bool deprocedure_p,
10976                                   bool parse_completion,
10977                                   innermost_block_tracker *tracker,
10978                                   struct type *context_type)
10979 {
10980   symbol *sym = std::get<0> (m_storage).symbol;
10981   if (sym->domain () == UNDEF_DOMAIN)
10982     {
10983       block_symbol resolved
10984         = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10985                                 context_type, parse_completion,
10986                                 deprocedure_p, tracker);
10987       std::get<0> (m_storage) = resolved;
10988     }
10989
10990   if (deprocedure_p
10991       && (std::get<0> (m_storage).symbol->type ()->code ()
10992           == TYPE_CODE_FUNC))
10993     return true;
10994
10995   return false;
10996 }
10997
10998 value *
10999 ada_atr_val_operation::evaluate (struct type *expect_type,
11000                                  struct expression *exp,
11001                                  enum noside noside)
11002 {
11003   value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
11004   return ada_val_atr (noside, std::get<0> (m_storage), arg);
11005 }
11006
11007 value *
11008 ada_unop_ind_operation::evaluate (struct type *expect_type,
11009                                   struct expression *exp,
11010                                   enum noside noside)
11011 {
11012   value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
11013
11014   struct type *type = ada_check_typedef (value_type (arg1));
11015   if (noside == EVAL_AVOID_SIDE_EFFECTS)
11016     {
11017       if (ada_is_array_descriptor_type (type))
11018         /* GDB allows dereferencing GNAT array descriptors.  */
11019         {
11020           struct type *arrType = ada_type_of_array (arg1, 0);
11021
11022           if (arrType == NULL)
11023             error (_("Attempt to dereference null array pointer."));
11024           return value_at_lazy (arrType, 0);
11025         }
11026       else if (type->code () == TYPE_CODE_PTR
11027                || type->code () == TYPE_CODE_REF
11028                /* In C you can dereference an array to get the 1st elt.  */
11029                || type->code () == TYPE_CODE_ARRAY)
11030         {
11031           /* As mentioned in the OP_VAR_VALUE case, tagged types can
11032              only be determined by inspecting the object's tag.
11033              This means that we need to evaluate completely the
11034              expression in order to get its type.  */
11035
11036           if ((type->code () == TYPE_CODE_REF
11037                || type->code () == TYPE_CODE_PTR)
11038               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11039             {
11040               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11041                                                         EVAL_NORMAL);
11042               type = value_type (ada_value_ind (arg1));
11043             }
11044           else
11045             {
11046               type = to_static_fixed_type
11047                 (ada_aligned_type
11048                  (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11049             }
11050           return value_zero (type, lval_memory);
11051         }
11052       else if (type->code () == TYPE_CODE_INT)
11053         {
11054           /* GDB allows dereferencing an int.  */
11055           if (expect_type == NULL)
11056             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11057                                lval_memory);
11058           else
11059             {
11060               expect_type =
11061                 to_static_fixed_type (ada_aligned_type (expect_type));
11062               return value_zero (expect_type, lval_memory);
11063             }
11064         }
11065       else
11066         error (_("Attempt to take contents of a non-pointer value."));
11067     }
11068   arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
11069   type = ada_check_typedef (value_type (arg1));
11070
11071   if (type->code () == TYPE_CODE_INT)
11072     /* GDB allows dereferencing an int.  If we were given
11073        the expect_type, then use that as the target type.
11074        Otherwise, assume that the target type is an int.  */
11075     {
11076       if (expect_type != NULL)
11077         return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11078                                           arg1));
11079       else
11080         return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11081                               (CORE_ADDR) value_as_address (arg1));
11082     }
11083
11084   if (ada_is_array_descriptor_type (type))
11085     /* GDB allows dereferencing GNAT array descriptors.  */
11086     return ada_coerce_to_simple_array (arg1);
11087   else
11088     return ada_value_ind (arg1);
11089 }
11090
11091 value *
11092 ada_structop_operation::evaluate (struct type *expect_type,
11093                                   struct expression *exp,
11094                                   enum noside noside)
11095 {
11096   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
11097   const char *str = std::get<1> (m_storage).c_str ();
11098   if (noside == EVAL_AVOID_SIDE_EFFECTS)
11099     {
11100       struct type *type;
11101       struct type *type1 = value_type (arg1);
11102
11103       if (ada_is_tagged_type (type1, 1))
11104         {
11105           type = ada_lookup_struct_elt_type (type1, str, 1, 1);
11106
11107           /* If the field is not found, check if it exists in the
11108              extension of this object's type. This means that we
11109              need to evaluate completely the expression.  */
11110
11111           if (type == NULL)
11112             {
11113               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11114                                                         EVAL_NORMAL);
11115               arg1 = ada_value_struct_elt (arg1, str, 0);
11116               arg1 = unwrap_value (arg1);
11117               type = value_type (ada_to_fixed_value (arg1));
11118             }
11119         }
11120       else
11121         type = ada_lookup_struct_elt_type (type1, str, 1, 0);
11122
11123       return value_zero (ada_aligned_type (type), lval_memory);
11124     }
11125   else
11126     {
11127       arg1 = ada_value_struct_elt (arg1, str, 0);
11128       arg1 = unwrap_value (arg1);
11129       return ada_to_fixed_value (arg1);
11130     }
11131 }
11132
11133 value *
11134 ada_funcall_operation::evaluate (struct type *expect_type,
11135                                  struct expression *exp,
11136                                  enum noside noside)
11137 {
11138   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11139   int nargs = args_up.size ();
11140   std::vector<value *> argvec (nargs);
11141   operation_up &callee_op = std::get<0> (m_storage);
11142
11143   ada_var_value_operation *avv
11144     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11145   if (avv != nullptr
11146       && avv->get_symbol ()->domain () == UNDEF_DOMAIN)
11147     error (_("Unexpected unresolved symbol, %s, during evaluation"),
11148            avv->get_symbol ()->print_name ());
11149
11150   value *callee = callee_op->evaluate (nullptr, exp, noside);
11151   for (int i = 0; i < args_up.size (); ++i)
11152     argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
11153
11154   if (ada_is_constrained_packed_array_type
11155       (desc_base_type (value_type (callee))))
11156     callee = ada_coerce_to_simple_array (callee);
11157   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11158            && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
11159     /* This is a packed array that has already been fixed, and
11160        therefore already coerced to a simple array.  Nothing further
11161        to do.  */
11162     ;
11163   else if (value_type (callee)->code () == TYPE_CODE_REF)
11164     {
11165       /* Make sure we dereference references so that all the code below
11166          feels like it's really handling the referenced value.  Wrapping
11167          types (for alignment) may be there, so make sure we strip them as
11168          well.  */
11169       callee = ada_to_fixed_value (coerce_ref (callee));
11170     }
11171   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11172            && VALUE_LVAL (callee) == lval_memory)
11173     callee = value_addr (callee);
11174
11175   struct type *type = ada_check_typedef (value_type (callee));
11176
11177   /* Ada allows us to implicitly dereference arrays when subscripting
11178      them.  So, if this is an array typedef (encoding use for array
11179      access types encoded as fat pointers), strip it now.  */
11180   if (type->code () == TYPE_CODE_TYPEDEF)
11181     type = ada_typedef_target_type (type);
11182
11183   if (type->code () == TYPE_CODE_PTR)
11184     {
11185       switch (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ())
11186         {
11187         case TYPE_CODE_FUNC:
11188           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
11189           break;
11190         case TYPE_CODE_ARRAY:
11191           break;
11192         case TYPE_CODE_STRUCT:
11193           if (noside != EVAL_AVOID_SIDE_EFFECTS)
11194             callee = ada_value_ind (callee);
11195           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
11196           break;
11197         default:
11198           error (_("cannot subscript or call something of type `%s'"),
11199                  ada_type_name (value_type (callee)));
11200           break;
11201         }
11202     }
11203
11204   switch (type->code ())
11205     {
11206     case TYPE_CODE_FUNC:
11207       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11208         {
11209           if (TYPE_TARGET_TYPE (type) == NULL)
11210             error_call_unknown_return_type (NULL);
11211           return allocate_value (TYPE_TARGET_TYPE (type));
11212         }
11213       return call_function_by_hand (callee, NULL, argvec);
11214     case TYPE_CODE_INTERNAL_FUNCTION:
11215       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11216         /* We don't know anything about what the internal
11217            function might return, but we have to return
11218            something.  */
11219         return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11220                            not_lval);
11221       else
11222         return call_internal_function (exp->gdbarch, exp->language_defn,
11223                                        callee, nargs,
11224                                        argvec.data ());
11225
11226     case TYPE_CODE_STRUCT:
11227       {
11228         int arity;
11229
11230         arity = ada_array_arity (type);
11231         type = ada_array_element_type (type, nargs);
11232         if (type == NULL)
11233           error (_("cannot subscript or call a record"));
11234         if (arity != nargs)
11235           error (_("wrong number of subscripts; expecting %d"), arity);
11236         if (noside == EVAL_AVOID_SIDE_EFFECTS)
11237           return value_zero (ada_aligned_type (type), lval_memory);
11238         return
11239           unwrap_value (ada_value_subscript
11240                         (callee, nargs, argvec.data ()));
11241       }
11242     case TYPE_CODE_ARRAY:
11243       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11244         {
11245           type = ada_array_element_type (type, nargs);
11246           if (type == NULL)
11247             error (_("element type of array unknown"));
11248           else
11249             return value_zero (ada_aligned_type (type), lval_memory);
11250         }
11251       return
11252         unwrap_value (ada_value_subscript
11253                       (ada_coerce_to_simple_array (callee),
11254                        nargs, argvec.data ()));
11255     case TYPE_CODE_PTR:     /* Pointer to array */
11256       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11257         {
11258           type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
11259           type = ada_array_element_type (type, nargs);
11260           if (type == NULL)
11261             error (_("element type of array unknown"));
11262           else
11263             return value_zero (ada_aligned_type (type), lval_memory);
11264         }
11265       return
11266         unwrap_value (ada_value_ptr_subscript (callee, nargs,
11267                                                argvec.data ()));
11268
11269     default:
11270       error (_("Attempt to index or call something other than an "
11271                "array or function"));
11272     }
11273 }
11274
11275 bool
11276 ada_funcall_operation::resolve (struct expression *exp,
11277                                 bool deprocedure_p,
11278                                 bool parse_completion,
11279                                 innermost_block_tracker *tracker,
11280                                 struct type *context_type)
11281 {
11282   operation_up &callee_op = std::get<0> (m_storage);
11283
11284   ada_var_value_operation *avv
11285     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11286   if (avv == nullptr)
11287     return false;
11288
11289   symbol *sym = avv->get_symbol ();
11290   if (sym->domain () != UNDEF_DOMAIN)
11291     return false;
11292
11293   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11294   int nargs = args_up.size ();
11295   std::vector<value *> argvec (nargs);
11296
11297   for (int i = 0; i < args_up.size (); ++i)
11298     argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
11299
11300   const block *block = avv->get_block ();
11301   block_symbol resolved
11302     = ada_resolve_funcall (sym, block,
11303                            context_type, parse_completion,
11304                            nargs, argvec.data (),
11305                            tracker);
11306
11307   std::get<0> (m_storage)
11308     = make_operation<ada_var_value_operation> (resolved);
11309   return false;
11310 }
11311
11312 bool
11313 ada_ternop_slice_operation::resolve (struct expression *exp,
11314                                      bool deprocedure_p,
11315                                      bool parse_completion,
11316                                      innermost_block_tracker *tracker,
11317                                      struct type *context_type)
11318 {
11319   /* Historically this check was done during resolution, so we
11320      continue that here.  */
11321   value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
11322                                                 EVAL_AVOID_SIDE_EFFECTS);
11323   if (ada_is_any_packed_array_type (value_type (v)))
11324     error (_("cannot slice a packed array"));
11325   return false;
11326 }
11327
11328 }
11329
11330 \f
11331
11332 /* Return non-zero iff TYPE represents a System.Address type.  */
11333
11334 int
11335 ada_is_system_address_type (struct type *type)
11336 {
11337   return (type->name () && strcmp (type->name (), "system__address") == 0);
11338 }
11339
11340 \f
11341
11342                                 /* Range types */
11343
11344 /* Scan STR beginning at position K for a discriminant name, and
11345    return the value of that discriminant field of DVAL in *PX.  If
11346    PNEW_K is not null, put the position of the character beyond the
11347    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
11348    not alter *PX and *PNEW_K if unsuccessful.  */
11349
11350 static int
11351 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11352                     int *pnew_k)
11353 {
11354   static std::string storage;
11355   const char *pstart, *pend, *bound;
11356   struct value *bound_val;
11357
11358   if (dval == NULL || str == NULL || str[k] == '\0')
11359     return 0;
11360
11361   pstart = str + k;
11362   pend = strstr (pstart, "__");
11363   if (pend == NULL)
11364     {
11365       bound = pstart;
11366       k += strlen (bound);
11367     }
11368   else
11369     {
11370       int len = pend - pstart;
11371
11372       /* Strip __ and beyond.  */
11373       storage = std::string (pstart, len);
11374       bound = storage.c_str ();
11375       k = pend - str;
11376     }
11377
11378   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11379   if (bound_val == NULL)
11380     return 0;
11381
11382   *px = value_as_long (bound_val);
11383   if (pnew_k != NULL)
11384     *pnew_k = k;
11385   return 1;
11386 }
11387
11388 /* Value of variable named NAME.  Only exact matches are considered.
11389    If no such variable found, then if ERR_MSG is null, returns 0, and
11390    otherwise causes an error with message ERR_MSG.  */
11391
11392 static struct value *
11393 get_var_value (const char *name, const char *err_msg)
11394 {
11395   std::string quoted_name = add_angle_brackets (name);
11396
11397   lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
11398
11399   std::vector<struct block_symbol> syms
11400     = ada_lookup_symbol_list_worker (lookup_name,
11401                                      get_selected_block (0),
11402                                      VAR_DOMAIN, 1);
11403
11404   if (syms.size () != 1)
11405     {
11406       if (err_msg == NULL)
11407         return 0;
11408       else
11409         error (("%s"), err_msg);
11410     }
11411
11412   return value_of_variable (syms[0].symbol, syms[0].block);
11413 }
11414
11415 /* Value of integer variable named NAME in the current environment.
11416    If no such variable is found, returns false.  Otherwise, sets VALUE
11417    to the variable's value and returns true.  */
11418
11419 bool
11420 get_int_var_value (const char *name, LONGEST &value)
11421 {
11422   struct value *var_val = get_var_value (name, 0);
11423
11424   if (var_val == 0)
11425     return false;
11426
11427   value = value_as_long (var_val);
11428   return true;
11429 }
11430
11431
11432 /* Return a range type whose base type is that of the range type named
11433    NAME in the current environment, and whose bounds are calculated
11434    from NAME according to the GNAT range encoding conventions.
11435    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
11436    corresponding range type from debug information; fall back to using it
11437    if symbol lookup fails.  If a new type must be created, allocate it
11438    like ORIG_TYPE was.  The bounds information, in general, is encoded
11439    in NAME, the base type given in the named range type.  */
11440
11441 static struct type *
11442 to_fixed_range_type (struct type *raw_type, struct value *dval)
11443 {
11444   const char *name;
11445   struct type *base_type;
11446   const char *subtype_info;
11447
11448   gdb_assert (raw_type != NULL);
11449   gdb_assert (raw_type->name () != NULL);
11450
11451   if (raw_type->code () == TYPE_CODE_RANGE)
11452     base_type = TYPE_TARGET_TYPE (raw_type);
11453   else
11454     base_type = raw_type;
11455
11456   name = raw_type->name ();
11457   subtype_info = strstr (name, "___XD");
11458   if (subtype_info == NULL)
11459     {
11460       LONGEST L = ada_discrete_type_low_bound (raw_type);
11461       LONGEST U = ada_discrete_type_high_bound (raw_type);
11462
11463       if (L < INT_MIN || U > INT_MAX)
11464         return raw_type;
11465       else
11466         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11467                                          L, U);
11468     }
11469   else
11470     {
11471       int prefix_len = subtype_info - name;
11472       LONGEST L, U;
11473       struct type *type;
11474       const char *bounds_str;
11475       int n;
11476
11477       subtype_info += 5;
11478       bounds_str = strchr (subtype_info, '_');
11479       n = 1;
11480
11481       if (*subtype_info == 'L')
11482         {
11483           if (!ada_scan_number (bounds_str, n, &L, &n)
11484               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11485             return raw_type;
11486           if (bounds_str[n] == '_')
11487             n += 2;
11488           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
11489             n += 1;
11490           subtype_info += 1;
11491         }
11492       else
11493         {
11494           std::string name_buf = std::string (name, prefix_len) + "___L";
11495           if (!get_int_var_value (name_buf.c_str (), L))
11496             {
11497               lim_warning (_("Unknown lower bound, using 1."));
11498               L = 1;
11499             }
11500         }
11501
11502       if (*subtype_info == 'U')
11503         {
11504           if (!ada_scan_number (bounds_str, n, &U, &n)
11505               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11506             return raw_type;
11507         }
11508       else
11509         {
11510           std::string name_buf = std::string (name, prefix_len) + "___U";
11511           if (!get_int_var_value (name_buf.c_str (), U))
11512             {
11513               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11514               U = L;
11515             }
11516         }
11517
11518       type = create_static_range_type (alloc_type_copy (raw_type),
11519                                        base_type, L, U);
11520       /* create_static_range_type alters the resulting type's length
11521          to match the size of the base_type, which is not what we want.
11522          Set it back to the original range type's length.  */
11523       TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11524       type->set_name (name);
11525       return type;
11526     }
11527 }
11528
11529 /* True iff NAME is the name of a range type.  */
11530
11531 int
11532 ada_is_range_type_name (const char *name)
11533 {
11534   return (name != NULL && strstr (name, "___XD"));
11535 }
11536 \f
11537
11538                                 /* Modular types */
11539
11540 /* True iff TYPE is an Ada modular type.  */
11541
11542 int
11543 ada_is_modular_type (struct type *type)
11544 {
11545   struct type *subranged_type = get_base_type (type);
11546
11547   return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11548           && subranged_type->code () == TYPE_CODE_INT
11549           && subranged_type->is_unsigned ());
11550 }
11551
11552 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
11553
11554 ULONGEST
11555 ada_modulus (struct type *type)
11556 {
11557   const dynamic_prop &high = type->bounds ()->high;
11558
11559   if (high.kind () == PROP_CONST)
11560     return (ULONGEST) high.const_val () + 1;
11561
11562   /* If TYPE is unresolved, the high bound might be a location list.  Return
11563      0, for lack of a better value to return.  */
11564   return 0;
11565 }
11566 \f
11567
11568 /* Ada exception catchpoint support:
11569    ---------------------------------
11570
11571    We support 3 kinds of exception catchpoints:
11572      . catchpoints on Ada exceptions
11573      . catchpoints on unhandled Ada exceptions
11574      . catchpoints on failed assertions
11575
11576    Exceptions raised during failed assertions, or unhandled exceptions
11577    could perfectly be caught with the general catchpoint on Ada exceptions.
11578    However, we can easily differentiate these two special cases, and having
11579    the option to distinguish these two cases from the rest can be useful
11580    to zero-in on certain situations.
11581
11582    Exception catchpoints are a specialized form of breakpoint,
11583    since they rely on inserting breakpoints inside known routines
11584    of the GNAT runtime.  The implementation therefore uses a standard
11585    breakpoint structure of the BP_BREAKPOINT type, but with its own set
11586    of breakpoint_ops.
11587
11588    Support in the runtime for exception catchpoints have been changed
11589    a few times already, and these changes affect the implementation
11590    of these catchpoints.  In order to be able to support several
11591    variants of the runtime, we use a sniffer that will determine
11592    the runtime variant used by the program being debugged.  */
11593
11594 /* Ada's standard exceptions.
11595
11596    The Ada 83 standard also defined Numeric_Error.  But there so many
11597    situations where it was unclear from the Ada 83 Reference Manual
11598    (RM) whether Constraint_Error or Numeric_Error should be raised,
11599    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11600    Interpretation saying that anytime the RM says that Numeric_Error
11601    should be raised, the implementation may raise Constraint_Error.
11602    Ada 95 went one step further and pretty much removed Numeric_Error
11603    from the list of standard exceptions (it made it a renaming of
11604    Constraint_Error, to help preserve compatibility when compiling
11605    an Ada83 compiler). As such, we do not include Numeric_Error from
11606    this list of standard exceptions.  */
11607
11608 static const char * const standard_exc[] = {
11609   "constraint_error",
11610   "program_error",
11611   "storage_error",
11612   "tasking_error"
11613 };
11614
11615 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11616
11617 /* A structure that describes how to support exception catchpoints
11618    for a given executable.  */
11619
11620 struct exception_support_info
11621 {
11622    /* The name of the symbol to break on in order to insert
11623       a catchpoint on exceptions.  */
11624    const char *catch_exception_sym;
11625
11626    /* The name of the symbol to break on in order to insert
11627       a catchpoint on unhandled exceptions.  */
11628    const char *catch_exception_unhandled_sym;
11629
11630    /* The name of the symbol to break on in order to insert
11631       a catchpoint on failed assertions.  */
11632    const char *catch_assert_sym;
11633
11634    /* The name of the symbol to break on in order to insert
11635       a catchpoint on exception handling.  */
11636    const char *catch_handlers_sym;
11637
11638    /* Assuming that the inferior just triggered an unhandled exception
11639       catchpoint, this function is responsible for returning the address
11640       in inferior memory where the name of that exception is stored.
11641       Return zero if the address could not be computed.  */
11642    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11643 };
11644
11645 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11646 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11647
11648 /* The following exception support info structure describes how to
11649    implement exception catchpoints with the latest version of the
11650    Ada runtime (as of 2019-08-??).  */
11651
11652 static const struct exception_support_info default_exception_support_info =
11653 {
11654   "__gnat_debug_raise_exception", /* catch_exception_sym */
11655   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11656   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11657   "__gnat_begin_handler_v1", /* catch_handlers_sym */
11658   ada_unhandled_exception_name_addr
11659 };
11660
11661 /* The following exception support info structure describes how to
11662    implement exception catchpoints with an earlier version of the
11663    Ada runtime (as of 2007-03-06) using v0 of the EH ABI.  */
11664
11665 static const struct exception_support_info exception_support_info_v0 =
11666 {
11667   "__gnat_debug_raise_exception", /* catch_exception_sym */
11668   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11669   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11670   "__gnat_begin_handler", /* catch_handlers_sym */
11671   ada_unhandled_exception_name_addr
11672 };
11673
11674 /* The following exception support info structure describes how to
11675    implement exception catchpoints with a slightly older version
11676    of the Ada runtime.  */
11677
11678 static const struct exception_support_info exception_support_info_fallback =
11679 {
11680   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11681   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11682   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
11683   "__gnat_begin_handler", /* catch_handlers_sym */
11684   ada_unhandled_exception_name_addr_from_raise
11685 };
11686
11687 /* Return nonzero if we can detect the exception support routines
11688    described in EINFO.
11689
11690    This function errors out if an abnormal situation is detected
11691    (for instance, if we find the exception support routines, but
11692    that support is found to be incomplete).  */
11693
11694 static int
11695 ada_has_this_exception_support (const struct exception_support_info *einfo)
11696 {
11697   struct symbol *sym;
11698
11699   /* The symbol we're looking up is provided by a unit in the GNAT runtime
11700      that should be compiled with debugging information.  As a result, we
11701      expect to find that symbol in the symtabs.  */
11702
11703   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11704   if (sym == NULL)
11705     {
11706       /* Perhaps we did not find our symbol because the Ada runtime was
11707          compiled without debugging info, or simply stripped of it.
11708          It happens on some GNU/Linux distributions for instance, where
11709          users have to install a separate debug package in order to get
11710          the runtime's debugging info.  In that situation, let the user
11711          know why we cannot insert an Ada exception catchpoint.
11712
11713          Note: Just for the purpose of inserting our Ada exception
11714          catchpoint, we could rely purely on the associated minimal symbol.
11715          But we would be operating in degraded mode anyway, since we are
11716          still lacking the debugging info needed later on to extract
11717          the name of the exception being raised (this name is printed in
11718          the catchpoint message, and is also used when trying to catch
11719          a specific exception).  We do not handle this case for now.  */
11720       struct bound_minimal_symbol msym
11721         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11722
11723       if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11724         error (_("Your Ada runtime appears to be missing some debugging "
11725                  "information.\nCannot insert Ada exception catchpoint "
11726                  "in this configuration."));
11727
11728       return 0;
11729     }
11730
11731   /* Make sure that the symbol we found corresponds to a function.  */
11732
11733   if (sym->aclass () != LOC_BLOCK)
11734     {
11735       error (_("Symbol \"%s\" is not a function (class = %d)"),
11736              sym->linkage_name (), sym->aclass ());
11737       return 0;
11738     }
11739
11740   sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11741   if (sym == NULL)
11742     {
11743       struct bound_minimal_symbol msym
11744         = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11745
11746       if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11747         error (_("Your Ada runtime appears to be missing some debugging "
11748                  "information.\nCannot insert Ada exception catchpoint "
11749                  "in this configuration."));
11750
11751       return 0;
11752     }
11753
11754   /* Make sure that the symbol we found corresponds to a function.  */
11755
11756   if (sym->aclass () != LOC_BLOCK)
11757     {
11758       error (_("Symbol \"%s\" is not a function (class = %d)"),
11759              sym->linkage_name (), sym->aclass ());
11760       return 0;
11761     }
11762
11763   return 1;
11764 }
11765
11766 /* Inspect the Ada runtime and determine which exception info structure
11767    should be used to provide support for exception catchpoints.
11768
11769    This function will always set the per-inferior exception_info,
11770    or raise an error.  */
11771
11772 static void
11773 ada_exception_support_info_sniffer (void)
11774 {
11775   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11776
11777   /* If the exception info is already known, then no need to recompute it.  */
11778   if (data->exception_info != NULL)
11779     return;
11780
11781   /* Check the latest (default) exception support info.  */
11782   if (ada_has_this_exception_support (&default_exception_support_info))
11783     {
11784       data->exception_info = &default_exception_support_info;
11785       return;
11786     }
11787
11788   /* Try the v0 exception suport info.  */
11789   if (ada_has_this_exception_support (&exception_support_info_v0))
11790     {
11791       data->exception_info = &exception_support_info_v0;
11792       return;
11793     }
11794
11795   /* Try our fallback exception suport info.  */
11796   if (ada_has_this_exception_support (&exception_support_info_fallback))
11797     {
11798       data->exception_info = &exception_support_info_fallback;
11799       return;
11800     }
11801
11802   /* Sometimes, it is normal for us to not be able to find the routine
11803      we are looking for.  This happens when the program is linked with
11804      the shared version of the GNAT runtime, and the program has not been
11805      started yet.  Inform the user of these two possible causes if
11806      applicable.  */
11807
11808   if (ada_update_initial_language (language_unknown) != language_ada)
11809     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
11810
11811   /* If the symbol does not exist, then check that the program is
11812      already started, to make sure that shared libraries have been
11813      loaded.  If it is not started, this may mean that the symbol is
11814      in a shared library.  */
11815
11816   if (inferior_ptid.pid () == 0)
11817     error (_("Unable to insert catchpoint. Try to start the program first."));
11818
11819   /* At this point, we know that we are debugging an Ada program and
11820      that the inferior has been started, but we still are not able to
11821      find the run-time symbols.  That can mean that we are in
11822      configurable run time mode, or that a-except as been optimized
11823      out by the linker...  In any case, at this point it is not worth
11824      supporting this feature.  */
11825
11826   error (_("Cannot insert Ada exception catchpoints in this configuration."));
11827 }
11828
11829 /* True iff FRAME is very likely to be that of a function that is
11830    part of the runtime system.  This is all very heuristic, but is
11831    intended to be used as advice as to what frames are uninteresting
11832    to most users.  */
11833
11834 static int
11835 is_known_support_routine (struct frame_info *frame)
11836 {
11837   enum language func_lang;
11838   int i;
11839   const char *fullname;
11840
11841   /* If this code does not have any debugging information (no symtab),
11842      This cannot be any user code.  */
11843
11844   symtab_and_line sal = find_frame_sal (frame);
11845   if (sal.symtab == NULL)
11846     return 1;
11847
11848   /* If there is a symtab, but the associated source file cannot be
11849      located, then assume this is not user code:  Selecting a frame
11850      for which we cannot display the code would not be very helpful
11851      for the user.  This should also take care of case such as VxWorks
11852      where the kernel has some debugging info provided for a few units.  */
11853
11854   fullname = symtab_to_fullname (sal.symtab);
11855   if (access (fullname, R_OK) != 0)
11856     return 1;
11857
11858   /* Check the unit filename against the Ada runtime file naming.
11859      We also check the name of the objfile against the name of some
11860      known system libraries that sometimes come with debugging info
11861      too.  */
11862
11863   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11864     {
11865       re_comp (known_runtime_file_name_patterns[i]);
11866       if (re_exec (lbasename (sal.symtab->filename)))
11867         return 1;
11868       if (sal.symtab->compunit ()->objfile () != NULL
11869           && re_exec (objfile_name (sal.symtab->compunit ()->objfile ())))
11870         return 1;
11871     }
11872
11873   /* Check whether the function is a GNAT-generated entity.  */
11874
11875   gdb::unique_xmalloc_ptr<char> func_name
11876     = find_frame_funname (frame, &func_lang, NULL);
11877   if (func_name == NULL)
11878     return 1;
11879
11880   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11881     {
11882       re_comp (known_auxiliary_function_name_patterns[i]);
11883       if (re_exec (func_name.get ()))
11884         return 1;
11885     }
11886
11887   return 0;
11888 }
11889
11890 /* Find the first frame that contains debugging information and that is not
11891    part of the Ada run-time, starting from FI and moving upward.  */
11892
11893 void
11894 ada_find_printable_frame (struct frame_info *fi)
11895 {
11896   for (; fi != NULL; fi = get_prev_frame (fi))
11897     {
11898       if (!is_known_support_routine (fi))
11899         {
11900           select_frame (fi);
11901           break;
11902         }
11903     }
11904
11905 }
11906
11907 /* Assuming that the inferior just triggered an unhandled exception
11908    catchpoint, return the address in inferior memory where the name
11909    of the exception is stored.
11910    
11911    Return zero if the address could not be computed.  */
11912
11913 static CORE_ADDR
11914 ada_unhandled_exception_name_addr (void)
11915 {
11916   return parse_and_eval_address ("e.full_name");
11917 }
11918
11919 /* Same as ada_unhandled_exception_name_addr, except that this function
11920    should be used when the inferior uses an older version of the runtime,
11921    where the exception name needs to be extracted from a specific frame
11922    several frames up in the callstack.  */
11923
11924 static CORE_ADDR
11925 ada_unhandled_exception_name_addr_from_raise (void)
11926 {
11927   int frame_level;
11928   struct frame_info *fi;
11929   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11930
11931   /* To determine the name of this exception, we need to select
11932      the frame corresponding to RAISE_SYM_NAME.  This frame is
11933      at least 3 levels up, so we simply skip the first 3 frames
11934      without checking the name of their associated function.  */
11935   fi = get_current_frame ();
11936   for (frame_level = 0; frame_level < 3; frame_level += 1)
11937     if (fi != NULL)
11938       fi = get_prev_frame (fi); 
11939
11940   while (fi != NULL)
11941     {
11942       enum language func_lang;
11943
11944       gdb::unique_xmalloc_ptr<char> func_name
11945         = find_frame_funname (fi, &func_lang, NULL);
11946       if (func_name != NULL)
11947         {
11948           if (strcmp (func_name.get (),
11949                       data->exception_info->catch_exception_sym) == 0)
11950             break; /* We found the frame we were looking for...  */
11951         }
11952       fi = get_prev_frame (fi);
11953     }
11954
11955   if (fi == NULL)
11956     return 0;
11957
11958   select_frame (fi);
11959   return parse_and_eval_address ("id.full_name");
11960 }
11961
11962 /* Assuming the inferior just triggered an Ada exception catchpoint
11963    (of any type), return the address in inferior memory where the name
11964    of the exception is stored, if applicable.
11965
11966    Assumes the selected frame is the current frame.
11967
11968    Return zero if the address could not be computed, or if not relevant.  */
11969
11970 static CORE_ADDR
11971 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
11972                            struct breakpoint *b)
11973 {
11974   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11975
11976   switch (ex)
11977     {
11978       case ada_catch_exception:
11979         return (parse_and_eval_address ("e.full_name"));
11980         break;
11981
11982       case ada_catch_exception_unhandled:
11983         return data->exception_info->unhandled_exception_name_addr ();
11984         break;
11985
11986       case ada_catch_handlers:
11987         return 0;  /* The runtimes does not provide access to the exception
11988                       name.  */
11989         break;
11990
11991       case ada_catch_assert:
11992         return 0;  /* Exception name is not relevant in this case.  */
11993         break;
11994
11995       default:
11996         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11997         break;
11998     }
11999
12000   return 0; /* Should never be reached.  */
12001 }
12002
12003 /* Assuming the inferior is stopped at an exception catchpoint,
12004    return the message which was associated to the exception, if
12005    available.  Return NULL if the message could not be retrieved.
12006
12007    Note: The exception message can be associated to an exception
12008    either through the use of the Raise_Exception function, or
12009    more simply (Ada 2005 and later), via:
12010
12011        raise Exception_Name with "exception message";
12012
12013    */
12014
12015 static gdb::unique_xmalloc_ptr<char>
12016 ada_exception_message_1 (void)
12017 {
12018   struct value *e_msg_val;
12019   int e_msg_len;
12020
12021   /* For runtimes that support this feature, the exception message
12022      is passed as an unbounded string argument called "message".  */
12023   e_msg_val = parse_and_eval ("message");
12024   if (e_msg_val == NULL)
12025     return NULL; /* Exception message not supported.  */
12026
12027   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12028   gdb_assert (e_msg_val != NULL);
12029   e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12030
12031   /* If the message string is empty, then treat it as if there was
12032      no exception message.  */
12033   if (e_msg_len <= 0)
12034     return NULL;
12035
12036   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12037   read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
12038                e_msg_len);
12039   e_msg.get ()[e_msg_len] = '\0';
12040
12041   return e_msg;
12042 }
12043
12044 /* Same as ada_exception_message_1, except that all exceptions are
12045    contained here (returning NULL instead).  */
12046
12047 static gdb::unique_xmalloc_ptr<char>
12048 ada_exception_message (void)
12049 {
12050   gdb::unique_xmalloc_ptr<char> e_msg;
12051
12052   try
12053     {
12054       e_msg = ada_exception_message_1 ();
12055     }
12056   catch (const gdb_exception_error &e)
12057     {
12058       e_msg.reset (nullptr);
12059     }
12060
12061   return e_msg;
12062 }
12063
12064 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12065    any error that ada_exception_name_addr_1 might cause to be thrown.
12066    When an error is intercepted, a warning with the error message is printed,
12067    and zero is returned.  */
12068
12069 static CORE_ADDR
12070 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
12071                          struct breakpoint *b)
12072 {
12073   CORE_ADDR result = 0;
12074
12075   try
12076     {
12077       result = ada_exception_name_addr_1 (ex, b);
12078     }
12079
12080   catch (const gdb_exception_error &e)
12081     {
12082       warning (_("failed to get exception name: %s"), e.what ());
12083       return 0;
12084     }
12085
12086   return result;
12087 }
12088
12089 static std::string ada_exception_catchpoint_cond_string
12090   (const char *excep_string,
12091    enum ada_exception_catchpoint_kind ex);
12092
12093 /* Ada catchpoints.
12094
12095    In the case of catchpoints on Ada exceptions, the catchpoint will
12096    stop the target on every exception the program throws.  When a user
12097    specifies the name of a specific exception, we translate this
12098    request into a condition expression (in text form), and then parse
12099    it into an expression stored in each of the catchpoint's locations.
12100    We then use this condition to check whether the exception that was
12101    raised is the one the user is interested in.  If not, then the
12102    target is resumed again.  We store the name of the requested
12103    exception, in order to be able to re-set the condition expression
12104    when symbols change.  */
12105
12106 /* An instance of this type is used to represent an Ada catchpoint
12107    breakpoint location.  */
12108
12109 class ada_catchpoint_location : public bp_location
12110 {
12111 public:
12112   ada_catchpoint_location (breakpoint *owner)
12113     : bp_location (owner, bp_loc_software_breakpoint)
12114   {}
12115
12116   /* The condition that checks whether the exception that was raised
12117      is the specific exception the user specified on catchpoint
12118      creation.  */
12119   expression_up excep_cond_expr;
12120 };
12121
12122 /* An instance of this type is used to represent an Ada catchpoint.  */
12123
12124 struct ada_catchpoint : public breakpoint
12125 {
12126   explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind)
12127     : m_kind (kind)
12128   {
12129   }
12130
12131   /* The name of the specific exception the user specified.  */
12132   std::string excep_string;
12133
12134   /* What kind of catchpoint this is.  */
12135   enum ada_exception_catchpoint_kind m_kind;
12136 };
12137
12138 /* Parse the exception condition string in the context of each of the
12139    catchpoint's locations, and store them for later evaluation.  */
12140
12141 static void
12142 create_excep_cond_exprs (struct ada_catchpoint *c,
12143                          enum ada_exception_catchpoint_kind ex)
12144 {
12145   /* Nothing to do if there's no specific exception to catch.  */
12146   if (c->excep_string.empty ())
12147     return;
12148
12149   /* Same if there are no locations... */
12150   if (c->loc == NULL)
12151     return;
12152
12153   /* Compute the condition expression in text form, from the specific
12154      expection we want to catch.  */
12155   std::string cond_string
12156     = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
12157
12158   /* Iterate over all the catchpoint's locations, and parse an
12159      expression for each.  */
12160   for (bp_location *bl : c->locations ())
12161     {
12162       struct ada_catchpoint_location *ada_loc
12163         = (struct ada_catchpoint_location *) bl;
12164       expression_up exp;
12165
12166       if (!bl->shlib_disabled)
12167         {
12168           const char *s;
12169
12170           s = cond_string.c_str ();
12171           try
12172             {
12173               exp = parse_exp_1 (&s, bl->address,
12174                                  block_for_pc (bl->address),
12175                                  0);
12176             }
12177           catch (const gdb_exception_error &e)
12178             {
12179               warning (_("failed to reevaluate internal exception condition "
12180                          "for catchpoint %d: %s"),
12181                        c->number, e.what ());
12182             }
12183         }
12184
12185       ada_loc->excep_cond_expr = std::move (exp);
12186     }
12187 }
12188
12189 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12190    structure for all exception catchpoint kinds.  */
12191
12192 static struct bp_location *
12193 allocate_location_exception (struct breakpoint *self)
12194 {
12195   return new ada_catchpoint_location (self);
12196 }
12197
12198 /* Implement the RE_SET method in the breakpoint_ops structure for all
12199    exception catchpoint kinds.  */
12200
12201 static void
12202 re_set_exception (struct breakpoint *b)
12203 {
12204   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12205
12206   /* Call the base class's method.  This updates the catchpoint's
12207      locations.  */
12208   bkpt_breakpoint_ops.re_set (b);
12209
12210   /* Reparse the exception conditional expressions.  One for each
12211      location.  */
12212   create_excep_cond_exprs (c, c->m_kind);
12213 }
12214
12215 /* Returns true if we should stop for this breakpoint hit.  If the
12216    user specified a specific exception, we only want to cause a stop
12217    if the program thrown that exception.  */
12218
12219 static bool
12220 should_stop_exception (const struct bp_location *bl)
12221 {
12222   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12223   const struct ada_catchpoint_location *ada_loc
12224     = (const struct ada_catchpoint_location *) bl;
12225   bool stop;
12226
12227   struct internalvar *var = lookup_internalvar ("_ada_exception");
12228   if (c->m_kind == ada_catch_assert)
12229     clear_internalvar (var);
12230   else
12231     {
12232       try
12233         {
12234           const char *expr;
12235
12236           if (c->m_kind == ada_catch_handlers)
12237             expr = ("GNAT_GCC_exception_Access(gcc_exception)"
12238                     ".all.occurrence.id");
12239           else
12240             expr = "e";
12241
12242           struct value *exc = parse_and_eval (expr);
12243           set_internalvar (var, exc);
12244         }
12245       catch (const gdb_exception_error &ex)
12246         {
12247           clear_internalvar (var);
12248         }
12249     }
12250
12251   /* With no specific exception, should always stop.  */
12252   if (c->excep_string.empty ())
12253     return true;
12254
12255   if (ada_loc->excep_cond_expr == NULL)
12256     {
12257       /* We will have a NULL expression if back when we were creating
12258          the expressions, this location's had failed to parse.  */
12259       return true;
12260     }
12261
12262   stop = true;
12263   try
12264     {
12265       struct value *mark;
12266
12267       mark = value_mark ();
12268       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12269       value_free_to_mark (mark);
12270     }
12271   catch (const gdb_exception &ex)
12272     {
12273       exception_fprintf (gdb_stderr, ex,
12274                          _("Error in testing exception condition:\n"));
12275     }
12276
12277   return stop;
12278 }
12279
12280 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12281    for all exception catchpoint kinds.  */
12282
12283 static void
12284 check_status_exception (bpstat *bs)
12285 {
12286   bs->stop = should_stop_exception (bs->bp_location_at.get ());
12287 }
12288
12289 /* Implement the PRINT_IT method in the breakpoint_ops structure
12290    for all exception catchpoint kinds.  */
12291
12292 static enum print_stop_action
12293 print_it_exception (bpstat *bs)
12294 {
12295   struct ui_out *uiout = current_uiout;
12296   struct breakpoint *b = bs->breakpoint_at;
12297
12298   annotate_catchpoint (b->number);
12299
12300   if (uiout->is_mi_like_p ())
12301     {
12302       uiout->field_string ("reason",
12303                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12304       uiout->field_string ("disp", bpdisp_text (b->disposition));
12305     }
12306
12307   uiout->text (b->disposition == disp_del
12308                ? "\nTemporary catchpoint " : "\nCatchpoint ");
12309   uiout->field_signed ("bkptno", b->number);
12310   uiout->text (", ");
12311
12312   /* ada_exception_name_addr relies on the selected frame being the
12313      current frame.  Need to do this here because this function may be
12314      called more than once when printing a stop, and below, we'll
12315      select the first frame past the Ada run-time (see
12316      ada_find_printable_frame).  */
12317   select_frame (get_current_frame ());
12318
12319   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12320   switch (c->m_kind)
12321     {
12322       case ada_catch_exception:
12323       case ada_catch_exception_unhandled:
12324       case ada_catch_handlers:
12325         {
12326           const CORE_ADDR addr = ada_exception_name_addr (c->m_kind, b);
12327           char exception_name[256];
12328
12329           if (addr != 0)
12330             {
12331               read_memory (addr, (gdb_byte *) exception_name,
12332                            sizeof (exception_name) - 1);
12333               exception_name [sizeof (exception_name) - 1] = '\0';
12334             }
12335           else
12336             {
12337               /* For some reason, we were unable to read the exception
12338                  name.  This could happen if the Runtime was compiled
12339                  without debugging info, for instance.  In that case,
12340                  just replace the exception name by the generic string
12341                  "exception" - it will read as "an exception" in the
12342                  notification we are about to print.  */
12343               memcpy (exception_name, "exception", sizeof ("exception"));
12344             }
12345           /* In the case of unhandled exception breakpoints, we print
12346              the exception name as "unhandled EXCEPTION_NAME", to make
12347              it clearer to the user which kind of catchpoint just got
12348              hit.  We used ui_out_text to make sure that this extra
12349              info does not pollute the exception name in the MI case.  */
12350           if (c->m_kind == ada_catch_exception_unhandled)
12351             uiout->text ("unhandled ");
12352           uiout->field_string ("exception-name", exception_name);
12353         }
12354         break;
12355       case ada_catch_assert:
12356         /* In this case, the name of the exception is not really
12357            important.  Just print "failed assertion" to make it clearer
12358            that his program just hit an assertion-failure catchpoint.
12359            We used ui_out_text because this info does not belong in
12360            the MI output.  */
12361         uiout->text ("failed assertion");
12362         break;
12363     }
12364
12365   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12366   if (exception_message != NULL)
12367     {
12368       uiout->text (" (");
12369       uiout->field_string ("exception-message", exception_message.get ());
12370       uiout->text (")");
12371     }
12372
12373   uiout->text (" at ");
12374   ada_find_printable_frame (get_current_frame ());
12375
12376   return PRINT_SRC_AND_LOC;
12377 }
12378
12379 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12380    for all exception catchpoint kinds.  */
12381
12382 static void
12383 print_one_exception (struct breakpoint *b, struct bp_location **last_loc)
12384
12385   struct ui_out *uiout = current_uiout;
12386   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12387   struct value_print_options opts;
12388
12389   get_user_print_options (&opts);
12390
12391   if (opts.addressprint)
12392     uiout->field_skip ("addr");
12393
12394   annotate_field (5);
12395   switch (c->m_kind)
12396     {
12397       case ada_catch_exception:
12398         if (!c->excep_string.empty ())
12399           {
12400             std::string msg = string_printf (_("`%s' Ada exception"),
12401                                              c->excep_string.c_str ());
12402
12403             uiout->field_string ("what", msg);
12404           }
12405         else
12406           uiout->field_string ("what", "all Ada exceptions");
12407         
12408         break;
12409
12410       case ada_catch_exception_unhandled:
12411         uiout->field_string ("what", "unhandled Ada exceptions");
12412         break;
12413       
12414       case ada_catch_handlers:
12415         if (!c->excep_string.empty ())
12416           {
12417             uiout->field_fmt ("what",
12418                               _("`%s' Ada exception handlers"),
12419                               c->excep_string.c_str ());
12420           }
12421         else
12422           uiout->field_string ("what", "all Ada exceptions handlers");
12423         break;
12424
12425       case ada_catch_assert:
12426         uiout->field_string ("what", "failed Ada assertions");
12427         break;
12428
12429       default:
12430         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12431         break;
12432     }
12433 }
12434
12435 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12436    for all exception catchpoint kinds.  */
12437
12438 static void
12439 print_mention_exception (struct breakpoint *b)
12440 {
12441   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12442   struct ui_out *uiout = current_uiout;
12443
12444   uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
12445                                                  : _("Catchpoint "));
12446   uiout->field_signed ("bkptno", b->number);
12447   uiout->text (": ");
12448
12449   switch (c->m_kind)
12450     {
12451       case ada_catch_exception:
12452         if (!c->excep_string.empty ())
12453           {
12454             std::string info = string_printf (_("`%s' Ada exception"),
12455                                               c->excep_string.c_str ());
12456             uiout->text (info);
12457           }
12458         else
12459           uiout->text (_("all Ada exceptions"));
12460         break;
12461
12462       case ada_catch_exception_unhandled:
12463         uiout->text (_("unhandled Ada exceptions"));
12464         break;
12465
12466       case ada_catch_handlers:
12467         if (!c->excep_string.empty ())
12468           {
12469             std::string info
12470               = string_printf (_("`%s' Ada exception handlers"),
12471                                c->excep_string.c_str ());
12472             uiout->text (info);
12473           }
12474         else
12475           uiout->text (_("all Ada exceptions handlers"));
12476         break;
12477
12478       case ada_catch_assert:
12479         uiout->text (_("failed Ada assertions"));
12480         break;
12481
12482       default:
12483         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12484         break;
12485     }
12486 }
12487
12488 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12489    for all exception catchpoint kinds.  */
12490
12491 static void
12492 print_recreate_exception (struct breakpoint *b, struct ui_file *fp)
12493 {
12494   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12495
12496   switch (c->m_kind)
12497     {
12498       case ada_catch_exception:
12499         gdb_printf (fp, "catch exception");
12500         if (!c->excep_string.empty ())
12501           gdb_printf (fp, " %s", c->excep_string.c_str ());
12502         break;
12503
12504       case ada_catch_exception_unhandled:
12505         gdb_printf (fp, "catch exception unhandled");
12506         break;
12507
12508       case ada_catch_handlers:
12509         gdb_printf (fp, "catch handlers");
12510         break;
12511
12512       case ada_catch_assert:
12513         gdb_printf (fp, "catch assert");
12514         break;
12515
12516       default:
12517         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12518     }
12519   print_recreate_thread (b, fp);
12520 }
12521
12522 /* Virtual table for breakpoint type.  */
12523 static struct breakpoint_ops catch_exception_breakpoint_ops;
12524
12525 /* See ada-lang.h.  */
12526
12527 bool
12528 is_ada_exception_catchpoint (breakpoint *bp)
12529 {
12530   return bp->ops == &catch_exception_breakpoint_ops;
12531 }
12532
12533 /* Split the arguments specified in a "catch exception" command.  
12534    Set EX to the appropriate catchpoint type.
12535    Set EXCEP_STRING to the name of the specific exception if
12536    specified by the user.
12537    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12538    "catch handlers" command.  False otherwise.
12539    If a condition is found at the end of the arguments, the condition
12540    expression is stored in COND_STRING (memory must be deallocated
12541    after use).  Otherwise COND_STRING is set to NULL.  */
12542
12543 static void
12544 catch_ada_exception_command_split (const char *args,
12545                                    bool is_catch_handlers_cmd,
12546                                    enum ada_exception_catchpoint_kind *ex,
12547                                    std::string *excep_string,
12548                                    std::string *cond_string)
12549 {
12550   std::string exception_name;
12551
12552   exception_name = extract_arg (&args);
12553   if (exception_name == "if")
12554     {
12555       /* This is not an exception name; this is the start of a condition
12556          expression for a catchpoint on all exceptions.  So, "un-get"
12557          this token, and set exception_name to NULL.  */
12558       exception_name.clear ();
12559       args -= 2;
12560     }
12561
12562   /* Check to see if we have a condition.  */
12563
12564   args = skip_spaces (args);
12565   if (startswith (args, "if")
12566       && (isspace (args[2]) || args[2] == '\0'))
12567     {
12568       args += 2;
12569       args = skip_spaces (args);
12570
12571       if (args[0] == '\0')
12572         error (_("Condition missing after `if' keyword"));
12573       *cond_string = args;
12574
12575       args += strlen (args);
12576     }
12577
12578   /* Check that we do not have any more arguments.  Anything else
12579      is unexpected.  */
12580
12581   if (args[0] != '\0')
12582     error (_("Junk at end of expression"));
12583
12584   if (is_catch_handlers_cmd)
12585     {
12586       /* Catch handling of exceptions.  */
12587       *ex = ada_catch_handlers;
12588       *excep_string = exception_name;
12589     }
12590   else if (exception_name.empty ())
12591     {
12592       /* Catch all exceptions.  */
12593       *ex = ada_catch_exception;
12594       excep_string->clear ();
12595     }
12596   else if (exception_name == "unhandled")
12597     {
12598       /* Catch unhandled exceptions.  */
12599       *ex = ada_catch_exception_unhandled;
12600       excep_string->clear ();
12601     }
12602   else
12603     {
12604       /* Catch a specific exception.  */
12605       *ex = ada_catch_exception;
12606       *excep_string = exception_name;
12607     }
12608 }
12609
12610 /* Return the name of the symbol on which we should break in order to
12611    implement a catchpoint of the EX kind.  */
12612
12613 static const char *
12614 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12615 {
12616   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12617
12618   gdb_assert (data->exception_info != NULL);
12619
12620   switch (ex)
12621     {
12622       case ada_catch_exception:
12623         return (data->exception_info->catch_exception_sym);
12624         break;
12625       case ada_catch_exception_unhandled:
12626         return (data->exception_info->catch_exception_unhandled_sym);
12627         break;
12628       case ada_catch_assert:
12629         return (data->exception_info->catch_assert_sym);
12630         break;
12631       case ada_catch_handlers:
12632         return (data->exception_info->catch_handlers_sym);
12633         break;
12634       default:
12635         internal_error (__FILE__, __LINE__,
12636                         _("unexpected catchpoint kind (%d)"), ex);
12637     }
12638 }
12639
12640 /* Return the condition that will be used to match the current exception
12641    being raised with the exception that the user wants to catch.  This
12642    assumes that this condition is used when the inferior just triggered
12643    an exception catchpoint.
12644    EX: the type of catchpoints used for catching Ada exceptions.  */
12645
12646 static std::string
12647 ada_exception_catchpoint_cond_string (const char *excep_string,
12648                                       enum ada_exception_catchpoint_kind ex)
12649 {
12650   bool is_standard_exc = false;
12651   std::string result;
12652
12653   if (ex == ada_catch_handlers)
12654     {
12655       /* For exception handlers catchpoints, the condition string does
12656          not use the same parameter as for the other exceptions.  */
12657       result = ("long_integer (GNAT_GCC_exception_Access"
12658                 "(gcc_exception).all.occurrence.id)");
12659     }
12660   else
12661     result = "long_integer (e)";
12662
12663   /* The standard exceptions are a special case.  They are defined in
12664      runtime units that have been compiled without debugging info; if
12665      EXCEP_STRING is the not-fully-qualified name of a standard
12666      exception (e.g. "constraint_error") then, during the evaluation
12667      of the condition expression, the symbol lookup on this name would
12668      *not* return this standard exception.  The catchpoint condition
12669      may then be set only on user-defined exceptions which have the
12670      same not-fully-qualified name (e.g. my_package.constraint_error).
12671
12672      To avoid this unexcepted behavior, these standard exceptions are
12673      systematically prefixed by "standard".  This means that "catch
12674      exception constraint_error" is rewritten into "catch exception
12675      standard.constraint_error".
12676
12677      If an exception named constraint_error is defined in another package of
12678      the inferior program, then the only way to specify this exception as a
12679      breakpoint condition is to use its fully-qualified named:
12680      e.g. my_package.constraint_error.  */
12681
12682   for (const char *name : standard_exc)
12683     {
12684       if (strcmp (name, excep_string) == 0)
12685         {
12686           is_standard_exc = true;
12687           break;
12688         }
12689     }
12690
12691   result += " = ";
12692
12693   if (is_standard_exc)
12694     string_appendf (result, "long_integer (&standard.%s)", excep_string);
12695   else
12696     string_appendf (result, "long_integer (&%s)", excep_string);
12697
12698   return result;
12699 }
12700
12701 /* Return the symtab_and_line that should be used to insert an exception
12702    catchpoint of the TYPE kind.
12703
12704    ADDR_STRING returns the name of the function where the real
12705    breakpoint that implements the catchpoints is set, depending on the
12706    type of catchpoint we need to create.  */
12707
12708 static struct symtab_and_line
12709 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12710                    std::string *addr_string, const struct breakpoint_ops **ops)
12711 {
12712   const char *sym_name;
12713   struct symbol *sym;
12714
12715   /* First, find out which exception support info to use.  */
12716   ada_exception_support_info_sniffer ();
12717
12718   /* Then lookup the function on which we will break in order to catch
12719      the Ada exceptions requested by the user.  */
12720   sym_name = ada_exception_sym_name (ex);
12721   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12722
12723   if (sym == NULL)
12724     error (_("Catchpoint symbol not found: %s"), sym_name);
12725
12726   if (sym->aclass () != LOC_BLOCK)
12727     error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12728
12729   /* Set ADDR_STRING.  */
12730   *addr_string = sym_name;
12731
12732   /* Set OPS.  */
12733   *ops = &catch_exception_breakpoint_ops;
12734
12735   return find_function_start_sal (sym, 1);
12736 }
12737
12738 /* Create an Ada exception catchpoint.
12739
12740    EX_KIND is the kind of exception catchpoint to be created.
12741
12742    If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12743    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
12744    of the exception to which this catchpoint applies.
12745
12746    COND_STRING, if not empty, is the catchpoint condition.
12747
12748    TEMPFLAG, if nonzero, means that the underlying breakpoint
12749    should be temporary.
12750
12751    FROM_TTY is the usual argument passed to all commands implementations.  */
12752
12753 void
12754 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12755                                  enum ada_exception_catchpoint_kind ex_kind,
12756                                  const std::string &excep_string,
12757                                  const std::string &cond_string,
12758                                  int tempflag,
12759                                  int disabled,
12760                                  int from_tty)
12761 {
12762   std::string addr_string;
12763   const struct breakpoint_ops *ops = NULL;
12764   struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
12765
12766   std::unique_ptr<ada_catchpoint> c (new ada_catchpoint (ex_kind));
12767   init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
12768                                  ops, tempflag, disabled, from_tty);
12769   c->excep_string = excep_string;
12770   create_excep_cond_exprs (c.get (), ex_kind);
12771   if (!cond_string.empty ())
12772     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12773   install_breakpoint (0, std::move (c), 1);
12774 }
12775
12776 /* Implement the "catch exception" command.  */
12777
12778 static void
12779 catch_ada_exception_command (const char *arg_entry, int from_tty,
12780                              struct cmd_list_element *command)
12781 {
12782   const char *arg = arg_entry;
12783   struct gdbarch *gdbarch = get_current_arch ();
12784   int tempflag;
12785   enum ada_exception_catchpoint_kind ex_kind;
12786   std::string excep_string;
12787   std::string cond_string;
12788
12789   tempflag = command->context () == CATCH_TEMPORARY;
12790
12791   if (!arg)
12792     arg = "";
12793   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12794                                      &cond_string);
12795   create_ada_exception_catchpoint (gdbarch, ex_kind,
12796                                    excep_string, cond_string,
12797                                    tempflag, 1 /* enabled */,
12798                                    from_tty);
12799 }
12800
12801 /* Implement the "catch handlers" command.  */
12802
12803 static void
12804 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12805                             struct cmd_list_element *command)
12806 {
12807   const char *arg = arg_entry;
12808   struct gdbarch *gdbarch = get_current_arch ();
12809   int tempflag;
12810   enum ada_exception_catchpoint_kind ex_kind;
12811   std::string excep_string;
12812   std::string cond_string;
12813
12814   tempflag = command->context () == CATCH_TEMPORARY;
12815
12816   if (!arg)
12817     arg = "";
12818   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12819                                      &cond_string);
12820   create_ada_exception_catchpoint (gdbarch, ex_kind,
12821                                    excep_string, cond_string,
12822                                    tempflag, 1 /* enabled */,
12823                                    from_tty);
12824 }
12825
12826 /* Completion function for the Ada "catch" commands.  */
12827
12828 static void
12829 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12830                      const char *text, const char *word)
12831 {
12832   std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12833
12834   for (const ada_exc_info &info : exceptions)
12835     {
12836       if (startswith (info.name, word))
12837         tracker.add_completion (make_unique_xstrdup (info.name));
12838     }
12839 }
12840
12841 /* Split the arguments specified in a "catch assert" command.
12842
12843    ARGS contains the command's arguments (or the empty string if
12844    no arguments were passed).
12845
12846    If ARGS contains a condition, set COND_STRING to that condition
12847    (the memory needs to be deallocated after use).  */
12848
12849 static void
12850 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12851 {
12852   args = skip_spaces (args);
12853
12854   /* Check whether a condition was provided.  */
12855   if (startswith (args, "if")
12856       && (isspace (args[2]) || args[2] == '\0'))
12857     {
12858       args += 2;
12859       args = skip_spaces (args);
12860       if (args[0] == '\0')
12861         error (_("condition missing after `if' keyword"));
12862       cond_string.assign (args);
12863     }
12864
12865   /* Otherwise, there should be no other argument at the end of
12866      the command.  */
12867   else if (args[0] != '\0')
12868     error (_("Junk at end of arguments."));
12869 }
12870
12871 /* Implement the "catch assert" command.  */
12872
12873 static void
12874 catch_assert_command (const char *arg_entry, int from_tty,
12875                       struct cmd_list_element *command)
12876 {
12877   const char *arg = arg_entry;
12878   struct gdbarch *gdbarch = get_current_arch ();
12879   int tempflag;
12880   std::string cond_string;
12881
12882   tempflag = command->context () == CATCH_TEMPORARY;
12883
12884   if (!arg)
12885     arg = "";
12886   catch_ada_assert_command_split (arg, cond_string);
12887   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12888                                    "", cond_string,
12889                                    tempflag, 1 /* enabled */,
12890                                    from_tty);
12891 }
12892
12893 /* Return non-zero if the symbol SYM is an Ada exception object.  */
12894
12895 static int
12896 ada_is_exception_sym (struct symbol *sym)
12897 {
12898   const char *type_name = sym->type ()->name ();
12899
12900   return (sym->aclass () != LOC_TYPEDEF
12901           && sym->aclass () != LOC_BLOCK
12902           && sym->aclass () != LOC_CONST
12903           && sym->aclass () != LOC_UNRESOLVED
12904           && type_name != NULL && strcmp (type_name, "exception") == 0);
12905 }
12906
12907 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12908    Ada exception object.  This matches all exceptions except the ones
12909    defined by the Ada language.  */
12910
12911 static int
12912 ada_is_non_standard_exception_sym (struct symbol *sym)
12913 {
12914   if (!ada_is_exception_sym (sym))
12915     return 0;
12916
12917   for (const char *name : standard_exc)
12918     if (strcmp (sym->linkage_name (), name) == 0)
12919       return 0;  /* A standard exception.  */
12920
12921   /* Numeric_Error is also a standard exception, so exclude it.
12922      See the STANDARD_EXC description for more details as to why
12923      this exception is not listed in that array.  */
12924   if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12925     return 0;
12926
12927   return 1;
12928 }
12929
12930 /* A helper function for std::sort, comparing two struct ada_exc_info
12931    objects.
12932
12933    The comparison is determined first by exception name, and then
12934    by exception address.  */
12935
12936 bool
12937 ada_exc_info::operator< (const ada_exc_info &other) const
12938 {
12939   int result;
12940
12941   result = strcmp (name, other.name);
12942   if (result < 0)
12943     return true;
12944   if (result == 0 && addr < other.addr)
12945     return true;
12946   return false;
12947 }
12948
12949 bool
12950 ada_exc_info::operator== (const ada_exc_info &other) const
12951 {
12952   return addr == other.addr && strcmp (name, other.name) == 0;
12953 }
12954
12955 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12956    routine, but keeping the first SKIP elements untouched.
12957
12958    All duplicates are also removed.  */
12959
12960 static void
12961 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
12962                                       int skip)
12963 {
12964   std::sort (exceptions->begin () + skip, exceptions->end ());
12965   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
12966                      exceptions->end ());
12967 }
12968
12969 /* Add all exceptions defined by the Ada standard whose name match
12970    a regular expression.
12971
12972    If PREG is not NULL, then this regexp_t object is used to
12973    perform the symbol name matching.  Otherwise, no name-based
12974    filtering is performed.
12975
12976    EXCEPTIONS is a vector of exceptions to which matching exceptions
12977    gets pushed.  */
12978
12979 static void
12980 ada_add_standard_exceptions (compiled_regex *preg,
12981                              std::vector<ada_exc_info> *exceptions)
12982 {
12983   for (const char *name : standard_exc)
12984     {
12985       if (preg == NULL || preg->exec (name, 0, NULL, 0) == 0)
12986         {
12987           struct bound_minimal_symbol msymbol
12988             = ada_lookup_simple_minsym (name);
12989
12990           if (msymbol.minsym != NULL)
12991             {
12992               struct ada_exc_info info
12993                 = {name, msymbol.value_address ()};
12994
12995               exceptions->push_back (info);
12996             }
12997         }
12998     }
12999 }
13000
13001 /* Add all Ada exceptions defined locally and accessible from the given
13002    FRAME.
13003
13004    If PREG is not NULL, then this regexp_t object is used to
13005    perform the symbol name matching.  Otherwise, no name-based
13006    filtering is performed.
13007
13008    EXCEPTIONS is a vector of exceptions to which matching exceptions
13009    gets pushed.  */
13010
13011 static void
13012 ada_add_exceptions_from_frame (compiled_regex *preg,
13013                                struct frame_info *frame,
13014                                std::vector<ada_exc_info> *exceptions)
13015 {
13016   const struct block *block = get_frame_block (frame, 0);
13017
13018   while (block != 0)
13019     {
13020       struct block_iterator iter;
13021       struct symbol *sym;
13022
13023       ALL_BLOCK_SYMBOLS (block, iter, sym)
13024         {
13025           switch (sym->aclass ())
13026             {
13027             case LOC_TYPEDEF:
13028             case LOC_BLOCK:
13029             case LOC_CONST:
13030               break;
13031             default:
13032               if (ada_is_exception_sym (sym))
13033                 {
13034                   struct ada_exc_info info = {sym->print_name (),
13035                                               sym->value_address ()};
13036
13037                   exceptions->push_back (info);
13038                 }
13039             }
13040         }
13041       if (BLOCK_FUNCTION (block) != NULL)
13042         break;
13043       block = BLOCK_SUPERBLOCK (block);
13044     }
13045 }
13046
13047 /* Return true if NAME matches PREG or if PREG is NULL.  */
13048
13049 static bool
13050 name_matches_regex (const char *name, compiled_regex *preg)
13051 {
13052   return (preg == NULL
13053           || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
13054 }
13055
13056 /* Add all exceptions defined globally whose name name match
13057    a regular expression, excluding standard exceptions.
13058
13059    The reason we exclude standard exceptions is that they need
13060    to be handled separately: Standard exceptions are defined inside
13061    a runtime unit which is normally not compiled with debugging info,
13062    and thus usually do not show up in our symbol search.  However,
13063    if the unit was in fact built with debugging info, we need to
13064    exclude them because they would duplicate the entry we found
13065    during the special loop that specifically searches for those
13066    standard exceptions.
13067
13068    If PREG is not NULL, then this regexp_t object is used to
13069    perform the symbol name matching.  Otherwise, no name-based
13070    filtering is performed.
13071
13072    EXCEPTIONS is a vector of exceptions to which matching exceptions
13073    gets pushed.  */
13074
13075 static void
13076 ada_add_global_exceptions (compiled_regex *preg,
13077                            std::vector<ada_exc_info> *exceptions)
13078 {
13079   /* In Ada, the symbol "search name" is a linkage name, whereas the
13080      regular expression used to do the matching refers to the natural
13081      name.  So match against the decoded name.  */
13082   expand_symtabs_matching (NULL,
13083                            lookup_name_info::match_any (),
13084                            [&] (const char *search_name)
13085                            {
13086                              std::string decoded = ada_decode (search_name);
13087                              return name_matches_regex (decoded.c_str (), preg);
13088                            },
13089                            NULL,
13090                            SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13091                            VARIABLES_DOMAIN);
13092
13093   for (objfile *objfile : current_program_space->objfiles ())
13094     {
13095       for (compunit_symtab *s : objfile->compunits ())
13096         {
13097           const struct blockvector *bv = s->blockvector ();
13098           int i;
13099
13100           for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13101             {
13102               const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13103               struct block_iterator iter;
13104               struct symbol *sym;
13105
13106               ALL_BLOCK_SYMBOLS (b, iter, sym)
13107                 if (ada_is_non_standard_exception_sym (sym)
13108                     && name_matches_regex (sym->natural_name (), preg))
13109                   {
13110                     struct ada_exc_info info
13111                       = {sym->print_name (), sym->value_address ()};
13112
13113                     exceptions->push_back (info);
13114                   }
13115             }
13116         }
13117     }
13118 }
13119
13120 /* Implements ada_exceptions_list with the regular expression passed
13121    as a regex_t, rather than a string.
13122
13123    If not NULL, PREG is used to filter out exceptions whose names
13124    do not match.  Otherwise, all exceptions are listed.  */
13125
13126 static std::vector<ada_exc_info>
13127 ada_exceptions_list_1 (compiled_regex *preg)
13128 {
13129   std::vector<ada_exc_info> result;
13130   int prev_len;
13131
13132   /* First, list the known standard exceptions.  These exceptions
13133      need to be handled separately, as they are usually defined in
13134      runtime units that have been compiled without debugging info.  */
13135
13136   ada_add_standard_exceptions (preg, &result);
13137
13138   /* Next, find all exceptions whose scope is local and accessible
13139      from the currently selected frame.  */
13140
13141   if (has_stack_frames ())
13142     {
13143       prev_len = result.size ();
13144       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13145                                      &result);
13146       if (result.size () > prev_len)
13147         sort_remove_dups_ada_exceptions_list (&result, prev_len);
13148     }
13149
13150   /* Add all exceptions whose scope is global.  */
13151
13152   prev_len = result.size ();
13153   ada_add_global_exceptions (preg, &result);
13154   if (result.size () > prev_len)
13155     sort_remove_dups_ada_exceptions_list (&result, prev_len);
13156
13157   return result;
13158 }
13159
13160 /* Return a vector of ada_exc_info.
13161
13162    If REGEXP is NULL, all exceptions are included in the result.
13163    Otherwise, it should contain a valid regular expression,
13164    and only the exceptions whose names match that regular expression
13165    are included in the result.
13166
13167    The exceptions are sorted in the following order:
13168      - Standard exceptions (defined by the Ada language), in
13169        alphabetical order;
13170      - Exceptions only visible from the current frame, in
13171        alphabetical order;
13172      - Exceptions whose scope is global, in alphabetical order.  */
13173
13174 std::vector<ada_exc_info>
13175 ada_exceptions_list (const char *regexp)
13176 {
13177   if (regexp == NULL)
13178     return ada_exceptions_list_1 (NULL);
13179
13180   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13181   return ada_exceptions_list_1 (&reg);
13182 }
13183
13184 /* Implement the "info exceptions" command.  */
13185
13186 static void
13187 info_exceptions_command (const char *regexp, int from_tty)
13188 {
13189   struct gdbarch *gdbarch = get_current_arch ();
13190
13191   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13192
13193   if (regexp != NULL)
13194     gdb_printf
13195       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13196   else
13197     gdb_printf (_("All defined Ada exceptions:\n"));
13198
13199   for (const ada_exc_info &info : exceptions)
13200     gdb_printf ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13201 }
13202
13203 \f
13204                                 /* Language vector */
13205
13206 /* symbol_name_matcher_ftype adapter for wild_match.  */
13207
13208 static bool
13209 do_wild_match (const char *symbol_search_name,
13210                const lookup_name_info &lookup_name,
13211                completion_match_result *comp_match_res)
13212 {
13213   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
13214 }
13215
13216 /* symbol_name_matcher_ftype adapter for full_match.  */
13217
13218 static bool
13219 do_full_match (const char *symbol_search_name,
13220                const lookup_name_info &lookup_name,
13221                completion_match_result *comp_match_res)
13222 {
13223   const char *lname = lookup_name.ada ().lookup_name ().c_str ();
13224
13225   /* If both symbols start with "_ada_", just let the loop below
13226      handle the comparison.  However, if only the symbol name starts
13227      with "_ada_", skip the prefix and let the match proceed as
13228      usual.  */
13229   if (startswith (symbol_search_name, "_ada_")
13230       && !startswith (lname, "_ada"))
13231     symbol_search_name += 5;
13232   /* Likewise for ghost entities.  */
13233   if (startswith (symbol_search_name, "___ghost_")
13234       && !startswith (lname, "___ghost_"))
13235     symbol_search_name += 9;
13236
13237   int uscore_count = 0;
13238   while (*lname != '\0')
13239     {
13240       if (*symbol_search_name != *lname)
13241         {
13242           if (*symbol_search_name == 'B' && uscore_count == 2
13243               && symbol_search_name[1] == '_')
13244             {
13245               symbol_search_name += 2;
13246               while (isdigit (*symbol_search_name))
13247                 ++symbol_search_name;
13248               if (symbol_search_name[0] == '_'
13249                   && symbol_search_name[1] == '_')
13250                 {
13251                   symbol_search_name += 2;
13252                   continue;
13253                 }
13254             }
13255           return false;
13256         }
13257
13258       if (*symbol_search_name == '_')
13259         ++uscore_count;
13260       else
13261         uscore_count = 0;
13262
13263       ++symbol_search_name;
13264       ++lname;
13265     }
13266
13267   return is_name_suffix (symbol_search_name);
13268 }
13269
13270 /* symbol_name_matcher_ftype for exact (verbatim) matches.  */
13271
13272 static bool
13273 do_exact_match (const char *symbol_search_name,
13274                 const lookup_name_info &lookup_name,
13275                 completion_match_result *comp_match_res)
13276 {
13277   return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
13278 }
13279
13280 /* Build the Ada lookup name for LOOKUP_NAME.  */
13281
13282 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
13283 {
13284   gdb::string_view user_name = lookup_name.name ();
13285
13286   if (!user_name.empty () && user_name[0] == '<')
13287     {
13288       if (user_name.back () == '>')
13289         m_encoded_name
13290           = gdb::to_string (user_name.substr (1, user_name.size () - 2));
13291       else
13292         m_encoded_name
13293           = gdb::to_string (user_name.substr (1, user_name.size () - 1));
13294       m_encoded_p = true;
13295       m_verbatim_p = true;
13296       m_wild_match_p = false;
13297       m_standard_p = false;
13298     }
13299   else
13300     {
13301       m_verbatim_p = false;
13302
13303       m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
13304
13305       if (!m_encoded_p)
13306         {
13307           const char *folded = ada_fold_name (user_name);
13308           m_encoded_name = ada_encode_1 (folded, false);
13309           if (m_encoded_name.empty ())
13310             m_encoded_name = gdb::to_string (user_name);
13311         }
13312       else
13313         m_encoded_name = gdb::to_string (user_name);
13314
13315       /* Handle the 'package Standard' special case.  See description
13316          of m_standard_p.  */
13317       if (startswith (m_encoded_name.c_str (), "standard__"))
13318         {
13319           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
13320           m_standard_p = true;
13321         }
13322       else
13323         m_standard_p = false;
13324
13325       /* If the name contains a ".", then the user is entering a fully
13326          qualified entity name, and the match must not be done in wild
13327          mode.  Similarly, if the user wants to complete what looks
13328          like an encoded name, the match must not be done in wild
13329          mode.  Also, in the standard__ special case always do
13330          non-wild matching.  */
13331       m_wild_match_p
13332         = (lookup_name.match_type () != symbol_name_match_type::FULL
13333            && !m_encoded_p
13334            && !m_standard_p
13335            && user_name.find ('.') == std::string::npos);
13336     }
13337 }
13338
13339 /* symbol_name_matcher_ftype method for Ada.  This only handles
13340    completion mode.  */
13341
13342 static bool
13343 ada_symbol_name_matches (const char *symbol_search_name,
13344                          const lookup_name_info &lookup_name,
13345                          completion_match_result *comp_match_res)
13346 {
13347   return lookup_name.ada ().matches (symbol_search_name,
13348                                      lookup_name.match_type (),
13349                                      comp_match_res);
13350 }
13351
13352 /* A name matcher that matches the symbol name exactly, with
13353    strcmp.  */
13354
13355 static bool
13356 literal_symbol_name_matcher (const char *symbol_search_name,
13357                              const lookup_name_info &lookup_name,
13358                              completion_match_result *comp_match_res)
13359 {
13360   gdb::string_view name_view = lookup_name.name ();
13361
13362   if (lookup_name.completion_mode ()
13363       ? (strncmp (symbol_search_name, name_view.data (),
13364                   name_view.size ()) == 0)
13365       : symbol_search_name == name_view)
13366     {
13367       if (comp_match_res != NULL)
13368         comp_match_res->set_match (symbol_search_name);
13369       return true;
13370     }
13371   else
13372     return false;
13373 }
13374
13375 /* Implement the "get_symbol_name_matcher" language_defn method for
13376    Ada.  */
13377
13378 static symbol_name_matcher_ftype *
13379 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
13380 {
13381   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
13382     return literal_symbol_name_matcher;
13383
13384   if (lookup_name.completion_mode ())
13385     return ada_symbol_name_matches;
13386   else
13387     {
13388       if (lookup_name.ada ().wild_match_p ())
13389         return do_wild_match;
13390       else if (lookup_name.ada ().verbatim_p ())
13391         return do_exact_match;
13392       else
13393         return do_full_match;
13394     }
13395 }
13396
13397 /* Class representing the Ada language.  */
13398
13399 class ada_language : public language_defn
13400 {
13401 public:
13402   ada_language ()
13403     : language_defn (language_ada)
13404   { /* Nothing.  */ }
13405
13406   /* See language.h.  */
13407
13408   const char *name () const override
13409   { return "ada"; }
13410
13411   /* See language.h.  */
13412
13413   const char *natural_name () const override
13414   { return "Ada"; }
13415
13416   /* See language.h.  */
13417
13418   const std::vector<const char *> &filename_extensions () const override
13419   {
13420     static const std::vector<const char *> extensions
13421       = { ".adb", ".ads", ".a", ".ada", ".dg" };
13422     return extensions;
13423   }
13424
13425   /* Print an array element index using the Ada syntax.  */
13426
13427   void print_array_index (struct type *index_type,
13428                           LONGEST index,
13429                           struct ui_file *stream,
13430                           const value_print_options *options) const override
13431   {
13432     struct value *index_value = val_atr (index_type, index);
13433
13434     value_print (index_value, stream, options);
13435     gdb_printf (stream, " => ");
13436   }
13437
13438   /* Implement the "read_var_value" language_defn method for Ada.  */
13439
13440   struct value *read_var_value (struct symbol *var,
13441                                 const struct block *var_block,
13442                                 struct frame_info *frame) const override
13443   {
13444     /* The only case where default_read_var_value is not sufficient
13445        is when VAR is a renaming...  */
13446     if (frame != nullptr)
13447       {
13448         const struct block *frame_block = get_frame_block (frame, NULL);
13449         if (frame_block != nullptr && ada_is_renaming_symbol (var))
13450           return ada_read_renaming_var_value (var, frame_block);
13451       }
13452
13453     /* This is a typical case where we expect the default_read_var_value
13454        function to work.  */
13455     return language_defn::read_var_value (var, var_block, frame);
13456   }
13457
13458   /* See language.h.  */
13459   bool symbol_printing_suppressed (struct symbol *symbol) const override
13460   {
13461     return symbol->is_artificial ();
13462   }
13463
13464   /* See language.h.  */
13465   void language_arch_info (struct gdbarch *gdbarch,
13466                            struct language_arch_info *lai) const override
13467   {
13468     const struct builtin_type *builtin = builtin_type (gdbarch);
13469
13470     /* Helper function to allow shorter lines below.  */
13471     auto add = [&] (struct type *t)
13472     {
13473       lai->add_primitive_type (t);
13474     };
13475
13476     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13477                             0, "integer"));
13478     add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13479                             0, "long_integer"));
13480     add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13481                             0, "short_integer"));
13482     struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
13483                                                   1, "character");
13484     lai->set_string_char_type (char_type);
13485     add (char_type);
13486     add (arch_character_type (gdbarch, 16, 1, "wide_character"));
13487     add (arch_character_type (gdbarch, 32, 1, "wide_wide_character"));
13488     add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13489                           "float", gdbarch_float_format (gdbarch)));
13490     add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13491                           "long_float", gdbarch_double_format (gdbarch)));
13492     add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13493                             0, "long_long_integer"));
13494     add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13495                           "long_long_float",
13496                           gdbarch_long_double_format (gdbarch)));
13497     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13498                             0, "natural"));
13499     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13500                             0, "positive"));
13501     add (builtin->builtin_void);
13502
13503     struct type *system_addr_ptr
13504       = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13505                                         "void"));
13506     system_addr_ptr->set_name ("system__address");
13507     add (system_addr_ptr);
13508
13509     /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13510        type.  This is a signed integral type whose size is the same as
13511        the size of addresses.  */
13512     unsigned int addr_length = TYPE_LENGTH (system_addr_ptr);
13513     add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13514                             "storage_offset"));
13515
13516     lai->set_bool_type (builtin->builtin_bool);
13517   }
13518
13519   /* See language.h.  */
13520
13521   bool iterate_over_symbols
13522         (const struct block *block, const lookup_name_info &name,
13523          domain_enum domain,
13524          gdb::function_view<symbol_found_callback_ftype> callback) const override
13525   {
13526     std::vector<struct block_symbol> results
13527       = ada_lookup_symbol_list_worker (name, block, domain, 0);
13528     for (block_symbol &sym : results)
13529       {
13530         if (!callback (&sym))
13531           return false;
13532       }
13533
13534     return true;
13535   }
13536
13537   /* See language.h.  */
13538   bool sniff_from_mangled_name
13539        (const char *mangled,
13540         gdb::unique_xmalloc_ptr<char> *out) const override
13541   {
13542     std::string demangled = ada_decode (mangled);
13543
13544     *out = NULL;
13545
13546     if (demangled != mangled && demangled[0] != '<')
13547       {
13548         /* Set the gsymbol language to Ada, but still return 0.
13549            Two reasons for that:
13550
13551            1. For Ada, we prefer computing the symbol's decoded name
13552            on the fly rather than pre-compute it, in order to save
13553            memory (Ada projects are typically very large).
13554
13555            2. There are some areas in the definition of the GNAT
13556            encoding where, with a bit of bad luck, we might be able
13557            to decode a non-Ada symbol, generating an incorrect
13558            demangled name (Eg: names ending with "TB" for instance
13559            are identified as task bodies and so stripped from
13560            the decoded name returned).
13561
13562            Returning true, here, but not setting *DEMANGLED, helps us get
13563            a little bit of the best of both worlds.  Because we're last,
13564            we should not affect any of the other languages that were
13565            able to demangle the symbol before us; we get to correctly
13566            tag Ada symbols as such; and even if we incorrectly tagged a
13567            non-Ada symbol, which should be rare, any routing through the
13568            Ada language should be transparent (Ada tries to behave much
13569            like C/C++ with non-Ada symbols).  */
13570         return true;
13571       }
13572
13573     return false;
13574   }
13575
13576   /* See language.h.  */
13577
13578   gdb::unique_xmalloc_ptr<char> demangle_symbol (const char *mangled,
13579                                                  int options) const override
13580   {
13581     return make_unique_xstrdup (ada_decode (mangled).c_str ());
13582   }
13583
13584   /* See language.h.  */
13585
13586   void print_type (struct type *type, const char *varstring,
13587                    struct ui_file *stream, int show, int level,
13588                    const struct type_print_options *flags) const override
13589   {
13590     ada_print_type (type, varstring, stream, show, level, flags);
13591   }
13592
13593   /* See language.h.  */
13594
13595   const char *word_break_characters (void) const override
13596   {
13597     return ada_completer_word_break_characters;
13598   }
13599
13600   /* See language.h.  */
13601
13602   void collect_symbol_completion_matches (completion_tracker &tracker,
13603                                           complete_symbol_mode mode,
13604                                           symbol_name_match_type name_match_type,
13605                                           const char *text, const char *word,
13606                                           enum type_code code) const override
13607   {
13608     struct symbol *sym;
13609     const struct block *b, *surrounding_static_block = 0;
13610     struct block_iterator iter;
13611
13612     gdb_assert (code == TYPE_CODE_UNDEF);
13613
13614     lookup_name_info lookup_name (text, name_match_type, true);
13615
13616     /* First, look at the partial symtab symbols.  */
13617     expand_symtabs_matching (NULL,
13618                              lookup_name,
13619                              NULL,
13620                              NULL,
13621                              SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13622                              ALL_DOMAIN);
13623
13624     /* At this point scan through the misc symbol vectors and add each
13625        symbol you find to the list.  Eventually we want to ignore
13626        anything that isn't a text symbol (everything else will be
13627        handled by the psymtab code above).  */
13628
13629     for (objfile *objfile : current_program_space->objfiles ())
13630       {
13631         for (minimal_symbol *msymbol : objfile->msymbols ())
13632           {
13633             QUIT;
13634
13635             if (completion_skip_symbol (mode, msymbol))
13636               continue;
13637
13638             language symbol_language = msymbol->language ();
13639
13640             /* Ada minimal symbols won't have their language set to Ada.  If
13641                we let completion_list_add_name compare using the
13642                default/C-like matcher, then when completing e.g., symbols in a
13643                package named "pck", we'd match internal Ada symbols like
13644                "pckS", which are invalid in an Ada expression, unless you wrap
13645                them in '<' '>' to request a verbatim match.
13646
13647                Unfortunately, some Ada encoded names successfully demangle as
13648                C++ symbols (using an old mangling scheme), such as "name__2Xn"
13649                -> "Xn::name(void)" and thus some Ada minimal symbols end up
13650                with the wrong language set.  Paper over that issue here.  */
13651             if (symbol_language == language_auto
13652                 || symbol_language == language_cplus)
13653               symbol_language = language_ada;
13654
13655             completion_list_add_name (tracker,
13656                                       symbol_language,
13657                                       msymbol->linkage_name (),
13658                                       lookup_name, text, word);
13659           }
13660       }
13661
13662     /* Search upwards from currently selected frame (so that we can
13663        complete on local vars.  */
13664
13665     for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
13666       {
13667         if (!BLOCK_SUPERBLOCK (b))
13668           surrounding_static_block = b;   /* For elmin of dups */
13669
13670         ALL_BLOCK_SYMBOLS (b, iter, sym)
13671           {
13672             if (completion_skip_symbol (mode, sym))
13673               continue;
13674
13675             completion_list_add_name (tracker,
13676                                       sym->language (),
13677                                       sym->linkage_name (),
13678                                       lookup_name, text, word);
13679           }
13680       }
13681
13682     /* Go through the symtabs and check the externs and statics for
13683        symbols which match.  */
13684
13685     for (objfile *objfile : current_program_space->objfiles ())
13686       {
13687         for (compunit_symtab *s : objfile->compunits ())
13688           {
13689             QUIT;
13690             b = BLOCKVECTOR_BLOCK (s->blockvector (), GLOBAL_BLOCK);
13691             ALL_BLOCK_SYMBOLS (b, iter, sym)
13692               {
13693                 if (completion_skip_symbol (mode, sym))
13694                   continue;
13695
13696                 completion_list_add_name (tracker,
13697                                           sym->language (),
13698                                           sym->linkage_name (),
13699                                           lookup_name, text, word);
13700               }
13701           }
13702       }
13703
13704     for (objfile *objfile : current_program_space->objfiles ())
13705       {
13706         for (compunit_symtab *s : objfile->compunits ())
13707           {
13708             QUIT;
13709             b = BLOCKVECTOR_BLOCK (s->blockvector (), STATIC_BLOCK);
13710             /* Don't do this block twice.  */
13711             if (b == surrounding_static_block)
13712               continue;
13713             ALL_BLOCK_SYMBOLS (b, iter, sym)
13714               {
13715                 if (completion_skip_symbol (mode, sym))
13716                   continue;
13717
13718                 completion_list_add_name (tracker,
13719                                           sym->language (),
13720                                           sym->linkage_name (),
13721                                           lookup_name, text, word);
13722               }
13723           }
13724       }
13725   }
13726
13727   /* See language.h.  */
13728
13729   gdb::unique_xmalloc_ptr<char> watch_location_expression
13730         (struct type *type, CORE_ADDR addr) const override
13731   {
13732     type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
13733     std::string name = type_to_string (type);
13734     return xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr));
13735   }
13736
13737   /* See language.h.  */
13738
13739   void value_print (struct value *val, struct ui_file *stream,
13740                     const struct value_print_options *options) const override
13741   {
13742     return ada_value_print (val, stream, options);
13743   }
13744
13745   /* See language.h.  */
13746
13747   void value_print_inner
13748         (struct value *val, struct ui_file *stream, int recurse,
13749          const struct value_print_options *options) const override
13750   {
13751     return ada_value_print_inner (val, stream, recurse, options);
13752   }
13753
13754   /* See language.h.  */
13755
13756   struct block_symbol lookup_symbol_nonlocal
13757         (const char *name, const struct block *block,
13758          const domain_enum domain) const override
13759   {
13760     struct block_symbol sym;
13761
13762     sym = ada_lookup_symbol (name, block_static_block (block), domain);
13763     if (sym.symbol != NULL)
13764       return sym;
13765
13766     /* If we haven't found a match at this point, try the primitive
13767        types.  In other languages, this search is performed before
13768        searching for global symbols in order to short-circuit that
13769        global-symbol search if it happens that the name corresponds
13770        to a primitive type.  But we cannot do the same in Ada, because
13771        it is perfectly legitimate for a program to declare a type which
13772        has the same name as a standard type.  If looking up a type in
13773        that situation, we have traditionally ignored the primitive type
13774        in favor of user-defined types.  This is why, unlike most other
13775        languages, we search the primitive types this late and only after
13776        having searched the global symbols without success.  */
13777
13778     if (domain == VAR_DOMAIN)
13779       {
13780         struct gdbarch *gdbarch;
13781
13782         if (block == NULL)
13783           gdbarch = target_gdbarch ();
13784         else
13785           gdbarch = block_gdbarch (block);
13786         sym.symbol
13787           = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13788         if (sym.symbol != NULL)
13789           return sym;
13790       }
13791
13792     return {};
13793   }
13794
13795   /* See language.h.  */
13796
13797   int parser (struct parser_state *ps) const override
13798   {
13799     warnings_issued = 0;
13800     return ada_parse (ps);
13801   }
13802
13803   /* See language.h.  */
13804
13805   void emitchar (int ch, struct type *chtype,
13806                  struct ui_file *stream, int quoter) const override
13807   {
13808     ada_emit_char (ch, chtype, stream, quoter, 1);
13809   }
13810
13811   /* See language.h.  */
13812
13813   void printchar (int ch, struct type *chtype,
13814                   struct ui_file *stream) const override
13815   {
13816     ada_printchar (ch, chtype, stream);
13817   }
13818
13819   /* See language.h.  */
13820
13821   void printstr (struct ui_file *stream, struct type *elttype,
13822                  const gdb_byte *string, unsigned int length,
13823                  const char *encoding, int force_ellipses,
13824                  const struct value_print_options *options) const override
13825   {
13826     ada_printstr (stream, elttype, string, length, encoding,
13827                   force_ellipses, options);
13828   }
13829
13830   /* See language.h.  */
13831
13832   void print_typedef (struct type *type, struct symbol *new_symbol,
13833                       struct ui_file *stream) const override
13834   {
13835     ada_print_typedef (type, new_symbol, stream);
13836   }
13837
13838   /* See language.h.  */
13839
13840   bool is_string_type_p (struct type *type) const override
13841   {
13842     return ada_is_string_type (type);
13843   }
13844
13845   /* See language.h.  */
13846
13847   const char *struct_too_deep_ellipsis () const override
13848   { return "(...)"; }
13849
13850   /* See language.h.  */
13851
13852   bool c_style_arrays_p () const override
13853   { return false; }
13854
13855   /* See language.h.  */
13856
13857   bool store_sym_names_in_linkage_form_p () const override
13858   { return true; }
13859
13860   /* See language.h.  */
13861
13862   const struct lang_varobj_ops *varobj_ops () const override
13863   { return &ada_varobj_ops; }
13864
13865 protected:
13866   /* See language.h.  */
13867
13868   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13869         (const lookup_name_info &lookup_name) const override
13870   {
13871     return ada_get_symbol_name_matcher (lookup_name);
13872   }
13873 };
13874
13875 /* Single instance of the Ada language class.  */
13876
13877 static ada_language ada_language_defn;
13878
13879 /* Command-list for the "set/show ada" prefix command.  */
13880 static struct cmd_list_element *set_ada_list;
13881 static struct cmd_list_element *show_ada_list;
13882
13883 static void
13884 initialize_ada_catchpoint_ops (void)
13885 {
13886   struct breakpoint_ops *ops;
13887
13888   initialize_breakpoint_ops ();
13889
13890   ops = &catch_exception_breakpoint_ops;
13891   *ops = bkpt_breakpoint_ops;
13892   ops->allocate_location = allocate_location_exception;
13893   ops->re_set = re_set_exception;
13894   ops->check_status = check_status_exception;
13895   ops->print_it = print_it_exception;
13896   ops->print_one = print_one_exception;
13897   ops->print_mention = print_mention_exception;
13898   ops->print_recreate = print_recreate_exception;
13899 }
13900
13901 /* This module's 'new_objfile' observer.  */
13902
13903 static void
13904 ada_new_objfile_observer (struct objfile *objfile)
13905 {
13906   ada_clear_symbol_cache ();
13907 }
13908
13909 /* This module's 'free_objfile' observer.  */
13910
13911 static void
13912 ada_free_objfile_observer (struct objfile *objfile)
13913 {
13914   ada_clear_symbol_cache ();
13915 }
13916
13917 /* Charsets known to GNAT.  */
13918 static const char * const gnat_source_charsets[] =
13919 {
13920   /* Note that code below assumes that the default comes first.
13921      Latin-1 is the default here, because that is also GNAT's
13922      default.  */
13923   "ISO-8859-1",
13924   "ISO-8859-2",
13925   "ISO-8859-3",
13926   "ISO-8859-4",
13927   "ISO-8859-5",
13928   "ISO-8859-15",
13929   "CP437",
13930   "CP850",
13931   /* Note that this value is special-cased in the encoder and
13932      decoder.  */
13933   ada_utf8,
13934   nullptr
13935 };
13936
13937 void _initialize_ada_language ();
13938 void
13939 _initialize_ada_language ()
13940 {
13941   initialize_ada_catchpoint_ops ();
13942
13943   add_setshow_prefix_cmd
13944     ("ada", no_class,
13945      _("Prefix command for changing Ada-specific settings."),
13946      _("Generic command for showing Ada-specific settings."),
13947      &set_ada_list, &show_ada_list,
13948      &setlist, &showlist);
13949
13950   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13951                            &trust_pad_over_xvs, _("\
13952 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13953 Show whether an optimization trusting PAD types over XVS types is activated."),
13954                            _("\
13955 This is related to the encoding used by the GNAT compiler.  The debugger\n\
13956 should normally trust the contents of PAD types, but certain older versions\n\
13957 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13958 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
13959 work around this bug.  It is always safe to turn this option \"off\", but\n\
13960 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13961 this option to \"off\" unless necessary."),
13962                             NULL, NULL, &set_ada_list, &show_ada_list);
13963
13964   add_setshow_boolean_cmd ("print-signatures", class_vars,
13965                            &print_signatures, _("\
13966 Enable or disable the output of formal and return types for functions in the \
13967 overloads selection menu."), _("\
13968 Show whether the output of formal and return types for functions in the \
13969 overloads selection menu is activated."),
13970                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
13971
13972   ada_source_charset = gnat_source_charsets[0];
13973   add_setshow_enum_cmd ("source-charset", class_files,
13974                         gnat_source_charsets,
13975                         &ada_source_charset,  _("\
13976 Set the Ada source character set."), _("\
13977 Show the Ada source character set."), _("\
13978 The character set used for Ada source files.\n\
13979 This must correspond to the '-gnati' or '-gnatW' option passed to GNAT."),
13980                         nullptr, nullptr,
13981                         &set_ada_list, &show_ada_list);
13982
13983   add_catch_command ("exception", _("\
13984 Catch Ada exceptions, when raised.\n\
13985 Usage: catch exception [ARG] [if CONDITION]\n\
13986 Without any argument, stop when any Ada exception is raised.\n\
13987 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
13988 being raised does not have a handler (and will therefore lead to the task's\n\
13989 termination).\n\
13990 Otherwise, the catchpoint only stops when the name of the exception being\n\
13991 raised is the same as ARG.\n\
13992 CONDITION is a boolean expression that is evaluated to see whether the\n\
13993 exception should cause a stop."),
13994                      catch_ada_exception_command,
13995                      catch_ada_completer,
13996                      CATCH_PERMANENT,
13997                      CATCH_TEMPORARY);
13998
13999   add_catch_command ("handlers", _("\
14000 Catch Ada exceptions, when handled.\n\
14001 Usage: catch handlers [ARG] [if CONDITION]\n\
14002 Without any argument, stop when any Ada exception is handled.\n\
14003 With an argument, catch only exceptions with the given name.\n\
14004 CONDITION is a boolean expression that is evaluated to see whether the\n\
14005 exception should cause a stop."),
14006                      catch_ada_handlers_command,
14007                      catch_ada_completer,
14008                      CATCH_PERMANENT,
14009                      CATCH_TEMPORARY);
14010   add_catch_command ("assert", _("\
14011 Catch failed Ada assertions, when raised.\n\
14012 Usage: catch assert [if CONDITION]\n\
14013 CONDITION is a boolean expression that is evaluated to see whether the\n\
14014 exception should cause a stop."),
14015                      catch_assert_command,
14016                      NULL,
14017                      CATCH_PERMANENT,
14018                      CATCH_TEMPORARY);
14019
14020   add_info ("exceptions", info_exceptions_command,
14021             _("\
14022 List all Ada exception names.\n\
14023 Usage: info exceptions [REGEXP]\n\
14024 If a regular expression is passed as an argument, only those matching\n\
14025 the regular expression are listed."));
14026
14027   add_setshow_prefix_cmd ("ada", class_maintenance,
14028                           _("Set Ada maintenance-related variables."),
14029                           _("Show Ada maintenance-related variables."),
14030                           &maint_set_ada_cmdlist, &maint_show_ada_cmdlist,
14031                           &maintenance_set_cmdlist, &maintenance_show_cmdlist);
14032
14033   add_setshow_boolean_cmd
14034     ("ignore-descriptive-types", class_maintenance,
14035      &ada_ignore_descriptive_types_p,
14036      _("Set whether descriptive types generated by GNAT should be ignored."),
14037      _("Show whether descriptive types generated by GNAT should be ignored."),
14038      _("\
14039 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14040 DWARF attribute."),
14041      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14042
14043   decoded_names_store = htab_create_alloc (256, htab_hash_string,
14044                                            htab_eq_string,
14045                                            NULL, xcalloc, xfree);
14046
14047   /* The ada-lang observers.  */
14048   gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
14049   gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
14050   gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");
14051 }
This page took 0.845378 seconds and 4 git commands to generate.