]> Git Repo - binutils.git/blob - gdb/ada-lang.c
gdb: add type::target_type / type::set_target_type
[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 registry<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 registry<program_space>::key<ada_pspace_data>
380   ada_pspace_data_handle;
381
382 /* Return this module's data for the given program space (PSPACE).
383    If not is found, add a zero'ed one now.
384
385    This function always returns a valid object.  */
386
387 static struct ada_pspace_data *
388 get_ada_pspace_data (struct program_space *pspace)
389 {
390   struct ada_pspace_data *data;
391
392   data = ada_pspace_data_handle.get (pspace);
393   if (data == NULL)
394     data = ada_pspace_data_handle.emplace (pspace);
395
396   return data;
397 }
398
399                         /* Utilities */
400
401 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
402    all typedef layers have been peeled.  Otherwise, return TYPE.
403
404    Normally, we really expect a typedef type to only have 1 typedef layer.
405    In other words, we really expect the target type of a typedef type to be
406    a non-typedef type.  This is particularly true for Ada units, because
407    the language does not have a typedef vs not-typedef distinction.
408    In that respect, the Ada compiler has been trying to eliminate as many
409    typedef definitions in the debugging information, since they generally
410    do not bring any extra information (we still use typedef under certain
411    circumstances related mostly to the GNAT encoding).
412
413    Unfortunately, we have seen situations where the debugging information
414    generated by the compiler leads to such multiple typedef layers.  For
415    instance, consider the following example with stabs:
416
417      .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
418      .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
419
420    This is an error in the debugging information which causes type
421    pck__float_array___XUP to be defined twice, and the second time,
422    it is defined as a typedef of a typedef.
423
424    This is on the fringe of legality as far as debugging information is
425    concerned, and certainly unexpected.  But it is easy to handle these
426    situations correctly, so we can afford to be lenient in this case.  */
427
428 static struct type *
429 ada_typedef_target_type (struct type *type)
430 {
431   while (type->code () == TYPE_CODE_TYPEDEF)
432     type = TYPE_TARGET_TYPE (type);
433   return type;
434 }
435
436 /* Given DECODED_NAME a string holding a symbol name in its
437    decoded form (ie using the Ada dotted notation), returns
438    its unqualified name.  */
439
440 static const char *
441 ada_unqualified_name (const char *decoded_name)
442 {
443   const char *result;
444   
445   /* If the decoded name starts with '<', it means that the encoded
446      name does not follow standard naming conventions, and thus that
447      it is not your typical Ada symbol name.  Trying to unqualify it
448      is therefore pointless and possibly erroneous.  */
449   if (decoded_name[0] == '<')
450     return decoded_name;
451
452   result = strrchr (decoded_name, '.');
453   if (result != NULL)
454     result++;                   /* Skip the dot...  */
455   else
456     result = decoded_name;
457
458   return result;
459 }
460
461 /* Return a string starting with '<', followed by STR, and '>'.  */
462
463 static std::string
464 add_angle_brackets (const char *str)
465 {
466   return string_printf ("<%s>", str);
467 }
468
469 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
470    suffix of FIELD_NAME beginning "___".  */
471
472 static int
473 field_name_match (const char *field_name, const char *target)
474 {
475   int len = strlen (target);
476
477   return
478     (strncmp (field_name, target, len) == 0
479      && (field_name[len] == '\0'
480          || (startswith (field_name + len, "___")
481              && strcmp (field_name + strlen (field_name) - 6,
482                         "___XVN") != 0)));
483 }
484
485
486 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
487    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
488    and return its index.  This function also handles fields whose name
489    have ___ suffixes because the compiler sometimes alters their name
490    by adding such a suffix to represent fields with certain constraints.
491    If the field could not be found, return a negative number if
492    MAYBE_MISSING is set.  Otherwise raise an error.  */
493
494 int
495 ada_get_field_index (const struct type *type, const char *field_name,
496                      int maybe_missing)
497 {
498   int fieldno;
499   struct type *struct_type = check_typedef ((struct type *) type);
500
501   for (fieldno = 0; fieldno < struct_type->num_fields (); fieldno++)
502     if (field_name_match (struct_type->field (fieldno).name (), field_name))
503       return fieldno;
504
505   if (!maybe_missing)
506     error (_("Unable to find field %s in struct %s.  Aborting"),
507            field_name, struct_type->name ());
508
509   return -1;
510 }
511
512 /* The length of the prefix of NAME prior to any "___" suffix.  */
513
514 int
515 ada_name_prefix_len (const char *name)
516 {
517   if (name == NULL)
518     return 0;
519   else
520     {
521       const char *p = strstr (name, "___");
522
523       if (p == NULL)
524         return strlen (name);
525       else
526         return p - name;
527     }
528 }
529
530 /* Return non-zero if SUFFIX is a suffix of STR.
531    Return zero if STR is null.  */
532
533 static int
534 is_suffix (const char *str, const char *suffix)
535 {
536   int len1, len2;
537
538   if (str == NULL)
539     return 0;
540   len1 = strlen (str);
541   len2 = strlen (suffix);
542   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
543 }
544
545 /* The contents of value VAL, treated as a value of type TYPE.  The
546    result is an lval in memory if VAL is.  */
547
548 static struct value *
549 coerce_unspec_val_to_type (struct value *val, struct type *type)
550 {
551   type = ada_check_typedef (type);
552   if (value_type (val) == type)
553     return val;
554   else
555     {
556       struct value *result;
557
558       if (value_optimized_out (val))
559         result = allocate_optimized_out_value (type);
560       else if (value_lazy (val)
561                /* Be careful not to make a lazy not_lval value.  */
562                || (VALUE_LVAL (val) != not_lval
563                    && TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val))))
564         result = allocate_value_lazy (type);
565       else
566         {
567           result = allocate_value (type);
568           value_contents_copy (result, 0, val, 0, TYPE_LENGTH (type));
569         }
570       set_value_component_location (result, val);
571       set_value_bitsize (result, value_bitsize (val));
572       set_value_bitpos (result, value_bitpos (val));
573       if (VALUE_LVAL (result) == lval_memory)
574         set_value_address (result, value_address (val));
575       return result;
576     }
577 }
578
579 static const gdb_byte *
580 cond_offset_host (const gdb_byte *valaddr, long offset)
581 {
582   if (valaddr == NULL)
583     return NULL;
584   else
585     return valaddr + offset;
586 }
587
588 static CORE_ADDR
589 cond_offset_target (CORE_ADDR address, long offset)
590 {
591   if (address == 0)
592     return 0;
593   else
594     return address + offset;
595 }
596
597 /* Issue a warning (as for the definition of warning in utils.c, but
598    with exactly one argument rather than ...), unless the limit on the
599    number of warnings has passed during the evaluation of the current
600    expression.  */
601
602 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
603    provided by "complaint".  */
604 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
605
606 static void
607 lim_warning (const char *format, ...)
608 {
609   va_list args;
610
611   va_start (args, format);
612   warnings_issued += 1;
613   if (warnings_issued <= warning_limit)
614     vwarning (format, args);
615
616   va_end (args);
617 }
618
619 /* Maximum value of a SIZE-byte signed integer type.  */
620 static LONGEST
621 max_of_size (int size)
622 {
623   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
624
625   return top_bit | (top_bit - 1);
626 }
627
628 /* Minimum value of a SIZE-byte signed integer type.  */
629 static LONGEST
630 min_of_size (int size)
631 {
632   return -max_of_size (size) - 1;
633 }
634
635 /* Maximum value of a SIZE-byte unsigned integer type.  */
636 static ULONGEST
637 umax_of_size (int size)
638 {
639   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
640
641   return top_bit | (top_bit - 1);
642 }
643
644 /* Maximum value of integral type T, as a signed quantity.  */
645 static LONGEST
646 max_of_type (struct type *t)
647 {
648   if (t->is_unsigned ())
649     return (LONGEST) umax_of_size (TYPE_LENGTH (t));
650   else
651     return max_of_size (TYPE_LENGTH (t));
652 }
653
654 /* Minimum value of integral type T, as a signed quantity.  */
655 static LONGEST
656 min_of_type (struct type *t)
657 {
658   if (t->is_unsigned ())
659     return 0;
660   else
661     return min_of_size (TYPE_LENGTH (t));
662 }
663
664 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
665 LONGEST
666 ada_discrete_type_high_bound (struct type *type)
667 {
668   type = resolve_dynamic_type (type, {}, 0);
669   switch (type->code ())
670     {
671     case TYPE_CODE_RANGE:
672       {
673         const dynamic_prop &high = type->bounds ()->high;
674
675         if (high.kind () == PROP_CONST)
676           return high.const_val ();
677         else
678           {
679             gdb_assert (high.kind () == PROP_UNDEFINED);
680
681             /* This happens when trying to evaluate a type's dynamic bound
682                without a live target.  There is nothing relevant for us to
683                return here, so return 0.  */
684             return 0;
685           }
686       }
687     case TYPE_CODE_ENUM:
688       return type->field (type->num_fields () - 1).loc_enumval ();
689     case TYPE_CODE_BOOL:
690       return 1;
691     case TYPE_CODE_CHAR:
692     case TYPE_CODE_INT:
693       return max_of_type (type);
694     default:
695       error (_("Unexpected type in ada_discrete_type_high_bound."));
696     }
697 }
698
699 /* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
700 LONGEST
701 ada_discrete_type_low_bound (struct type *type)
702 {
703   type = resolve_dynamic_type (type, {}, 0);
704   switch (type->code ())
705     {
706     case TYPE_CODE_RANGE:
707       {
708         const dynamic_prop &low = type->bounds ()->low;
709
710         if (low.kind () == PROP_CONST)
711           return low.const_val ();
712         else
713           {
714             gdb_assert (low.kind () == PROP_UNDEFINED);
715
716             /* This happens when trying to evaluate a type's dynamic bound
717                without a live target.  There is nothing relevant for us to
718                return here, so return 0.  */
719             return 0;
720           }
721       }
722     case TYPE_CODE_ENUM:
723       return type->field (0).loc_enumval ();
724     case TYPE_CODE_BOOL:
725       return 0;
726     case TYPE_CODE_CHAR:
727     case TYPE_CODE_INT:
728       return min_of_type (type);
729     default:
730       error (_("Unexpected type in ada_discrete_type_low_bound."));
731     }
732 }
733
734 /* The identity on non-range types.  For range types, the underlying
735    non-range scalar type.  */
736
737 static struct type *
738 get_base_type (struct type *type)
739 {
740   while (type != NULL && type->code () == TYPE_CODE_RANGE)
741     {
742       if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
743         return type;
744       type = TYPE_TARGET_TYPE (type);
745     }
746   return type;
747 }
748
749 /* Return a decoded version of the given VALUE.  This means returning
750    a value whose type is obtained by applying all the GNAT-specific
751    encodings, making the resulting type a static but standard description
752    of the initial type.  */
753
754 struct value *
755 ada_get_decoded_value (struct value *value)
756 {
757   struct type *type = ada_check_typedef (value_type (value));
758
759   if (ada_is_array_descriptor_type (type)
760       || (ada_is_constrained_packed_array_type (type)
761           && type->code () != TYPE_CODE_PTR))
762     {
763       if (type->code () == TYPE_CODE_TYPEDEF)  /* array access type.  */
764         value = ada_coerce_to_simple_array_ptr (value);
765       else
766         value = ada_coerce_to_simple_array (value);
767     }
768   else
769     value = ada_to_fixed_value (value);
770
771   return value;
772 }
773
774 /* Same as ada_get_decoded_value, but with the given TYPE.
775    Because there is no associated actual value for this type,
776    the resulting type might be a best-effort approximation in
777    the case of dynamic types.  */
778
779 struct type *
780 ada_get_decoded_type (struct type *type)
781 {
782   type = to_static_fixed_type (type);
783   if (ada_is_constrained_packed_array_type (type))
784     type = ada_coerce_to_simple_array_type (type);
785   return type;
786 }
787
788 \f
789
790                                 /* Language Selection */
791
792 /* If the main program is in Ada, return language_ada, otherwise return LANG
793    (the main program is in Ada iif the adainit symbol is found).  */
794
795 static enum language
796 ada_update_initial_language (enum language lang)
797 {
798   if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
799     return language_ada;
800
801   return lang;
802 }
803
804 /* If the main procedure is written in Ada, then return its name.
805    The result is good until the next call.  Return NULL if the main
806    procedure doesn't appear to be in Ada.  */
807
808 char *
809 ada_main_name (void)
810 {
811   struct bound_minimal_symbol msym;
812   static gdb::unique_xmalloc_ptr<char> main_program_name;
813
814   /* For Ada, the name of the main procedure is stored in a specific
815      string constant, generated by the binder.  Look for that symbol,
816      extract its address, and then read that string.  If we didn't find
817      that string, then most probably the main procedure is not written
818      in Ada.  */
819   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
820
821   if (msym.minsym != NULL)
822     {
823       CORE_ADDR main_program_name_addr = msym.value_address ();
824       if (main_program_name_addr == 0)
825         error (_("Invalid address for Ada main program name."));
826
827       main_program_name = target_read_string (main_program_name_addr, 1024);
828       return main_program_name.get ();
829     }
830
831   /* The main procedure doesn't seem to be in Ada.  */
832   return NULL;
833 }
834 \f
835                                 /* Symbols */
836
837 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
838    of NULLs.  */
839
840 const struct ada_opname_map ada_opname_table[] = {
841   {"Oadd", "\"+\"", BINOP_ADD},
842   {"Osubtract", "\"-\"", BINOP_SUB},
843   {"Omultiply", "\"*\"", BINOP_MUL},
844   {"Odivide", "\"/\"", BINOP_DIV},
845   {"Omod", "\"mod\"", BINOP_MOD},
846   {"Orem", "\"rem\"", BINOP_REM},
847   {"Oexpon", "\"**\"", BINOP_EXP},
848   {"Olt", "\"<\"", BINOP_LESS},
849   {"Ole", "\"<=\"", BINOP_LEQ},
850   {"Ogt", "\">\"", BINOP_GTR},
851   {"Oge", "\">=\"", BINOP_GEQ},
852   {"Oeq", "\"=\"", BINOP_EQUAL},
853   {"One", "\"/=\"", BINOP_NOTEQUAL},
854   {"Oand", "\"and\"", BINOP_BITWISE_AND},
855   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
856   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
857   {"Oconcat", "\"&\"", BINOP_CONCAT},
858   {"Oabs", "\"abs\"", UNOP_ABS},
859   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
860   {"Oadd", "\"+\"", UNOP_PLUS},
861   {"Osubtract", "\"-\"", UNOP_NEG},
862   {NULL, NULL}
863 };
864
865 /* If STR is a decoded version of a compiler-provided suffix (like the
866    "[cold]" in "symbol[cold]"), return true.  Otherwise, return
867    false.  */
868
869 static bool
870 is_compiler_suffix (const char *str)
871 {
872   gdb_assert (*str == '[');
873   ++str;
874   while (*str != '\0' && isalpha (*str))
875     ++str;
876   /* We accept a missing "]" in order to support completion.  */
877   return *str == '\0' || (str[0] == ']' && str[1] == '\0');
878 }
879
880 /* Append a non-ASCII character to RESULT.  */
881 static void
882 append_hex_encoded (std::string &result, uint32_t one_char)
883 {
884   if (one_char <= 0xff)
885     {
886       result.append ("U");
887       result.append (phex (one_char, 1));
888     }
889   else if (one_char <= 0xffff)
890     {
891       result.append ("W");
892       result.append (phex (one_char, 2));
893     }
894   else
895     {
896       result.append ("WW");
897       result.append (phex (one_char, 4));
898     }
899 }
900
901 /* Return a string that is a copy of the data in STORAGE, with
902    non-ASCII characters replaced by the appropriate hex encoding.  A
903    template is used because, for UTF-8, we actually want to work with
904    UTF-32 codepoints.  */
905 template<typename T>
906 std::string
907 copy_and_hex_encode (struct obstack *storage)
908 {
909   const T *chars = (T *) obstack_base (storage);
910   int num_chars = obstack_object_size (storage) / sizeof (T);
911   std::string result;
912   for (int i = 0; i < num_chars; ++i)
913     {
914       if (chars[i] <= 0x7f)
915         {
916           /* The host character set has to be a superset of ASCII, as
917              are all the other character sets we can use.  */
918           result.push_back (chars[i]);
919         }
920       else
921         append_hex_encoded (result, chars[i]);
922     }
923   return result;
924 }
925
926 /* The "encoded" form of DECODED, according to GNAT conventions.  If
927    THROW_ERRORS, throw an error if invalid operator name is found.
928    Otherwise, return the empty string in that case.  */
929
930 static std::string
931 ada_encode_1 (const char *decoded, bool throw_errors)
932 {
933   if (decoded == NULL)
934     return {};
935
936   std::string encoding_buffer;
937   bool saw_non_ascii = false;
938   for (const char *p = decoded; *p != '\0'; p += 1)
939     {
940       if ((*p & 0x80) != 0)
941         saw_non_ascii = true;
942
943       if (*p == '.')
944         encoding_buffer.append ("__");
945       else if (*p == '[' && is_compiler_suffix (p))
946         {
947           encoding_buffer = encoding_buffer + "." + (p + 1);
948           if (encoding_buffer.back () == ']')
949             encoding_buffer.pop_back ();
950           break;
951         }
952       else if (*p == '"')
953         {
954           const struct ada_opname_map *mapping;
955
956           for (mapping = ada_opname_table;
957                mapping->encoded != NULL
958                && !startswith (p, mapping->decoded); mapping += 1)
959             ;
960           if (mapping->encoded == NULL)
961             {
962               if (throw_errors)
963                 error (_("invalid Ada operator name: %s"), p);
964               else
965                 return {};
966             }
967           encoding_buffer.append (mapping->encoded);
968           break;
969         }
970       else
971         encoding_buffer.push_back (*p);
972     }
973
974   /* If a non-ASCII character is seen, we must convert it to the
975      appropriate hex form.  As this is more expensive, we keep track
976      of whether it is even necessary.  */
977   if (saw_non_ascii)
978     {
979       auto_obstack storage;
980       bool is_utf8 = ada_source_charset == ada_utf8;
981       try
982         {
983           convert_between_encodings
984             (host_charset (),
985              is_utf8 ? HOST_UTF32 : ada_source_charset,
986              (const gdb_byte *) encoding_buffer.c_str (),
987              encoding_buffer.length (), 1,
988              &storage, translit_none);
989         }
990       catch (const gdb_exception &)
991         {
992           static bool warned = false;
993
994           /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
995              might like to know why.  */
996           if (!warned)
997             {
998               warned = true;
999               warning (_("charset conversion failure for '%s'.\n"
1000                          "You may have the wrong value for 'set ada source-charset'."),
1001                        encoding_buffer.c_str ());
1002             }
1003
1004           /* We don't try to recover from errors.  */
1005           return encoding_buffer;
1006         }
1007
1008       if (is_utf8)
1009         return copy_and_hex_encode<uint32_t> (&storage);
1010       return copy_and_hex_encode<gdb_byte> (&storage);
1011     }
1012
1013   return encoding_buffer;
1014 }
1015
1016 /* Find the entry for C in the case-folding table.  Return nullptr if
1017    the entry does not cover C.  */
1018 static const utf8_entry *
1019 find_case_fold_entry (uint32_t c)
1020 {
1021   auto iter = std::lower_bound (std::begin (ada_case_fold),
1022                                 std::end (ada_case_fold),
1023                                 c);
1024   if (iter == std::end (ada_case_fold)
1025       || c < iter->start
1026       || c > iter->end)
1027     return nullptr;
1028   return &*iter;
1029 }
1030
1031 /* Return NAME folded to lower case, or, if surrounded by single
1032    quotes, unfolded, but with the quotes stripped away.  If
1033    THROW_ON_ERROR is true, encoding failures will throw an exception
1034    rather than emitting a warning.  Result good to next call.  */
1035
1036 static const char *
1037 ada_fold_name (gdb::string_view name, bool throw_on_error = false)
1038 {
1039   static std::string fold_storage;
1040
1041   if (!name.empty () && name[0] == '\'')
1042     fold_storage = gdb::to_string (name.substr (1, name.size () - 2));
1043   else
1044     {
1045       /* Why convert to UTF-32 and implement our own case-folding,
1046          rather than convert to wchar_t and use the platform's
1047          functions?  I'm glad you asked.
1048
1049          The main problem is that GNAT implements an unusual rule for
1050          case folding.  For ASCII letters, letters in single-byte
1051          encodings (such as ISO-8859-*), and Unicode letters that fit
1052          in a single byte (i.e., code point is <= 0xff), the letter is
1053          folded to lower case.  Other Unicode letters are folded to
1054          upper case.
1055
1056          This rule means that the code must be able to examine the
1057          value of the character.  And, some hosts do not use Unicode
1058          for wchar_t, so examining the value of such characters is
1059          forbidden.  */
1060       auto_obstack storage;
1061       try
1062         {
1063           convert_between_encodings
1064             (host_charset (), HOST_UTF32,
1065              (const gdb_byte *) name.data (),
1066              name.length (), 1,
1067              &storage, translit_none);
1068         }
1069       catch (const gdb_exception &)
1070         {
1071           if (throw_on_error)
1072             throw;
1073
1074           static bool warned = false;
1075
1076           /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
1077              might like to know why.  */
1078           if (!warned)
1079             {
1080               warned = true;
1081               warning (_("could not convert '%s' from the host encoding (%s) to UTF-32.\n"
1082                          "This normally should not happen, please file a bug report."),
1083                        gdb::to_string (name).c_str (), host_charset ());
1084             }
1085
1086           /* We don't try to recover from errors; just return the
1087              original string.  */
1088           fold_storage = gdb::to_string (name);
1089           return fold_storage.c_str ();
1090         }
1091
1092       bool is_utf8 = ada_source_charset == ada_utf8;
1093       uint32_t *chars = (uint32_t *) obstack_base (&storage);
1094       int num_chars = obstack_object_size (&storage) / sizeof (uint32_t);
1095       for (int i = 0; i < num_chars; ++i)
1096         {
1097           const struct utf8_entry *entry = find_case_fold_entry (chars[i]);
1098           if (entry != nullptr)
1099             {
1100               uint32_t low = chars[i] + entry->lower_delta;
1101               if (!is_utf8 || low <= 0xff)
1102                 chars[i] = low;
1103               else
1104                 chars[i] = chars[i] + entry->upper_delta;
1105             }
1106         }
1107
1108       /* Now convert back to ordinary characters.  */
1109       auto_obstack reconverted;
1110       try
1111         {
1112           convert_between_encodings (HOST_UTF32,
1113                                      host_charset (),
1114                                      (const gdb_byte *) chars,
1115                                      num_chars * sizeof (uint32_t),
1116                                      sizeof (uint32_t),
1117                                      &reconverted,
1118                                      translit_none);
1119           obstack_1grow (&reconverted, '\0');
1120           fold_storage = std::string ((const char *) obstack_base (&reconverted));
1121         }
1122       catch (const gdb_exception &)
1123         {
1124           if (throw_on_error)
1125             throw;
1126
1127           static bool warned = false;
1128
1129           /* Converting back from UTF-32 shouldn't normally fail, but
1130              there are some host encodings without upper/lower
1131              equivalence.  */
1132           if (!warned)
1133             {
1134               warned = true;
1135               warning (_("could not convert the lower-cased variant of '%s'\n"
1136                          "from UTF-32 to the host encoding (%s)."),
1137                        gdb::to_string (name).c_str (), host_charset ());
1138             }
1139
1140           /* We don't try to recover from errors; just return the
1141              original string.  */
1142           fold_storage = gdb::to_string (name);
1143         }
1144     }
1145
1146   return fold_storage.c_str ();
1147 }
1148
1149 /* The "encoded" form of DECODED, according to GNAT conventions.  */
1150
1151 std::string
1152 ada_encode (const char *decoded)
1153 {
1154   if (decoded[0] != '<')
1155     decoded = ada_fold_name (decoded);
1156   return ada_encode_1 (decoded, true);
1157 }
1158
1159 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
1160
1161 static int
1162 is_lower_alphanum (const char c)
1163 {
1164   return (isdigit (c) || (isalpha (c) && islower (c)));
1165 }
1166
1167 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1168    This function saves in LEN the length of that same symbol name but
1169    without either of these suffixes:
1170      . .{DIGIT}+
1171      . ${DIGIT}+
1172      . ___{DIGIT}+
1173      . __{DIGIT}+.
1174
1175    These are suffixes introduced by the compiler for entities such as
1176    nested subprogram for instance, in order to avoid name clashes.
1177    They do not serve any purpose for the debugger.  */
1178
1179 static void
1180 ada_remove_trailing_digits (const char *encoded, int *len)
1181 {
1182   if (*len > 1 && isdigit (encoded[*len - 1]))
1183     {
1184       int i = *len - 2;
1185
1186       while (i > 0 && isdigit (encoded[i]))
1187         i--;
1188       if (i >= 0 && encoded[i] == '.')
1189         *len = i;
1190       else if (i >= 0 && encoded[i] == '$')
1191         *len = i;
1192       else if (i >= 2 && startswith (encoded + i - 2, "___"))
1193         *len = i - 2;
1194       else if (i >= 1 && startswith (encoded + i - 1, "__"))
1195         *len = i - 1;
1196     }
1197 }
1198
1199 /* Remove the suffix introduced by the compiler for protected object
1200    subprograms.  */
1201
1202 static void
1203 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1204 {
1205   /* Remove trailing N.  */
1206
1207   /* Protected entry subprograms are broken into two
1208      separate subprograms: The first one is unprotected, and has
1209      a 'N' suffix; the second is the protected version, and has
1210      the 'P' suffix.  The second calls the first one after handling
1211      the protection.  Since the P subprograms are internally generated,
1212      we leave these names undecoded, giving the user a clue that this
1213      entity is internal.  */
1214
1215   if (*len > 1
1216       && encoded[*len - 1] == 'N'
1217       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1218     *len = *len - 1;
1219 }
1220
1221 /* If ENCODED ends with a compiler-provided suffix (like ".cold"),
1222    then update *LEN to remove the suffix and return the offset of the
1223    character just past the ".".  Otherwise, return -1.  */
1224
1225 static int
1226 remove_compiler_suffix (const char *encoded, int *len)
1227 {
1228   int offset = *len - 1;
1229   while (offset > 0 && isalpha (encoded[offset]))
1230     --offset;
1231   if (offset > 0 && encoded[offset] == '.')
1232     {
1233       *len = offset;
1234       return offset + 1;
1235     }
1236   return -1;
1237 }
1238
1239 /* Convert an ASCII hex string to a number.  Reads exactly N
1240    characters from STR.  Returns true on success, false if one of the
1241    digits was not a hex digit.  */
1242 static bool
1243 convert_hex (const char *str, int n, uint32_t *out)
1244 {
1245   uint32_t result = 0;
1246
1247   for (int i = 0; i < n; ++i)
1248     {
1249       if (!isxdigit (str[i]))
1250         return false;
1251       result <<= 4;
1252       result |= fromhex (str[i]);
1253     }
1254
1255   *out = result;
1256   return true;
1257 }
1258
1259 /* Convert a wide character from its ASCII hex representation in STR
1260    (consisting of exactly N characters) to the host encoding,
1261    appending the resulting bytes to OUT.  If N==2 and the Ada source
1262    charset is not UTF-8, then hex refers to an encoding in the
1263    ADA_SOURCE_CHARSET; otherwise, use UTF-32.  Return true on success.
1264    Return false and do not modify OUT on conversion failure.  */
1265 static bool
1266 convert_from_hex_encoded (std::string &out, const char *str, int n)
1267 {
1268   uint32_t value;
1269
1270   if (!convert_hex (str, n, &value))
1271     return false;
1272   try
1273     {
1274       auto_obstack bytes;
1275       /* In the 'U' case, the hex digits encode the character in the
1276          Ada source charset.  However, if the source charset is UTF-8,
1277          this really means it is a single-byte UTF-32 character.  */
1278       if (n == 2 && ada_source_charset != ada_utf8)
1279         {
1280           gdb_byte one_char = (gdb_byte) value;
1281
1282           convert_between_encodings (ada_source_charset, host_charset (),
1283                                      &one_char,
1284                                      sizeof (one_char), sizeof (one_char),
1285                                      &bytes, translit_none);
1286         }
1287       else
1288         convert_between_encodings (HOST_UTF32, host_charset (),
1289                                    (const gdb_byte *) &value,
1290                                    sizeof (value), sizeof (value),
1291                                    &bytes, translit_none);
1292       obstack_1grow (&bytes, '\0');
1293       out.append ((const char *) obstack_base (&bytes));
1294     }
1295   catch (const gdb_exception &)
1296     {
1297       /* On failure, the caller will just let the encoded form
1298          through, which seems basically reasonable.  */
1299       return false;
1300     }
1301
1302   return true;
1303 }
1304
1305 /* See ada-lang.h.  */
1306
1307 std::string
1308 ada_decode (const char *encoded, bool wrap, bool operators)
1309 {
1310   int i;
1311   int len0;
1312   const char *p;
1313   int at_start_name;
1314   std::string decoded;
1315   int suffix = -1;
1316
1317   /* With function descriptors on PPC64, the value of a symbol named
1318      ".FN", if it exists, is the entry point of the function "FN".  */
1319   if (encoded[0] == '.')
1320     encoded += 1;
1321
1322   /* The name of the Ada main procedure starts with "_ada_".
1323      This prefix is not part of the decoded name, so skip this part
1324      if we see this prefix.  */
1325   if (startswith (encoded, "_ada_"))
1326     encoded += 5;
1327   /* The "___ghost_" prefix is used for ghost entities.  Normally
1328      these aren't preserved but when they are, it's useful to see
1329      them.  */
1330   if (startswith (encoded, "___ghost_"))
1331     encoded += 9;
1332
1333   /* If the name starts with '_', then it is not a properly encoded
1334      name, so do not attempt to decode it.  Similarly, if the name
1335      starts with '<', the name should not be decoded.  */
1336   if (encoded[0] == '_' || encoded[0] == '<')
1337     goto Suppress;
1338
1339   len0 = strlen (encoded);
1340
1341   suffix = remove_compiler_suffix (encoded, &len0);
1342
1343   ada_remove_trailing_digits (encoded, &len0);
1344   ada_remove_po_subprogram_suffix (encoded, &len0);
1345
1346   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1347      the suffix is located before the current "end" of ENCODED.  We want
1348      to avoid re-matching parts of ENCODED that have previously been
1349      marked as discarded (by decrementing LEN0).  */
1350   p = strstr (encoded, "___");
1351   if (p != NULL && p - encoded < len0 - 3)
1352     {
1353       if (p[3] == 'X')
1354         len0 = p - encoded;
1355       else
1356         goto Suppress;
1357     }
1358
1359   /* Remove any trailing TKB suffix.  It tells us that this symbol
1360      is for the body of a task, but that information does not actually
1361      appear in the decoded name.  */
1362
1363   if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1364     len0 -= 3;
1365
1366   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1367      from the TKB suffix because it is used for non-anonymous task
1368      bodies.  */
1369
1370   if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1371     len0 -= 2;
1372
1373   /* Remove trailing "B" suffixes.  */
1374   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1375
1376   if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1377     len0 -= 1;
1378
1379   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1380
1381   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1382     {
1383       i = len0 - 2;
1384       while ((i >= 0 && isdigit (encoded[i]))
1385              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1386         i -= 1;
1387       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1388         len0 = i - 1;
1389       else if (encoded[i] == '$')
1390         len0 = i;
1391     }
1392
1393   /* The first few characters that are not alphabetic are not part
1394      of any encoding we use, so we can copy them over verbatim.  */
1395
1396   for (i = 0; i < len0 && !isalpha (encoded[i]); i += 1)
1397     decoded.push_back (encoded[i]);
1398
1399   at_start_name = 1;
1400   while (i < len0)
1401     {
1402       /* Is this a symbol function?  */
1403       if (operators && at_start_name && encoded[i] == 'O')
1404         {
1405           int k;
1406
1407           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1408             {
1409               int op_len = strlen (ada_opname_table[k].encoded);
1410               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1411                             op_len - 1) == 0)
1412                   && !isalnum (encoded[i + op_len]))
1413                 {
1414                   decoded.append (ada_opname_table[k].decoded);
1415                   at_start_name = 0;
1416                   i += op_len;
1417                   break;
1418                 }
1419             }
1420           if (ada_opname_table[k].encoded != NULL)
1421             continue;
1422         }
1423       at_start_name = 0;
1424
1425       /* Replace "TK__" with "__", which will eventually be translated
1426          into "." (just below).  */
1427
1428       if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1429         i += 2;
1430
1431       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1432          be translated into "." (just below).  These are internal names
1433          generated for anonymous blocks inside which our symbol is nested.  */
1434
1435       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1436           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1437           && isdigit (encoded [i+4]))
1438         {
1439           int k = i + 5;
1440           
1441           while (k < len0 && isdigit (encoded[k]))
1442             k++;  /* Skip any extra digit.  */
1443
1444           /* Double-check that the "__B_{DIGITS}+" sequence we found
1445              is indeed followed by "__".  */
1446           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1447             i = k;
1448         }
1449
1450       /* Remove _E{DIGITS}+[sb] */
1451
1452       /* Just as for protected object subprograms, there are 2 categories
1453          of subprograms created by the compiler for each entry.  The first
1454          one implements the actual entry code, and has a suffix following
1455          the convention above; the second one implements the barrier and
1456          uses the same convention as above, except that the 'E' is replaced
1457          by a 'B'.
1458
1459          Just as above, we do not decode the name of barrier functions
1460          to give the user a clue that the code he is debugging has been
1461          internally generated.  */
1462
1463       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1464           && isdigit (encoded[i+2]))
1465         {
1466           int k = i + 3;
1467
1468           while (k < len0 && isdigit (encoded[k]))
1469             k++;
1470
1471           if (k < len0
1472               && (encoded[k] == 'b' || encoded[k] == 's'))
1473             {
1474               k++;
1475               /* Just as an extra precaution, make sure that if this
1476                  suffix is followed by anything else, it is a '_'.
1477                  Otherwise, we matched this sequence by accident.  */
1478               if (k == len0
1479                   || (k < len0 && encoded[k] == '_'))
1480                 i = k;
1481             }
1482         }
1483
1484       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1485          the GNAT front-end in protected object subprograms.  */
1486
1487       if (i < len0 + 3
1488           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1489         {
1490           /* Backtrack a bit up until we reach either the begining of
1491              the encoded name, or "__".  Make sure that we only find
1492              digits or lowercase characters.  */
1493           const char *ptr = encoded + i - 1;
1494
1495           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1496             ptr--;
1497           if (ptr < encoded
1498               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1499             i++;
1500         }
1501
1502       if (i < len0 + 3 && encoded[i] == 'U' && isxdigit (encoded[i + 1]))
1503         {
1504           if (convert_from_hex_encoded (decoded, &encoded[i + 1], 2))
1505             {
1506               i += 3;
1507               continue;
1508             }
1509         }
1510       else if (i < len0 + 5 && encoded[i] == 'W' && isxdigit (encoded[i + 1]))
1511         {
1512           if (convert_from_hex_encoded (decoded, &encoded[i + 1], 4))
1513             {
1514               i += 5;
1515               continue;
1516             }
1517         }
1518       else if (i < len0 + 10 && encoded[i] == 'W' && encoded[i + 1] == 'W'
1519                && isxdigit (encoded[i + 2]))
1520         {
1521           if (convert_from_hex_encoded (decoded, &encoded[i + 2], 8))
1522             {
1523               i += 10;
1524               continue;
1525             }
1526         }
1527
1528       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1529         {
1530           /* This is a X[bn]* sequence not separated from the previous
1531              part of the name with a non-alpha-numeric character (in other
1532              words, immediately following an alpha-numeric character), then
1533              verify that it is placed at the end of the encoded name.  If
1534              not, then the encoding is not valid and we should abort the
1535              decoding.  Otherwise, just skip it, it is used in body-nested
1536              package names.  */
1537           do
1538             i += 1;
1539           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1540           if (i < len0)
1541             goto Suppress;
1542         }
1543       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1544         {
1545          /* Replace '__' by '.'.  */
1546           decoded.push_back ('.');
1547           at_start_name = 1;
1548           i += 2;
1549         }
1550       else
1551         {
1552           /* It's a character part of the decoded name, so just copy it
1553              over.  */
1554           decoded.push_back (encoded[i]);
1555           i += 1;
1556         }
1557     }
1558
1559   /* Decoded names should never contain any uppercase character.
1560      Double-check this, and abort the decoding if we find one.  */
1561
1562   if (operators)
1563     {
1564       for (i = 0; i < decoded.length(); ++i)
1565         if (isupper (decoded[i]) || decoded[i] == ' ')
1566           goto Suppress;
1567     }
1568
1569   /* If the compiler added a suffix, append it now.  */
1570   if (suffix >= 0)
1571     decoded = decoded + "[" + &encoded[suffix] + "]";
1572
1573   return decoded;
1574
1575 Suppress:
1576   if (!wrap)
1577     return {};
1578
1579   if (encoded[0] == '<')
1580     decoded = encoded;
1581   else
1582     decoded = '<' + std::string(encoded) + '>';
1583   return decoded;
1584 }
1585
1586 /* Table for keeping permanent unique copies of decoded names.  Once
1587    allocated, names in this table are never released.  While this is a
1588    storage leak, it should not be significant unless there are massive
1589    changes in the set of decoded names in successive versions of a 
1590    symbol table loaded during a single session.  */
1591 static struct htab *decoded_names_store;
1592
1593 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1594    in the language-specific part of GSYMBOL, if it has not been
1595    previously computed.  Tries to save the decoded name in the same
1596    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1597    in any case, the decoded symbol has a lifetime at least that of
1598    GSYMBOL).
1599    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1600    const, but nevertheless modified to a semantically equivalent form
1601    when a decoded name is cached in it.  */
1602
1603 const char *
1604 ada_decode_symbol (const struct general_symbol_info *arg)
1605 {
1606   struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1607   const char **resultp =
1608     &gsymbol->language_specific.demangled_name;
1609
1610   if (!gsymbol->ada_mangled)
1611     {
1612       std::string decoded = ada_decode (gsymbol->linkage_name ());
1613       struct obstack *obstack = gsymbol->language_specific.obstack;
1614
1615       gsymbol->ada_mangled = 1;
1616
1617       if (obstack != NULL)
1618         *resultp = obstack_strdup (obstack, decoded.c_str ());
1619       else
1620         {
1621           /* Sometimes, we can't find a corresponding objfile, in
1622              which case, we put the result on the heap.  Since we only
1623              decode when needed, we hope this usually does not cause a
1624              significant memory leak (FIXME).  */
1625
1626           char **slot = (char **) htab_find_slot (decoded_names_store,
1627                                                   decoded.c_str (), INSERT);
1628
1629           if (*slot == NULL)
1630             *slot = xstrdup (decoded.c_str ());
1631           *resultp = *slot;
1632         }
1633     }
1634
1635   return *resultp;
1636 }
1637
1638 \f
1639
1640                                 /* Arrays */
1641
1642 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1643    generated by the GNAT compiler to describe the index type used
1644    for each dimension of an array, check whether it follows the latest
1645    known encoding.  If not, fix it up to conform to the latest encoding.
1646    Otherwise, do nothing.  This function also does nothing if
1647    INDEX_DESC_TYPE is NULL.
1648
1649    The GNAT encoding used to describe the array index type evolved a bit.
1650    Initially, the information would be provided through the name of each
1651    field of the structure type only, while the type of these fields was
1652    described as unspecified and irrelevant.  The debugger was then expected
1653    to perform a global type lookup using the name of that field in order
1654    to get access to the full index type description.  Because these global
1655    lookups can be very expensive, the encoding was later enhanced to make
1656    the global lookup unnecessary by defining the field type as being
1657    the full index type description.
1658
1659    The purpose of this routine is to allow us to support older versions
1660    of the compiler by detecting the use of the older encoding, and by
1661    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1662    we essentially replace each field's meaningless type by the associated
1663    index subtype).  */
1664
1665 void
1666 ada_fixup_array_indexes_type (struct type *index_desc_type)
1667 {
1668   int i;
1669
1670   if (index_desc_type == NULL)
1671     return;
1672   gdb_assert (index_desc_type->num_fields () > 0);
1673
1674   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1675      to check one field only, no need to check them all).  If not, return
1676      now.
1677
1678      If our INDEX_DESC_TYPE was generated using the older encoding,
1679      the field type should be a meaningless integer type whose name
1680      is not equal to the field name.  */
1681   if (index_desc_type->field (0).type ()->name () != NULL
1682       && strcmp (index_desc_type->field (0).type ()->name (),
1683                  index_desc_type->field (0).name ()) == 0)
1684     return;
1685
1686   /* Fixup each field of INDEX_DESC_TYPE.  */
1687   for (i = 0; i < index_desc_type->num_fields (); i++)
1688    {
1689      const char *name = index_desc_type->field (i).name ();
1690      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1691
1692      if (raw_type)
1693        index_desc_type->field (i).set_type (raw_type);
1694    }
1695 }
1696
1697 /* The desc_* routines return primitive portions of array descriptors
1698    (fat pointers).  */
1699
1700 /* The descriptor or array type, if any, indicated by TYPE; removes
1701    level of indirection, if needed.  */
1702
1703 static struct type *
1704 desc_base_type (struct type *type)
1705 {
1706   if (type == NULL)
1707     return NULL;
1708   type = ada_check_typedef (type);
1709   if (type->code () == TYPE_CODE_TYPEDEF)
1710     type = ada_typedef_target_type (type);
1711
1712   if (type != NULL
1713       && (type->code () == TYPE_CODE_PTR
1714           || type->code () == TYPE_CODE_REF))
1715     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1716   else
1717     return type;
1718 }
1719
1720 /* True iff TYPE indicates a "thin" array pointer type.  */
1721
1722 static int
1723 is_thin_pntr (struct type *type)
1724 {
1725   return
1726     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1727     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1728 }
1729
1730 /* The descriptor type for thin pointer type TYPE.  */
1731
1732 static struct type *
1733 thin_descriptor_type (struct type *type)
1734 {
1735   struct type *base_type = desc_base_type (type);
1736
1737   if (base_type == NULL)
1738     return NULL;
1739   if (is_suffix (ada_type_name (base_type), "___XVE"))
1740     return base_type;
1741   else
1742     {
1743       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1744
1745       if (alt_type == NULL)
1746         return base_type;
1747       else
1748         return alt_type;
1749     }
1750 }
1751
1752 /* A pointer to the array data for thin-pointer value VAL.  */
1753
1754 static struct value *
1755 thin_data_pntr (struct value *val)
1756 {
1757   struct type *type = ada_check_typedef (value_type (val));
1758   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1759
1760   data_type = lookup_pointer_type (data_type);
1761
1762   if (type->code () == TYPE_CODE_PTR)
1763     return value_cast (data_type, value_copy (val));
1764   else
1765     return value_from_longest (data_type, value_address (val));
1766 }
1767
1768 /* True iff TYPE indicates a "thick" array pointer type.  */
1769
1770 static int
1771 is_thick_pntr (struct type *type)
1772 {
1773   type = desc_base_type (type);
1774   return (type != NULL && type->code () == TYPE_CODE_STRUCT
1775           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1776 }
1777
1778 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1779    pointer to one, the type of its bounds data; otherwise, NULL.  */
1780
1781 static struct type *
1782 desc_bounds_type (struct type *type)
1783 {
1784   struct type *r;
1785
1786   type = desc_base_type (type);
1787
1788   if (type == NULL)
1789     return NULL;
1790   else if (is_thin_pntr (type))
1791     {
1792       type = thin_descriptor_type (type);
1793       if (type == NULL)
1794         return NULL;
1795       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1796       if (r != NULL)
1797         return ada_check_typedef (r);
1798     }
1799   else if (type->code () == TYPE_CODE_STRUCT)
1800     {
1801       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1802       if (r != NULL)
1803         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1804     }
1805   return NULL;
1806 }
1807
1808 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1809    one, a pointer to its bounds data.   Otherwise NULL.  */
1810
1811 static struct value *
1812 desc_bounds (struct value *arr)
1813 {
1814   struct type *type = ada_check_typedef (value_type (arr));
1815
1816   if (is_thin_pntr (type))
1817     {
1818       struct type *bounds_type =
1819         desc_bounds_type (thin_descriptor_type (type));
1820       LONGEST addr;
1821
1822       if (bounds_type == NULL)
1823         error (_("Bad GNAT array descriptor"));
1824
1825       /* NOTE: The following calculation is not really kosher, but
1826          since desc_type is an XVE-encoded type (and shouldn't be),
1827          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1828       if (type->code () == TYPE_CODE_PTR)
1829         addr = value_as_long (arr);
1830       else
1831         addr = value_address (arr);
1832
1833       return
1834         value_from_longest (lookup_pointer_type (bounds_type),
1835                             addr - TYPE_LENGTH (bounds_type));
1836     }
1837
1838   else if (is_thick_pntr (type))
1839     {
1840       struct value *p_bounds = value_struct_elt (&arr, {}, "P_BOUNDS", NULL,
1841                                                _("Bad GNAT array descriptor"));
1842       struct type *p_bounds_type = value_type (p_bounds);
1843
1844       if (p_bounds_type
1845           && p_bounds_type->code () == TYPE_CODE_PTR)
1846         {
1847           struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1848
1849           if (target_type->is_stub ())
1850             p_bounds = value_cast (lookup_pointer_type
1851                                    (ada_check_typedef (target_type)),
1852                                    p_bounds);
1853         }
1854       else
1855         error (_("Bad GNAT array descriptor"));
1856
1857       return p_bounds;
1858     }
1859   else
1860     return NULL;
1861 }
1862
1863 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1864    position of the field containing the address of the bounds data.  */
1865
1866 static int
1867 fat_pntr_bounds_bitpos (struct type *type)
1868 {
1869   return desc_base_type (type)->field (1).loc_bitpos ();
1870 }
1871
1872 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1873    size of the field containing the address of the bounds data.  */
1874
1875 static int
1876 fat_pntr_bounds_bitsize (struct type *type)
1877 {
1878   type = desc_base_type (type);
1879
1880   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1881     return TYPE_FIELD_BITSIZE (type, 1);
1882   else
1883     return 8 * TYPE_LENGTH (ada_check_typedef (type->field (1).type ()));
1884 }
1885
1886 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1887    pointer to one, the type of its array data (a array-with-no-bounds type);
1888    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1889    data.  */
1890
1891 static struct type *
1892 desc_data_target_type (struct type *type)
1893 {
1894   type = desc_base_type (type);
1895
1896   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1897   if (is_thin_pntr (type))
1898     return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1899   else if (is_thick_pntr (type))
1900     {
1901       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1902
1903       if (data_type
1904           && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1905         return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1906     }
1907
1908   return NULL;
1909 }
1910
1911 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1912    its array data.  */
1913
1914 static struct value *
1915 desc_data (struct value *arr)
1916 {
1917   struct type *type = value_type (arr);
1918
1919   if (is_thin_pntr (type))
1920     return thin_data_pntr (arr);
1921   else if (is_thick_pntr (type))
1922     return value_struct_elt (&arr, {}, "P_ARRAY", NULL,
1923                              _("Bad GNAT array descriptor"));
1924   else
1925     return NULL;
1926 }
1927
1928
1929 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1930    position of the field containing the address of the data.  */
1931
1932 static int
1933 fat_pntr_data_bitpos (struct type *type)
1934 {
1935   return desc_base_type (type)->field (0).loc_bitpos ();
1936 }
1937
1938 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1939    size of the field containing the address of the data.  */
1940
1941 static int
1942 fat_pntr_data_bitsize (struct type *type)
1943 {
1944   type = desc_base_type (type);
1945
1946   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1947     return TYPE_FIELD_BITSIZE (type, 0);
1948   else
1949     return TARGET_CHAR_BIT * TYPE_LENGTH (type->field (0).type ());
1950 }
1951
1952 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1953    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1954    bound, if WHICH is 1.  The first bound is I=1.  */
1955
1956 static struct value *
1957 desc_one_bound (struct value *bounds, int i, int which)
1958 {
1959   char bound_name[20];
1960   xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1961              which ? 'U' : 'L', i - 1);
1962   return value_struct_elt (&bounds, {}, bound_name, NULL,
1963                            _("Bad GNAT array descriptor bounds"));
1964 }
1965
1966 /* If BOUNDS is an array-bounds structure type, return the bit position
1967    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1968    bound, if WHICH is 1.  The first bound is I=1.  */
1969
1970 static int
1971 desc_bound_bitpos (struct type *type, int i, int which)
1972 {
1973   return desc_base_type (type)->field (2 * i + which - 2).loc_bitpos ();
1974 }
1975
1976 /* If BOUNDS is an array-bounds structure type, return the bit field size
1977    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1978    bound, if WHICH is 1.  The first bound is I=1.  */
1979
1980 static int
1981 desc_bound_bitsize (struct type *type, int i, int which)
1982 {
1983   type = desc_base_type (type);
1984
1985   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1986     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1987   else
1988     return 8 * TYPE_LENGTH (type->field (2 * i + which - 2).type ());
1989 }
1990
1991 /* If TYPE is the type of an array-bounds structure, the type of its
1992    Ith bound (numbering from 1).  Otherwise, NULL.  */
1993
1994 static struct type *
1995 desc_index_type (struct type *type, int i)
1996 {
1997   type = desc_base_type (type);
1998
1999   if (type->code () == TYPE_CODE_STRUCT)
2000     {
2001       char bound_name[20];
2002       xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
2003       return lookup_struct_elt_type (type, bound_name, 1);
2004     }
2005   else
2006     return NULL;
2007 }
2008
2009 /* The number of index positions in the array-bounds type TYPE.
2010    Return 0 if TYPE is NULL.  */
2011
2012 static int
2013 desc_arity (struct type *type)
2014 {
2015   type = desc_base_type (type);
2016
2017   if (type != NULL)
2018     return type->num_fields () / 2;
2019   return 0;
2020 }
2021
2022 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
2023    an array descriptor type (representing an unconstrained array
2024    type).  */
2025
2026 static int
2027 ada_is_direct_array_type (struct type *type)
2028 {
2029   if (type == NULL)
2030     return 0;
2031   type = ada_check_typedef (type);
2032   return (type->code () == TYPE_CODE_ARRAY
2033           || ada_is_array_descriptor_type (type));
2034 }
2035
2036 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
2037  * to one.  */
2038
2039 static int
2040 ada_is_array_type (struct type *type)
2041 {
2042   while (type != NULL
2043          && (type->code () == TYPE_CODE_PTR
2044              || type->code () == TYPE_CODE_REF))
2045     type = TYPE_TARGET_TYPE (type);
2046   return ada_is_direct_array_type (type);
2047 }
2048
2049 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
2050
2051 int
2052 ada_is_simple_array_type (struct type *type)
2053 {
2054   if (type == NULL)
2055     return 0;
2056   type = ada_check_typedef (type);
2057   return (type->code () == TYPE_CODE_ARRAY
2058           || (type->code () == TYPE_CODE_PTR
2059               && (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ()
2060                   == TYPE_CODE_ARRAY)));
2061 }
2062
2063 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
2064
2065 int
2066 ada_is_array_descriptor_type (struct type *type)
2067 {
2068   struct type *data_type = desc_data_target_type (type);
2069
2070   if (type == NULL)
2071     return 0;
2072   type = ada_check_typedef (type);
2073   return (data_type != NULL
2074           && data_type->code () == TYPE_CODE_ARRAY
2075           && desc_arity (desc_bounds_type (type)) > 0);
2076 }
2077
2078 /* Non-zero iff type is a partially mal-formed GNAT array
2079    descriptor.  FIXME: This is to compensate for some problems with
2080    debugging output from GNAT.  Re-examine periodically to see if it
2081    is still needed.  */
2082
2083 int
2084 ada_is_bogus_array_descriptor (struct type *type)
2085 {
2086   return
2087     type != NULL
2088     && type->code () == TYPE_CODE_STRUCT
2089     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
2090         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
2091     && !ada_is_array_descriptor_type (type);
2092 }
2093
2094
2095 /* If ARR has a record type in the form of a standard GNAT array descriptor,
2096    (fat pointer) returns the type of the array data described---specifically,
2097    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
2098    in from the descriptor; otherwise, they are left unspecified.  If
2099    the ARR denotes a null array descriptor and BOUNDS is non-zero,
2100    returns NULL.  The result is simply the type of ARR if ARR is not
2101    a descriptor.  */
2102
2103 static struct type *
2104 ada_type_of_array (struct value *arr, int bounds)
2105 {
2106   if (ada_is_constrained_packed_array_type (value_type (arr)))
2107     return decode_constrained_packed_array_type (value_type (arr));
2108
2109   if (!ada_is_array_descriptor_type (value_type (arr)))
2110     return value_type (arr);
2111
2112   if (!bounds)
2113     {
2114       struct type *array_type =
2115         ada_check_typedef (desc_data_target_type (value_type (arr)));
2116
2117       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2118         TYPE_FIELD_BITSIZE (array_type, 0) =
2119           decode_packed_array_bitsize (value_type (arr));
2120       
2121       return array_type;
2122     }
2123   else
2124     {
2125       struct type *elt_type;
2126       int arity;
2127       struct value *descriptor;
2128
2129       elt_type = ada_array_element_type (value_type (arr), -1);
2130       arity = ada_array_arity (value_type (arr));
2131
2132       if (elt_type == NULL || arity == 0)
2133         return ada_check_typedef (value_type (arr));
2134
2135       descriptor = desc_bounds (arr);
2136       if (value_as_long (descriptor) == 0)
2137         return NULL;
2138       while (arity > 0)
2139         {
2140           struct type *range_type = alloc_type_copy (value_type (arr));
2141           struct type *array_type = alloc_type_copy (value_type (arr));
2142           struct value *low = desc_one_bound (descriptor, arity, 0);
2143           struct value *high = desc_one_bound (descriptor, arity, 1);
2144
2145           arity -= 1;
2146           create_static_range_type (range_type, value_type (low),
2147                                     longest_to_int (value_as_long (low)),
2148                                     longest_to_int (value_as_long (high)));
2149           elt_type = create_array_type (array_type, elt_type, range_type);
2150
2151           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2152             {
2153               /* We need to store the element packed bitsize, as well as
2154                  recompute the array size, because it was previously
2155                  computed based on the unpacked element size.  */
2156               LONGEST lo = value_as_long (low);
2157               LONGEST hi = value_as_long (high);
2158
2159               TYPE_FIELD_BITSIZE (elt_type, 0) =
2160                 decode_packed_array_bitsize (value_type (arr));
2161               /* If the array has no element, then the size is already
2162                  zero, and does not need to be recomputed.  */
2163               if (lo < hi)
2164                 {
2165                   int array_bitsize =
2166                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2167
2168                   TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2169                 }
2170             }
2171         }
2172
2173       return lookup_pointer_type (elt_type);
2174     }
2175 }
2176
2177 /* If ARR does not represent an array, returns ARR unchanged.
2178    Otherwise, returns either a standard GDB array with bounds set
2179    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2180    GDB array.  Returns NULL if ARR is a null fat pointer.  */
2181
2182 struct value *
2183 ada_coerce_to_simple_array_ptr (struct value *arr)
2184 {
2185   if (ada_is_array_descriptor_type (value_type (arr)))
2186     {
2187       struct type *arrType = ada_type_of_array (arr, 1);
2188
2189       if (arrType == NULL)
2190         return NULL;
2191       return value_cast (arrType, value_copy (desc_data (arr)));
2192     }
2193   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2194     return decode_constrained_packed_array (arr);
2195   else
2196     return arr;
2197 }
2198
2199 /* If ARR does not represent an array, returns ARR unchanged.
2200    Otherwise, returns a standard GDB array describing ARR (which may
2201    be ARR itself if it already is in the proper form).  */
2202
2203 struct value *
2204 ada_coerce_to_simple_array (struct value *arr)
2205 {
2206   if (ada_is_array_descriptor_type (value_type (arr)))
2207     {
2208       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2209
2210       if (arrVal == NULL)
2211         error (_("Bounds unavailable for null array pointer."));
2212       return value_ind (arrVal);
2213     }
2214   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2215     return decode_constrained_packed_array (arr);
2216   else
2217     return arr;
2218 }
2219
2220 /* If TYPE represents a GNAT array type, return it translated to an
2221    ordinary GDB array type (possibly with BITSIZE fields indicating
2222    packing).  For other types, is the identity.  */
2223
2224 struct type *
2225 ada_coerce_to_simple_array_type (struct type *type)
2226 {
2227   if (ada_is_constrained_packed_array_type (type))
2228     return decode_constrained_packed_array_type (type);
2229
2230   if (ada_is_array_descriptor_type (type))
2231     return ada_check_typedef (desc_data_target_type (type));
2232
2233   return type;
2234 }
2235
2236 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
2237
2238 static int
2239 ada_is_gnat_encoded_packed_array_type  (struct type *type)
2240 {
2241   if (type == NULL)
2242     return 0;
2243   type = desc_base_type (type);
2244   type = ada_check_typedef (type);
2245   return
2246     ada_type_name (type) != NULL
2247     && strstr (ada_type_name (type), "___XP") != NULL;
2248 }
2249
2250 /* Non-zero iff TYPE represents a standard GNAT constrained
2251    packed-array type.  */
2252
2253 int
2254 ada_is_constrained_packed_array_type (struct type *type)
2255 {
2256   return ada_is_gnat_encoded_packed_array_type (type)
2257     && !ada_is_array_descriptor_type (type);
2258 }
2259
2260 /* Non-zero iff TYPE represents an array descriptor for a
2261    unconstrained packed-array type.  */
2262
2263 static int
2264 ada_is_unconstrained_packed_array_type (struct type *type)
2265 {
2266   if (!ada_is_array_descriptor_type (type))
2267     return 0;
2268
2269   if (ada_is_gnat_encoded_packed_array_type (type))
2270     return 1;
2271
2272   /* If we saw GNAT encodings, then the above code is sufficient.
2273      However, with minimal encodings, we will just have a thick
2274      pointer instead.  */
2275   if (is_thick_pntr (type))
2276     {
2277       type = desc_base_type (type);
2278       /* The structure's first field is a pointer to an array, so this
2279          fetches the array type.  */
2280       type = TYPE_TARGET_TYPE (type->field (0).type ());
2281       if (type->code () == TYPE_CODE_TYPEDEF)
2282         type = ada_typedef_target_type (type);
2283       /* Now we can see if the array elements are packed.  */
2284       return TYPE_FIELD_BITSIZE (type, 0) > 0;
2285     }
2286
2287   return 0;
2288 }
2289
2290 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
2291    type, or if it is an ordinary (non-Gnat-encoded) packed array.  */
2292
2293 static bool
2294 ada_is_any_packed_array_type (struct type *type)
2295 {
2296   return (ada_is_constrained_packed_array_type (type)
2297           || (type->code () == TYPE_CODE_ARRAY
2298               && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
2299 }
2300
2301 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2302    return the size of its elements in bits.  */
2303
2304 static long
2305 decode_packed_array_bitsize (struct type *type)
2306 {
2307   const char *raw_name;
2308   const char *tail;
2309   long bits;
2310
2311   /* Access to arrays implemented as fat pointers are encoded as a typedef
2312      of the fat pointer type.  We need the name of the fat pointer type
2313      to do the decoding, so strip the typedef layer.  */
2314   if (type->code () == TYPE_CODE_TYPEDEF)
2315     type = ada_typedef_target_type (type);
2316
2317   raw_name = ada_type_name (ada_check_typedef (type));
2318   if (!raw_name)
2319     raw_name = ada_type_name (desc_base_type (type));
2320
2321   if (!raw_name)
2322     return 0;
2323
2324   tail = strstr (raw_name, "___XP");
2325   if (tail == nullptr)
2326     {
2327       gdb_assert (is_thick_pntr (type));
2328       /* The structure's first field is a pointer to an array, so this
2329          fetches the array type.  */
2330       type = TYPE_TARGET_TYPE (type->field (0).type ());
2331       /* Now we can see if the array elements are packed.  */
2332       return TYPE_FIELD_BITSIZE (type, 0);
2333     }
2334
2335   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2336     {
2337       lim_warning
2338         (_("could not understand bit size information on packed array"));
2339       return 0;
2340     }
2341
2342   return bits;
2343 }
2344
2345 /* Given that TYPE is a standard GDB array type with all bounds filled
2346    in, and that the element size of its ultimate scalar constituents
2347    (that is, either its elements, or, if it is an array of arrays, its
2348    elements' elements, etc.) is *ELT_BITS, return an identical type,
2349    but with the bit sizes of its elements (and those of any
2350    constituent arrays) recorded in the BITSIZE components of its
2351    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2352    in bits.
2353
2354    Note that, for arrays whose index type has an XA encoding where
2355    a bound references a record discriminant, getting that discriminant,
2356    and therefore the actual value of that bound, is not possible
2357    because none of the given parameters gives us access to the record.
2358    This function assumes that it is OK in the context where it is being
2359    used to return an array whose bounds are still dynamic and where
2360    the length is arbitrary.  */
2361
2362 static struct type *
2363 constrained_packed_array_type (struct type *type, long *elt_bits)
2364 {
2365   struct type *new_elt_type;
2366   struct type *new_type;
2367   struct type *index_type_desc;
2368   struct type *index_type;
2369   LONGEST low_bound, high_bound;
2370
2371   type = ada_check_typedef (type);
2372   if (type->code () != TYPE_CODE_ARRAY)
2373     return type;
2374
2375   index_type_desc = ada_find_parallel_type (type, "___XA");
2376   if (index_type_desc)
2377     index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2378                                       NULL);
2379   else
2380     index_type = type->index_type ();
2381
2382   new_type = alloc_type_copy (type);
2383   new_elt_type =
2384     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2385                                    elt_bits);
2386   create_array_type (new_type, new_elt_type, index_type);
2387   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2388   new_type->set_name (ada_type_name (type));
2389
2390   if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2391        && is_dynamic_type (check_typedef (index_type)))
2392       || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2393     low_bound = high_bound = 0;
2394   if (high_bound < low_bound)
2395     *elt_bits = TYPE_LENGTH (new_type) = 0;
2396   else
2397     {
2398       *elt_bits *= (high_bound - low_bound + 1);
2399       TYPE_LENGTH (new_type) =
2400         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2401     }
2402
2403   new_type->set_is_fixed_instance (true);
2404   return new_type;
2405 }
2406
2407 /* The array type encoded by TYPE, where
2408    ada_is_constrained_packed_array_type (TYPE).  */
2409
2410 static struct type *
2411 decode_constrained_packed_array_type (struct type *type)
2412 {
2413   const char *raw_name = ada_type_name (ada_check_typedef (type));
2414   char *name;
2415   const char *tail;
2416   struct type *shadow_type;
2417   long bits;
2418
2419   if (!raw_name)
2420     raw_name = ada_type_name (desc_base_type (type));
2421
2422   if (!raw_name)
2423     return NULL;
2424
2425   name = (char *) alloca (strlen (raw_name) + 1);
2426   tail = strstr (raw_name, "___XP");
2427   type = desc_base_type (type);
2428
2429   memcpy (name, raw_name, tail - raw_name);
2430   name[tail - raw_name] = '\000';
2431
2432   shadow_type = ada_find_parallel_type_with_name (type, name);
2433
2434   if (shadow_type == NULL)
2435     {
2436       lim_warning (_("could not find bounds information on packed array"));
2437       return NULL;
2438     }
2439   shadow_type = check_typedef (shadow_type);
2440
2441   if (shadow_type->code () != TYPE_CODE_ARRAY)
2442     {
2443       lim_warning (_("could not understand bounds "
2444                      "information on packed array"));
2445       return NULL;
2446     }
2447
2448   bits = decode_packed_array_bitsize (type);
2449   return constrained_packed_array_type (shadow_type, &bits);
2450 }
2451
2452 /* Helper function for decode_constrained_packed_array.  Set the field
2453    bitsize on a series of packed arrays.  Returns the number of
2454    elements in TYPE.  */
2455
2456 static LONGEST
2457 recursively_update_array_bitsize (struct type *type)
2458 {
2459   gdb_assert (type->code () == TYPE_CODE_ARRAY);
2460
2461   LONGEST low, high;
2462   if (!get_discrete_bounds (type->index_type (), &low, &high)
2463       || low > high)
2464     return 0;
2465   LONGEST our_len = high - low + 1;
2466
2467   struct type *elt_type = TYPE_TARGET_TYPE (type);
2468   if (elt_type->code () == TYPE_CODE_ARRAY)
2469     {
2470       LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2471       LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2472       TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2473
2474       TYPE_LENGTH (type) = ((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2475                             / HOST_CHAR_BIT);
2476     }
2477
2478   return our_len;
2479 }
2480
2481 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2482    array, returns a simple array that denotes that array.  Its type is a
2483    standard GDB array type except that the BITSIZEs of the array
2484    target types are set to the number of bits in each element, and the
2485    type length is set appropriately.  */
2486
2487 static struct value *
2488 decode_constrained_packed_array (struct value *arr)
2489 {
2490   struct type *type;
2491
2492   /* If our value is a pointer, then dereference it. Likewise if
2493      the value is a reference.  Make sure that this operation does not
2494      cause the target type to be fixed, as this would indirectly cause
2495      this array to be decoded.  The rest of the routine assumes that
2496      the array hasn't been decoded yet, so we use the basic "coerce_ref"
2497      and "value_ind" routines to perform the dereferencing, as opposed
2498      to using "ada_coerce_ref" or "ada_value_ind".  */
2499   arr = coerce_ref (arr);
2500   if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2501     arr = value_ind (arr);
2502
2503   type = decode_constrained_packed_array_type (value_type (arr));
2504   if (type == NULL)
2505     {
2506       error (_("can't unpack array"));
2507       return NULL;
2508     }
2509
2510   /* Decoding the packed array type could not correctly set the field
2511      bitsizes for any dimension except the innermost, because the
2512      bounds may be variable and were not passed to that function.  So,
2513      we further resolve the array bounds here and then update the
2514      sizes.  */
2515   const gdb_byte *valaddr = value_contents_for_printing (arr).data ();
2516   CORE_ADDR address = value_address (arr);
2517   gdb::array_view<const gdb_byte> view
2518     = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
2519   type = resolve_dynamic_type (type, view, address);
2520   recursively_update_array_bitsize (type);
2521
2522   if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2523       && ada_is_modular_type (value_type (arr)))
2524     {
2525        /* This is a (right-justified) modular type representing a packed
2526           array with no wrapper.  In order to interpret the value through
2527           the (left-justified) packed array type we just built, we must
2528           first left-justify it.  */
2529       int bit_size, bit_pos;
2530       ULONGEST mod;
2531
2532       mod = ada_modulus (value_type (arr)) - 1;
2533       bit_size = 0;
2534       while (mod > 0)
2535         {
2536           bit_size += 1;
2537           mod >>= 1;
2538         }
2539       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2540       arr = ada_value_primitive_packed_val (arr, NULL,
2541                                             bit_pos / HOST_CHAR_BIT,
2542                                             bit_pos % HOST_CHAR_BIT,
2543                                             bit_size,
2544                                             type);
2545     }
2546
2547   return coerce_unspec_val_to_type (arr, type);
2548 }
2549
2550
2551 /* The value of the element of packed array ARR at the ARITY indices
2552    given in IND.   ARR must be a simple array.  */
2553
2554 static struct value *
2555 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2556 {
2557   int i;
2558   int bits, elt_off, bit_off;
2559   long elt_total_bit_offset;
2560   struct type *elt_type;
2561   struct value *v;
2562
2563   bits = 0;
2564   elt_total_bit_offset = 0;
2565   elt_type = ada_check_typedef (value_type (arr));
2566   for (i = 0; i < arity; i += 1)
2567     {
2568       if (elt_type->code () != TYPE_CODE_ARRAY
2569           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2570         error
2571           (_("attempt to do packed indexing of "
2572              "something other than a packed array"));
2573       else
2574         {
2575           struct type *range_type = elt_type->index_type ();
2576           LONGEST lowerbound, upperbound;
2577           LONGEST idx;
2578
2579           if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2580             {
2581               lim_warning (_("don't know bounds of array"));
2582               lowerbound = upperbound = 0;
2583             }
2584
2585           idx = pos_atr (ind[i]);
2586           if (idx < lowerbound || idx > upperbound)
2587             lim_warning (_("packed array index %ld out of bounds"),
2588                          (long) idx);
2589           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2590           elt_total_bit_offset += (idx - lowerbound) * bits;
2591           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2592         }
2593     }
2594   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2595   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2596
2597   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2598                                       bits, elt_type);
2599   return v;
2600 }
2601
2602 /* Non-zero iff TYPE includes negative integer values.  */
2603
2604 static int
2605 has_negatives (struct type *type)
2606 {
2607   switch (type->code ())
2608     {
2609     default:
2610       return 0;
2611     case TYPE_CODE_INT:
2612       return !type->is_unsigned ();
2613     case TYPE_CODE_RANGE:
2614       return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2615     }
2616 }
2617
2618 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2619    unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
2620    the unpacked buffer.
2621
2622    The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2623    enough to contain at least BIT_OFFSET bits.  If not, an error is raised.
2624
2625    IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2626    zero otherwise.
2627
2628    IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2629
2630    IS_SCALAR is nonzero if the data corresponds to a signed type.  */
2631
2632 static void
2633 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2634                           gdb_byte *unpacked, int unpacked_len,
2635                           int is_big_endian, int is_signed_type,
2636                           int is_scalar)
2637 {
2638   int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2639   int src_idx;                  /* Index into the source area */
2640   int src_bytes_left;           /* Number of source bytes left to process.  */
2641   int srcBitsLeft;              /* Number of source bits left to move */
2642   int unusedLS;                 /* Number of bits in next significant
2643                                    byte of source that are unused */
2644
2645   int unpacked_idx;             /* Index into the unpacked buffer */
2646   int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */
2647
2648   unsigned long accum;          /* Staging area for bits being transferred */
2649   int accumSize;                /* Number of meaningful bits in accum */
2650   unsigned char sign;
2651
2652   /* Transmit bytes from least to most significant; delta is the direction
2653      the indices move.  */
2654   int delta = is_big_endian ? -1 : 1;
2655
2656   /* Make sure that unpacked is large enough to receive the BIT_SIZE
2657      bits from SRC.  .*/
2658   if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2659     error (_("Cannot unpack %d bits into buffer of %d bytes"),
2660            bit_size, unpacked_len);
2661
2662   srcBitsLeft = bit_size;
2663   src_bytes_left = src_len;
2664   unpacked_bytes_left = unpacked_len;
2665   sign = 0;
2666
2667   if (is_big_endian)
2668     {
2669       src_idx = src_len - 1;
2670       if (is_signed_type
2671           && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2672         sign = ~0;
2673
2674       unusedLS =
2675         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2676         % HOST_CHAR_BIT;
2677
2678       if (is_scalar)
2679         {
2680           accumSize = 0;
2681           unpacked_idx = unpacked_len - 1;
2682         }
2683       else
2684         {
2685           /* Non-scalar values must be aligned at a byte boundary...  */
2686           accumSize =
2687             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2688           /* ... And are placed at the beginning (most-significant) bytes
2689              of the target.  */
2690           unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2691           unpacked_bytes_left = unpacked_idx + 1;
2692         }
2693     }
2694   else
2695     {
2696       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2697
2698       src_idx = unpacked_idx = 0;
2699       unusedLS = bit_offset;
2700       accumSize = 0;
2701
2702       if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2703         sign = ~0;
2704     }
2705
2706   accum = 0;
2707   while (src_bytes_left > 0)
2708     {
2709       /* Mask for removing bits of the next source byte that are not
2710          part of the value.  */
2711       unsigned int unusedMSMask =
2712         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2713         1;
2714       /* Sign-extend bits for this byte.  */
2715       unsigned int signMask = sign & ~unusedMSMask;
2716
2717       accum |=
2718         (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2719       accumSize += HOST_CHAR_BIT - unusedLS;
2720       if (accumSize >= HOST_CHAR_BIT)
2721         {
2722           unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2723           accumSize -= HOST_CHAR_BIT;
2724           accum >>= HOST_CHAR_BIT;
2725           unpacked_bytes_left -= 1;
2726           unpacked_idx += delta;
2727         }
2728       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2729       unusedLS = 0;
2730       src_bytes_left -= 1;
2731       src_idx += delta;
2732     }
2733   while (unpacked_bytes_left > 0)
2734     {
2735       accum |= sign << accumSize;
2736       unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2737       accumSize -= HOST_CHAR_BIT;
2738       if (accumSize < 0)
2739         accumSize = 0;
2740       accum >>= HOST_CHAR_BIT;
2741       unpacked_bytes_left -= 1;
2742       unpacked_idx += delta;
2743     }
2744 }
2745
2746 /* Create a new value of type TYPE from the contents of OBJ starting
2747    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2748    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2749    assigning through the result will set the field fetched from.
2750    VALADDR is ignored unless OBJ is NULL, in which case,
2751    VALADDR+OFFSET must address the start of storage containing the 
2752    packed value.  The value returned  in this case is never an lval.
2753    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2754
2755 struct value *
2756 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2757                                 long offset, int bit_offset, int bit_size,
2758                                 struct type *type)
2759 {
2760   struct value *v;
2761   const gdb_byte *src;                /* First byte containing data to unpack */
2762   gdb_byte *unpacked;
2763   const int is_scalar = is_scalar_type (type);
2764   const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2765   gdb::byte_vector staging;
2766
2767   type = ada_check_typedef (type);
2768
2769   if (obj == NULL)
2770     src = valaddr + offset;
2771   else
2772     src = value_contents (obj).data () + offset;
2773
2774   if (is_dynamic_type (type))
2775     {
2776       /* The length of TYPE might by dynamic, so we need to resolve
2777          TYPE in order to know its actual size, which we then use
2778          to create the contents buffer of the value we return.
2779          The difficulty is that the data containing our object is
2780          packed, and therefore maybe not at a byte boundary.  So, what
2781          we do, is unpack the data into a byte-aligned buffer, and then
2782          use that buffer as our object's value for resolving the type.  */
2783       int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2784       staging.resize (staging_len);
2785
2786       ada_unpack_from_contents (src, bit_offset, bit_size,
2787                                 staging.data (), staging.size (),
2788                                 is_big_endian, has_negatives (type),
2789                                 is_scalar);
2790       type = resolve_dynamic_type (type, staging, 0);
2791       if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2792         {
2793           /* This happens when the length of the object is dynamic,
2794              and is actually smaller than the space reserved for it.
2795              For instance, in an array of variant records, the bit_size
2796              we're given is the array stride, which is constant and
2797              normally equal to the maximum size of its element.
2798              But, in reality, each element only actually spans a portion
2799              of that stride.  */
2800           bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2801         }
2802     }
2803
2804   if (obj == NULL)
2805     {
2806       v = allocate_value (type);
2807       src = valaddr + offset;
2808     }
2809   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2810     {
2811       int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2812       gdb_byte *buf;
2813
2814       v = value_at (type, value_address (obj) + offset);
2815       buf = (gdb_byte *) alloca (src_len);
2816       read_memory (value_address (v), buf, src_len);
2817       src = buf;
2818     }
2819   else
2820     {
2821       v = allocate_value (type);
2822       src = value_contents (obj).data () + offset;
2823     }
2824
2825   if (obj != NULL)
2826     {
2827       long new_offset = offset;
2828
2829       set_value_component_location (v, obj);
2830       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2831       set_value_bitsize (v, bit_size);
2832       if (value_bitpos (v) >= HOST_CHAR_BIT)
2833         {
2834           ++new_offset;
2835           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2836         }
2837       set_value_offset (v, new_offset);
2838
2839       /* Also set the parent value.  This is needed when trying to
2840          assign a new value (in inferior memory).  */
2841       set_value_parent (v, obj);
2842     }
2843   else
2844     set_value_bitsize (v, bit_size);
2845   unpacked = value_contents_writeable (v).data ();
2846
2847   if (bit_size == 0)
2848     {
2849       memset (unpacked, 0, TYPE_LENGTH (type));
2850       return v;
2851     }
2852
2853   if (staging.size () == TYPE_LENGTH (type))
2854     {
2855       /* Small short-cut: If we've unpacked the data into a buffer
2856          of the same size as TYPE's length, then we can reuse that,
2857          instead of doing the unpacking again.  */
2858       memcpy (unpacked, staging.data (), staging.size ());
2859     }
2860   else
2861     ada_unpack_from_contents (src, bit_offset, bit_size,
2862                               unpacked, TYPE_LENGTH (type),
2863                               is_big_endian, has_negatives (type), is_scalar);
2864
2865   return v;
2866 }
2867
2868 /* Store the contents of FROMVAL into the location of TOVAL.
2869    Return a new value with the location of TOVAL and contents of
2870    FROMVAL.   Handles assignment into packed fields that have
2871    floating-point or non-scalar types.  */
2872
2873 static struct value *
2874 ada_value_assign (struct value *toval, struct value *fromval)
2875 {
2876   struct type *type = value_type (toval);
2877   int bits = value_bitsize (toval);
2878
2879   toval = ada_coerce_ref (toval);
2880   fromval = ada_coerce_ref (fromval);
2881
2882   if (ada_is_direct_array_type (value_type (toval)))
2883     toval = ada_coerce_to_simple_array (toval);
2884   if (ada_is_direct_array_type (value_type (fromval)))
2885     fromval = ada_coerce_to_simple_array (fromval);
2886
2887   if (!deprecated_value_modifiable (toval))
2888     error (_("Left operand of assignment is not a modifiable lvalue."));
2889
2890   if (VALUE_LVAL (toval) == lval_memory
2891       && bits > 0
2892       && (type->code () == TYPE_CODE_FLT
2893           || type->code () == TYPE_CODE_STRUCT))
2894     {
2895       int len = (value_bitpos (toval)
2896                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2897       int from_size;
2898       gdb_byte *buffer = (gdb_byte *) alloca (len);
2899       struct value *val;
2900       CORE_ADDR to_addr = value_address (toval);
2901
2902       if (type->code () == TYPE_CODE_FLT)
2903         fromval = value_cast (type, fromval);
2904
2905       read_memory (to_addr, buffer, len);
2906       from_size = value_bitsize (fromval);
2907       if (from_size == 0)
2908         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2909
2910       const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2911       ULONGEST from_offset = 0;
2912       if (is_big_endian && is_scalar_type (value_type (fromval)))
2913         from_offset = from_size - bits;
2914       copy_bitwise (buffer, value_bitpos (toval),
2915                     value_contents (fromval).data (), from_offset,
2916                     bits, is_big_endian);
2917       write_memory_with_notification (to_addr, buffer, len);
2918
2919       val = value_copy (toval);
2920       memcpy (value_contents_raw (val).data (),
2921               value_contents (fromval).data (),
2922               TYPE_LENGTH (type));
2923       deprecated_set_value_type (val, type);
2924
2925       return val;
2926     }
2927
2928   return value_assign (toval, fromval);
2929 }
2930
2931
2932 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2933    CONTAINER, assign the contents of VAL to COMPONENTS's place in
2934    CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2935    COMPONENT, and not the inferior's memory.  The current contents
2936    of COMPONENT are ignored.
2937
2938    Although not part of the initial design, this function also works
2939    when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2940    had a null address, and COMPONENT had an address which is equal to
2941    its offset inside CONTAINER.  */
2942
2943 static void
2944 value_assign_to_component (struct value *container, struct value *component,
2945                            struct value *val)
2946 {
2947   LONGEST offset_in_container =
2948     (LONGEST)  (value_address (component) - value_address (container));
2949   int bit_offset_in_container =
2950     value_bitpos (component) - value_bitpos (container);
2951   int bits;
2952
2953   val = value_cast (value_type (component), val);
2954
2955   if (value_bitsize (component) == 0)
2956     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2957   else
2958     bits = value_bitsize (component);
2959
2960   if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2961     {
2962       int src_offset;
2963
2964       if (is_scalar_type (check_typedef (value_type (component))))
2965         src_offset
2966           = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2967       else
2968         src_offset = 0;
2969       copy_bitwise ((value_contents_writeable (container).data ()
2970                      + offset_in_container),
2971                     value_bitpos (container) + bit_offset_in_container,
2972                     value_contents (val).data (), src_offset, bits, 1);
2973     }
2974   else
2975     copy_bitwise ((value_contents_writeable (container).data ()
2976                    + offset_in_container),
2977                   value_bitpos (container) + bit_offset_in_container,
2978                   value_contents (val).data (), 0, bits, 0);
2979 }
2980
2981 /* Determine if TYPE is an access to an unconstrained array.  */
2982
2983 bool
2984 ada_is_access_to_unconstrained_array (struct type *type)
2985 {
2986   return (type->code () == TYPE_CODE_TYPEDEF
2987           && is_thick_pntr (ada_typedef_target_type (type)));
2988 }
2989
2990 /* The value of the element of array ARR at the ARITY indices given in IND.
2991    ARR may be either a simple array, GNAT array descriptor, or pointer
2992    thereto.  */
2993
2994 struct value *
2995 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2996 {
2997   int k;
2998   struct value *elt;
2999   struct type *elt_type;
3000
3001   elt = ada_coerce_to_simple_array (arr);
3002
3003   elt_type = ada_check_typedef (value_type (elt));
3004   if (elt_type->code () == TYPE_CODE_ARRAY
3005       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
3006     return value_subscript_packed (elt, arity, ind);
3007
3008   for (k = 0; k < arity; k += 1)
3009     {
3010       struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
3011
3012       if (elt_type->code () != TYPE_CODE_ARRAY)
3013         error (_("too many subscripts (%d expected)"), k);
3014
3015       elt = value_subscript (elt, pos_atr (ind[k]));
3016
3017       if (ada_is_access_to_unconstrained_array (saved_elt_type)
3018           && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
3019         {
3020           /* The element is a typedef to an unconstrained array,
3021              except that the value_subscript call stripped the
3022              typedef layer.  The typedef layer is GNAT's way to
3023              specify that the element is, at the source level, an
3024              access to the unconstrained array, rather than the
3025              unconstrained array.  So, we need to restore that
3026              typedef layer, which we can do by forcing the element's
3027              type back to its original type. Otherwise, the returned
3028              value is going to be printed as the array, rather
3029              than as an access.  Another symptom of the same issue
3030              would be that an expression trying to dereference the
3031              element would also be improperly rejected.  */
3032           deprecated_set_value_type (elt, saved_elt_type);
3033         }
3034
3035       elt_type = ada_check_typedef (value_type (elt));
3036     }
3037
3038   return elt;
3039 }
3040
3041 /* Assuming ARR is a pointer to a GDB array, the value of the element
3042    of *ARR at the ARITY indices given in IND.
3043    Does not read the entire array into memory.
3044
3045    Note: Unlike what one would expect, this function is used instead of
3046    ada_value_subscript for basically all non-packed array types.  The reason
3047    for this is that a side effect of doing our own pointer arithmetics instead
3048    of relying on value_subscript is that there is no implicit typedef peeling.
3049    This is important for arrays of array accesses, where it allows us to
3050    preserve the fact that the array's element is an array access, where the
3051    access part os encoded in a typedef layer.  */
3052
3053 static struct value *
3054 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
3055 {
3056   int k;
3057   struct value *array_ind = ada_value_ind (arr);
3058   struct type *type
3059     = check_typedef (value_enclosing_type (array_ind));
3060
3061   if (type->code () == TYPE_CODE_ARRAY
3062       && TYPE_FIELD_BITSIZE (type, 0) > 0)
3063     return value_subscript_packed (array_ind, arity, ind);
3064
3065   for (k = 0; k < arity; k += 1)
3066     {
3067       LONGEST lwb, upb;
3068
3069       if (type->code () != TYPE_CODE_ARRAY)
3070         error (_("too many subscripts (%d expected)"), k);
3071       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
3072                         value_copy (arr));
3073       get_discrete_bounds (type->index_type (), &lwb, &upb);
3074       arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
3075       type = TYPE_TARGET_TYPE (type);
3076     }
3077
3078   return value_ind (arr);
3079 }
3080
3081 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
3082    actual type of ARRAY_PTR is ignored), returns the Ada slice of
3083    HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
3084    this array is LOW, as per Ada rules.  */
3085 static struct value *
3086 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
3087                           int low, int high)
3088 {
3089   struct type *type0 = ada_check_typedef (type);
3090   struct type *base_index_type = TYPE_TARGET_TYPE (type0->index_type ());
3091   struct type *index_type
3092     = create_static_range_type (NULL, base_index_type, low, high);
3093   struct type *slice_type = create_array_type_with_stride
3094                               (NULL, TYPE_TARGET_TYPE (type0), index_type,
3095                                type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
3096                                TYPE_FIELD_BITSIZE (type0, 0));
3097   int base_low =  ada_discrete_type_low_bound (type0->index_type ());
3098   gdb::optional<LONGEST> base_low_pos, low_pos;
3099   CORE_ADDR base;
3100
3101   low_pos = discrete_position (base_index_type, low);
3102   base_low_pos = discrete_position (base_index_type, base_low);
3103
3104   if (!low_pos.has_value () || !base_low_pos.has_value ())
3105     {
3106       warning (_("unable to get positions in slice, use bounds instead"));
3107       low_pos = low;
3108       base_low_pos = base_low;
3109     }
3110
3111   ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
3112   if (stride == 0)
3113     stride = TYPE_LENGTH (TYPE_TARGET_TYPE (type0));
3114
3115   base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
3116   return value_at_lazy (slice_type, base);
3117 }
3118
3119
3120 static struct value *
3121 ada_value_slice (struct value *array, int low, int high)
3122 {
3123   struct type *type = ada_check_typedef (value_type (array));
3124   struct type *base_index_type = TYPE_TARGET_TYPE (type->index_type ());
3125   struct type *index_type
3126     = create_static_range_type (NULL, type->index_type (), low, high);
3127   struct type *slice_type = create_array_type_with_stride
3128                               (NULL, TYPE_TARGET_TYPE (type), index_type,
3129                                type->dyn_prop (DYN_PROP_BYTE_STRIDE),
3130                                TYPE_FIELD_BITSIZE (type, 0));
3131   gdb::optional<LONGEST> low_pos, high_pos;
3132
3133
3134   low_pos = discrete_position (base_index_type, low);
3135   high_pos = discrete_position (base_index_type, high);
3136
3137   if (!low_pos.has_value () || !high_pos.has_value ())
3138     {
3139       warning (_("unable to get positions in slice, use bounds instead"));
3140       low_pos = low;
3141       high_pos = high;
3142     }
3143
3144   return value_cast (slice_type,
3145                      value_slice (array, low, *high_pos - *low_pos + 1));
3146 }
3147
3148 /* If type is a record type in the form of a standard GNAT array
3149    descriptor, returns the number of dimensions for type.  If arr is a
3150    simple array, returns the number of "array of"s that prefix its
3151    type designation.  Otherwise, returns 0.  */
3152
3153 int
3154 ada_array_arity (struct type *type)
3155 {
3156   int arity;
3157
3158   if (type == NULL)
3159     return 0;
3160
3161   type = desc_base_type (type);
3162
3163   arity = 0;
3164   if (type->code () == TYPE_CODE_STRUCT)
3165     return desc_arity (desc_bounds_type (type));
3166   else
3167     while (type->code () == TYPE_CODE_ARRAY)
3168       {
3169         arity += 1;
3170         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
3171       }
3172
3173   return arity;
3174 }
3175
3176 /* If TYPE is a record type in the form of a standard GNAT array
3177    descriptor or a simple array type, returns the element type for
3178    TYPE after indexing by NINDICES indices, or by all indices if
3179    NINDICES is -1.  Otherwise, returns NULL.  */
3180
3181 struct type *
3182 ada_array_element_type (struct type *type, int nindices)
3183 {
3184   type = desc_base_type (type);
3185
3186   if (type->code () == TYPE_CODE_STRUCT)
3187     {
3188       int k;
3189       struct type *p_array_type;
3190
3191       p_array_type = desc_data_target_type (type);
3192
3193       k = ada_array_arity (type);
3194       if (k == 0)
3195         return NULL;
3196
3197       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
3198       if (nindices >= 0 && k > nindices)
3199         k = nindices;
3200       while (k > 0 && p_array_type != NULL)
3201         {
3202           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
3203           k -= 1;
3204         }
3205       return p_array_type;
3206     }
3207   else if (type->code () == TYPE_CODE_ARRAY)
3208     {
3209       while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
3210         {
3211           type = TYPE_TARGET_TYPE (type);
3212           /* A multi-dimensional array is represented using a sequence
3213              of array types.  If one of these types has a name, then
3214              it is not another dimension of the outer array, but
3215              rather the element type of the outermost array.  */
3216           if (type->name () != nullptr)
3217             break;
3218           nindices -= 1;
3219         }
3220       return type;
3221     }
3222
3223   return NULL;
3224 }
3225
3226 /* See ada-lang.h.  */
3227
3228 struct type *
3229 ada_index_type (struct type *type, int n, const char *name)
3230 {
3231   struct type *result_type;
3232
3233   type = desc_base_type (type);
3234
3235   if (n < 0 || n > ada_array_arity (type))
3236     error (_("invalid dimension number to '%s"), name);
3237
3238   if (ada_is_simple_array_type (type))
3239     {
3240       int i;
3241
3242       for (i = 1; i < n; i += 1)
3243         {
3244           type = ada_check_typedef (type);
3245           type = TYPE_TARGET_TYPE (type);
3246         }
3247       result_type = TYPE_TARGET_TYPE (ada_check_typedef (type)->index_type ());
3248       /* FIXME: The stabs type r(0,0);bound;bound in an array type
3249          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
3250          perhaps stabsread.c would make more sense.  */
3251       if (result_type && result_type->code () == TYPE_CODE_UNDEF)
3252         result_type = NULL;
3253     }
3254   else
3255     {
3256       result_type = desc_index_type (desc_bounds_type (type), n);
3257       if (result_type == NULL)
3258         error (_("attempt to take bound of something that is not an array"));
3259     }
3260
3261   return result_type;
3262 }
3263
3264 /* Given that arr is an array type, returns the lower bound of the
3265    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3266    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
3267    array-descriptor type.  It works for other arrays with bounds supplied
3268    by run-time quantities other than discriminants.  */
3269
3270 static LONGEST
3271 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3272 {
3273   struct type *type, *index_type_desc, *index_type;
3274   int i;
3275
3276   gdb_assert (which == 0 || which == 1);
3277
3278   if (ada_is_constrained_packed_array_type (arr_type))
3279     arr_type = decode_constrained_packed_array_type (arr_type);
3280
3281   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3282     return (LONGEST) - which;
3283
3284   if (arr_type->code () == TYPE_CODE_PTR)
3285     type = TYPE_TARGET_TYPE (arr_type);
3286   else
3287     type = arr_type;
3288
3289   if (type->is_fixed_instance ())
3290     {
3291       /* The array has already been fixed, so we do not need to
3292          check the parallel ___XA type again.  That encoding has
3293          already been applied, so ignore it now.  */
3294       index_type_desc = NULL;
3295     }
3296   else
3297     {
3298       index_type_desc = ada_find_parallel_type (type, "___XA");
3299       ada_fixup_array_indexes_type (index_type_desc);
3300     }
3301
3302   if (index_type_desc != NULL)
3303     index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
3304                                       NULL);
3305   else
3306     {
3307       struct type *elt_type = check_typedef (type);
3308
3309       for (i = 1; i < n; i++)
3310         elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3311
3312       index_type = elt_type->index_type ();
3313     }
3314
3315   return
3316     (LONGEST) (which == 0
3317                ? ada_discrete_type_low_bound (index_type)
3318                : ada_discrete_type_high_bound (index_type));
3319 }
3320
3321 /* Given that arr is an array value, returns the lower bound of the
3322    nth index (numbering from 1) if WHICH is 0, and the upper bound if
3323    WHICH is 1.  This routine will also work for arrays with bounds
3324    supplied by run-time quantities other than discriminants.  */
3325
3326 static LONGEST
3327 ada_array_bound (struct value *arr, int n, int which)
3328 {
3329   struct type *arr_type;
3330
3331   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3332     arr = value_ind (arr);
3333   arr_type = value_enclosing_type (arr);
3334
3335   if (ada_is_constrained_packed_array_type (arr_type))
3336     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3337   else if (ada_is_simple_array_type (arr_type))
3338     return ada_array_bound_from_type (arr_type, n, which);
3339   else
3340     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3341 }
3342
3343 /* Given that arr is an array value, returns the length of the
3344    nth index.  This routine will also work for arrays with bounds
3345    supplied by run-time quantities other than discriminants.
3346    Does not work for arrays indexed by enumeration types with representation
3347    clauses at the moment.  */
3348
3349 static LONGEST
3350 ada_array_length (struct value *arr, int n)
3351 {
3352   struct type *arr_type, *index_type;
3353   int low, high;
3354
3355   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3356     arr = value_ind (arr);
3357   arr_type = value_enclosing_type (arr);
3358
3359   if (ada_is_constrained_packed_array_type (arr_type))
3360     return ada_array_length (decode_constrained_packed_array (arr), n);
3361
3362   if (ada_is_simple_array_type (arr_type))
3363     {
3364       low = ada_array_bound_from_type (arr_type, n, 0);
3365       high = ada_array_bound_from_type (arr_type, n, 1);
3366     }
3367   else
3368     {
3369       low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3370       high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3371     }
3372
3373   arr_type = check_typedef (arr_type);
3374   index_type = ada_index_type (arr_type, n, "length");
3375   if (index_type != NULL)
3376     {
3377       struct type *base_type;
3378       if (index_type->code () == TYPE_CODE_RANGE)
3379         base_type = TYPE_TARGET_TYPE (index_type);
3380       else
3381         base_type = index_type;
3382
3383       low = pos_atr (value_from_longest (base_type, low));
3384       high = pos_atr (value_from_longest (base_type, high));
3385     }
3386   return high - low + 1;
3387 }
3388
3389 /* An array whose type is that of ARR_TYPE (an array type), with
3390    bounds LOW to HIGH, but whose contents are unimportant.  If HIGH is
3391    less than LOW, then LOW-1 is used.  */
3392
3393 static struct value *
3394 empty_array (struct type *arr_type, int low, int high)
3395 {
3396   struct type *arr_type0 = ada_check_typedef (arr_type);
3397   struct type *index_type
3398     = create_static_range_type
3399         (NULL, TYPE_TARGET_TYPE (arr_type0->index_type ()), low,
3400          high < low ? low - 1 : high);
3401   struct type *elt_type = ada_array_element_type (arr_type0, 1);
3402
3403   return allocate_value (create_array_type (NULL, elt_type, index_type));
3404 }
3405 \f
3406
3407                                 /* Name resolution */
3408
3409 /* The "decoded" name for the user-definable Ada operator corresponding
3410    to OP.  */
3411
3412 static const char *
3413 ada_decoded_op_name (enum exp_opcode op)
3414 {
3415   int i;
3416
3417   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3418     {
3419       if (ada_opname_table[i].op == op)
3420         return ada_opname_table[i].decoded;
3421     }
3422   error (_("Could not find operator name for opcode"));
3423 }
3424
3425 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3426    in a listing of choices during disambiguation (see sort_choices, below).
3427    The idea is that overloadings of a subprogram name from the
3428    same package should sort in their source order.  We settle for ordering
3429    such symbols by their trailing number (__N  or $N).  */
3430
3431 static int
3432 encoded_ordered_before (const char *N0, const char *N1)
3433 {
3434   if (N1 == NULL)
3435     return 0;
3436   else if (N0 == NULL)
3437     return 1;
3438   else
3439     {
3440       int k0, k1;
3441
3442       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3443         ;
3444       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3445         ;
3446       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3447           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3448         {
3449           int n0, n1;
3450
3451           n0 = k0;
3452           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3453             n0 -= 1;
3454           n1 = k1;
3455           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3456             n1 -= 1;
3457           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3458             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3459         }
3460       return (strcmp (N0, N1) < 0);
3461     }
3462 }
3463
3464 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3465    encoded names.  */
3466
3467 static void
3468 sort_choices (struct block_symbol syms[], int nsyms)
3469 {
3470   int i;
3471
3472   for (i = 1; i < nsyms; i += 1)
3473     {
3474       struct block_symbol sym = syms[i];
3475       int j;
3476
3477       for (j = i - 1; j >= 0; j -= 1)
3478         {
3479           if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3480                                       sym.symbol->linkage_name ()))
3481             break;
3482           syms[j + 1] = syms[j];
3483         }
3484       syms[j + 1] = sym;
3485     }
3486 }
3487
3488 /* Whether GDB should display formals and return types for functions in the
3489    overloads selection menu.  */
3490 static bool print_signatures = true;
3491
3492 /* Print the signature for SYM on STREAM according to the FLAGS options.  For
3493    all but functions, the signature is just the name of the symbol.  For
3494    functions, this is the name of the function, the list of types for formals
3495    and the return type (if any).  */
3496
3497 static void
3498 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3499                             const struct type_print_options *flags)
3500 {
3501   struct type *type = sym->type ();
3502
3503   gdb_printf (stream, "%s", sym->print_name ());
3504   if (!print_signatures
3505       || type == NULL
3506       || type->code () != TYPE_CODE_FUNC)
3507     return;
3508
3509   if (type->num_fields () > 0)
3510     {
3511       int i;
3512
3513       gdb_printf (stream, " (");
3514       for (i = 0; i < type->num_fields (); ++i)
3515         {
3516           if (i > 0)
3517             gdb_printf (stream, "; ");
3518           ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3519                           flags);
3520         }
3521       gdb_printf (stream, ")");
3522     }
3523   if (TYPE_TARGET_TYPE (type) != NULL
3524       && TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_VOID)
3525     {
3526       gdb_printf (stream, " return ");
3527       ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3528     }
3529 }
3530
3531 /* Read and validate a set of numeric choices from the user in the
3532    range 0 .. N_CHOICES-1.  Place the results in increasing
3533    order in CHOICES[0 .. N-1], and return N.
3534
3535    The user types choices as a sequence of numbers on one line
3536    separated by blanks, encoding them as follows:
3537
3538      + A choice of 0 means to cancel the selection, throwing an error.
3539      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3540      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3541
3542    The user is not allowed to choose more than MAX_RESULTS values.
3543
3544    ANNOTATION_SUFFIX, if present, is used to annotate the input
3545    prompts (for use with the -f switch).  */
3546
3547 static int
3548 get_selections (int *choices, int n_choices, int max_results,
3549                 int is_all_choice, const char *annotation_suffix)
3550 {
3551   const char *args;
3552   const char *prompt;
3553   int n_chosen;
3554   int first_choice = is_all_choice ? 2 : 1;
3555
3556   prompt = getenv ("PS2");
3557   if (prompt == NULL)
3558     prompt = "> ";
3559
3560   args = command_line_input (prompt, annotation_suffix);
3561
3562   if (args == NULL)
3563     error_no_arg (_("one or more choice numbers"));
3564
3565   n_chosen = 0;
3566
3567   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3568      order, as given in args.  Choices are validated.  */
3569   while (1)
3570     {
3571       char *args2;
3572       int choice, j;
3573
3574       args = skip_spaces (args);
3575       if (*args == '\0' && n_chosen == 0)
3576         error_no_arg (_("one or more choice numbers"));
3577       else if (*args == '\0')
3578         break;
3579
3580       choice = strtol (args, &args2, 10);
3581       if (args == args2 || choice < 0
3582           || choice > n_choices + first_choice - 1)
3583         error (_("Argument must be choice number"));
3584       args = args2;
3585
3586       if (choice == 0)
3587         error (_("cancelled"));
3588
3589       if (choice < first_choice)
3590         {
3591           n_chosen = n_choices;
3592           for (j = 0; j < n_choices; j += 1)
3593             choices[j] = j;
3594           break;
3595         }
3596       choice -= first_choice;
3597
3598       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3599         {
3600         }
3601
3602       if (j < 0 || choice != choices[j])
3603         {
3604           int k;
3605
3606           for (k = n_chosen - 1; k > j; k -= 1)
3607             choices[k + 1] = choices[k];
3608           choices[j + 1] = choice;
3609           n_chosen += 1;
3610         }
3611     }
3612
3613   if (n_chosen > max_results)
3614     error (_("Select no more than %d of the above"), max_results);
3615
3616   return n_chosen;
3617 }
3618
3619 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3620    by asking the user (if necessary), returning the number selected,
3621    and setting the first elements of SYMS items.  Error if no symbols
3622    selected.  */
3623
3624 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3625    to be re-integrated one of these days.  */
3626
3627 static int
3628 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3629 {
3630   int i;
3631   int *chosen = XALLOCAVEC (int , nsyms);
3632   int n_chosen;
3633   int first_choice = (max_results == 1) ? 1 : 2;
3634   const char *select_mode = multiple_symbols_select_mode ();
3635
3636   if (max_results < 1)
3637     error (_("Request to select 0 symbols!"));
3638   if (nsyms <= 1)
3639     return nsyms;
3640
3641   if (select_mode == multiple_symbols_cancel)
3642     error (_("\
3643 canceled because the command is ambiguous\n\
3644 See set/show multiple-symbol."));
3645
3646   /* If select_mode is "all", then return all possible symbols.
3647      Only do that if more than one symbol can be selected, of course.
3648      Otherwise, display the menu as usual.  */
3649   if (select_mode == multiple_symbols_all && max_results > 1)
3650     return nsyms;
3651
3652   gdb_printf (_("[0] cancel\n"));
3653   if (max_results > 1)
3654     gdb_printf (_("[1] all\n"));
3655
3656   sort_choices (syms, nsyms);
3657
3658   for (i = 0; i < nsyms; i += 1)
3659     {
3660       if (syms[i].symbol == NULL)
3661         continue;
3662
3663       if (syms[i].symbol->aclass () == LOC_BLOCK)
3664         {
3665           struct symtab_and_line sal =
3666             find_function_start_sal (syms[i].symbol, 1);
3667
3668           gdb_printf ("[%d] ", i + first_choice);
3669           ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3670                                       &type_print_raw_options);
3671           if (sal.symtab == NULL)
3672             gdb_printf (_(" at %p[<no source file available>%p]:%d\n"),
3673                         metadata_style.style ().ptr (), nullptr, sal.line);
3674           else
3675             gdb_printf
3676               (_(" at %ps:%d\n"),
3677                styled_string (file_name_style.style (),
3678                               symtab_to_filename_for_display (sal.symtab)),
3679                sal.line);
3680           continue;
3681         }
3682       else
3683         {
3684           int is_enumeral =
3685             (syms[i].symbol->aclass () == LOC_CONST
3686              && syms[i].symbol->type () != NULL
3687              && syms[i].symbol->type ()->code () == TYPE_CODE_ENUM);
3688           struct symtab *symtab = NULL;
3689
3690           if (syms[i].symbol->is_objfile_owned ())
3691             symtab = syms[i].symbol->symtab ();
3692
3693           if (syms[i].symbol->line () != 0 && symtab != NULL)
3694             {
3695               gdb_printf ("[%d] ", i + first_choice);
3696               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3697                                           &type_print_raw_options);
3698               gdb_printf (_(" at %s:%d\n"),
3699                           symtab_to_filename_for_display (symtab),
3700                           syms[i].symbol->line ());
3701             }
3702           else if (is_enumeral
3703                    && syms[i].symbol->type ()->name () != NULL)
3704             {
3705               gdb_printf (("[%d] "), i + first_choice);
3706               ada_print_type (syms[i].symbol->type (), NULL,
3707                               gdb_stdout, -1, 0, &type_print_raw_options);
3708               gdb_printf (_("'(%s) (enumeral)\n"),
3709                           syms[i].symbol->print_name ());
3710             }
3711           else
3712             {
3713               gdb_printf ("[%d] ", i + first_choice);
3714               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3715                                           &type_print_raw_options);
3716
3717               if (symtab != NULL)
3718                 gdb_printf (is_enumeral
3719                             ? _(" in %s (enumeral)\n")
3720                             : _(" at %s:?\n"),
3721                             symtab_to_filename_for_display (symtab));
3722               else
3723                 gdb_printf (is_enumeral
3724                             ? _(" (enumeral)\n")
3725                             : _(" at ?\n"));
3726             }
3727         }
3728     }
3729
3730   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3731                              "overload-choice");
3732
3733   for (i = 0; i < n_chosen; i += 1)
3734     syms[i] = syms[chosen[i]];
3735
3736   return n_chosen;
3737 }
3738
3739 /* See ada-lang.h.  */
3740
3741 block_symbol
3742 ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
3743                           int nargs, value *argvec[])
3744 {
3745   if (possible_user_operator_p (op, argvec))
3746     {
3747       std::vector<struct block_symbol> candidates
3748         = ada_lookup_symbol_list (ada_decoded_op_name (op),
3749                                   NULL, VAR_DOMAIN);
3750
3751       int i = ada_resolve_function (candidates, argvec,
3752                                     nargs, ada_decoded_op_name (op), NULL,
3753                                     parse_completion);
3754       if (i >= 0)
3755         return candidates[i];
3756     }
3757   return {};
3758 }
3759
3760 /* See ada-lang.h.  */
3761
3762 block_symbol
3763 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3764                      struct type *context_type,
3765                      bool parse_completion,
3766                      int nargs, value *argvec[],
3767                      innermost_block_tracker *tracker)
3768 {
3769   std::vector<struct block_symbol> candidates
3770     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3771
3772   int i;
3773   if (candidates.size () == 1)
3774     i = 0;
3775   else
3776     {
3777       i = ada_resolve_function
3778         (candidates,
3779          argvec, nargs,
3780          sym->linkage_name (),
3781          context_type, parse_completion);
3782       if (i < 0)
3783         error (_("Could not find a match for %s"), sym->print_name ());
3784     }
3785
3786   tracker->update (candidates[i]);
3787   return candidates[i];
3788 }
3789
3790 /* Resolve a mention of a name where the context type is an
3791    enumeration type.  */
3792
3793 static int
3794 ada_resolve_enum (std::vector<struct block_symbol> &syms,
3795                   const char *name, struct type *context_type,
3796                   bool parse_completion)
3797 {
3798   gdb_assert (context_type->code () == TYPE_CODE_ENUM);
3799   context_type = ada_check_typedef (context_type);
3800
3801   for (int i = 0; i < syms.size (); ++i)
3802     {
3803       /* We already know the name matches, so we're just looking for
3804          an element of the correct enum type.  */
3805       if (ada_check_typedef (syms[i].symbol->type ()) == context_type)
3806         return i;
3807     }
3808
3809   error (_("No name '%s' in enumeration type '%s'"), name,
3810          ada_type_name (context_type));
3811 }
3812
3813 /* See ada-lang.h.  */
3814
3815 block_symbol
3816 ada_resolve_variable (struct symbol *sym, const struct block *block,
3817                       struct type *context_type,
3818                       bool parse_completion,
3819                       int deprocedure_p,
3820                       innermost_block_tracker *tracker)
3821 {
3822   std::vector<struct block_symbol> candidates
3823     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3824
3825   if (std::any_of (candidates.begin (),
3826                    candidates.end (),
3827                    [] (block_symbol &bsym)
3828                    {
3829                      switch (bsym.symbol->aclass ())
3830                        {
3831                        case LOC_REGISTER:
3832                        case LOC_ARG:
3833                        case LOC_REF_ARG:
3834                        case LOC_REGPARM_ADDR:
3835                        case LOC_LOCAL:
3836                        case LOC_COMPUTED:
3837                          return true;
3838                        default:
3839                          return false;
3840                        }
3841                    }))
3842     {
3843       /* Types tend to get re-introduced locally, so if there
3844          are any local symbols that are not types, first filter
3845          out all types.  */
3846       candidates.erase
3847         (std::remove_if
3848          (candidates.begin (),
3849           candidates.end (),
3850           [] (block_symbol &bsym)
3851           {
3852             return bsym.symbol->aclass () == LOC_TYPEDEF;
3853           }),
3854          candidates.end ());
3855     }
3856
3857   /* Filter out artificial symbols.  */
3858   candidates.erase
3859     (std::remove_if
3860      (candidates.begin (),
3861       candidates.end (),
3862       [] (block_symbol &bsym)
3863       {
3864         return bsym.symbol->is_artificial ();
3865       }),
3866      candidates.end ());
3867
3868   int i;
3869   if (candidates.empty ())
3870     error (_("No definition found for %s"), sym->print_name ());
3871   else if (candidates.size () == 1)
3872     i = 0;
3873   else if (context_type != nullptr
3874            && context_type->code () == TYPE_CODE_ENUM)
3875     i = ada_resolve_enum (candidates, sym->linkage_name (), context_type,
3876                           parse_completion);
3877   else if (deprocedure_p && !is_nonfunction (candidates))
3878     {
3879       i = ada_resolve_function
3880         (candidates, NULL, 0,
3881          sym->linkage_name (),
3882          context_type, parse_completion);
3883       if (i < 0)
3884         error (_("Could not find a match for %s"), sym->print_name ());
3885     }
3886   else
3887     {
3888       gdb_printf (_("Multiple matches for %s\n"), sym->print_name ());
3889       user_select_syms (candidates.data (), candidates.size (), 1);
3890       i = 0;
3891     }
3892
3893   tracker->update (candidates[i]);
3894   return candidates[i];
3895 }
3896
3897 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  */
3898 /* The term "match" here is rather loose.  The match is heuristic and
3899    liberal.  */
3900
3901 static int
3902 ada_type_match (struct type *ftype, struct type *atype)
3903 {
3904   ftype = ada_check_typedef (ftype);
3905   atype = ada_check_typedef (atype);
3906
3907   if (ftype->code () == TYPE_CODE_REF)
3908     ftype = TYPE_TARGET_TYPE (ftype);
3909   if (atype->code () == TYPE_CODE_REF)
3910     atype = TYPE_TARGET_TYPE (atype);
3911
3912   switch (ftype->code ())
3913     {
3914     default:
3915       return ftype->code () == atype->code ();
3916     case TYPE_CODE_PTR:
3917       if (atype->code () != TYPE_CODE_PTR)
3918         return 0;
3919       atype = TYPE_TARGET_TYPE (atype);
3920       /* This can only happen if the actual argument is 'null'.  */
3921       if (atype->code () == TYPE_CODE_INT && TYPE_LENGTH (atype) == 0)
3922         return 1;
3923       return ada_type_match (TYPE_TARGET_TYPE (ftype), atype);
3924     case TYPE_CODE_INT:
3925     case TYPE_CODE_ENUM:
3926     case TYPE_CODE_RANGE:
3927       switch (atype->code ())
3928         {
3929         case TYPE_CODE_INT:
3930         case TYPE_CODE_ENUM:
3931         case TYPE_CODE_RANGE:
3932           return 1;
3933         default:
3934           return 0;
3935         }
3936
3937     case TYPE_CODE_ARRAY:
3938       return (atype->code () == TYPE_CODE_ARRAY
3939               || ada_is_array_descriptor_type (atype));
3940
3941     case TYPE_CODE_STRUCT:
3942       if (ada_is_array_descriptor_type (ftype))
3943         return (atype->code () == TYPE_CODE_ARRAY
3944                 || ada_is_array_descriptor_type (atype));
3945       else
3946         return (atype->code () == TYPE_CODE_STRUCT
3947                 && !ada_is_array_descriptor_type (atype));
3948
3949     case TYPE_CODE_UNION:
3950     case TYPE_CODE_FLT:
3951       return (atype->code () == ftype->code ());
3952     }
3953 }
3954
3955 /* Return non-zero if the formals of FUNC "sufficiently match" the
3956    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3957    may also be an enumeral, in which case it is treated as a 0-
3958    argument function.  */
3959
3960 static int
3961 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3962 {
3963   int i;
3964   struct type *func_type = func->type ();
3965
3966   if (func->aclass () == LOC_CONST
3967       && func_type->code () == TYPE_CODE_ENUM)
3968     return (n_actuals == 0);
3969   else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3970     return 0;
3971
3972   if (func_type->num_fields () != n_actuals)
3973     return 0;
3974
3975   for (i = 0; i < n_actuals; i += 1)
3976     {
3977       if (actuals[i] == NULL)
3978         return 0;
3979       else
3980         {
3981           struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3982           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3983
3984           if (!ada_type_match (ftype, atype))
3985             return 0;
3986         }
3987     }
3988   return 1;
3989 }
3990
3991 /* False iff function type FUNC_TYPE definitely does not produce a value
3992    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3993    FUNC_TYPE is not a valid function type with a non-null return type
3994    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3995
3996 static int
3997 return_match (struct type *func_type, struct type *context_type)
3998 {
3999   struct type *return_type;
4000
4001   if (func_type == NULL)
4002     return 1;
4003
4004   if (func_type->code () == TYPE_CODE_FUNC)
4005     return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4006   else
4007     return_type = get_base_type (func_type);
4008   if (return_type == NULL)
4009     return 1;
4010
4011   context_type = get_base_type (context_type);
4012
4013   if (return_type->code () == TYPE_CODE_ENUM)
4014     return context_type == NULL || return_type == context_type;
4015   else if (context_type == NULL)
4016     return return_type->code () != TYPE_CODE_VOID;
4017   else
4018     return return_type->code () == context_type->code ();
4019 }
4020
4021
4022 /* Returns the index in SYMS that contains the symbol for the
4023    function (if any) that matches the types of the NARGS arguments in
4024    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
4025    that returns that type, then eliminate matches that don't.  If
4026    CONTEXT_TYPE is void and there is at least one match that does not
4027    return void, eliminate all matches that do.
4028
4029    Asks the user if there is more than one match remaining.  Returns -1
4030    if there is no such symbol or none is selected.  NAME is used
4031    solely for messages.  May re-arrange and modify SYMS in
4032    the process; the index returned is for the modified vector.  */
4033
4034 static int
4035 ada_resolve_function (std::vector<struct block_symbol> &syms,
4036                       struct value **args, int nargs,
4037                       const char *name, struct type *context_type,
4038                       bool parse_completion)
4039 {
4040   int fallback;
4041   int k;
4042   int m;                        /* Number of hits */
4043
4044   m = 0;
4045   /* In the first pass of the loop, we only accept functions matching
4046      context_type.  If none are found, we add a second pass of the loop
4047      where every function is accepted.  */
4048   for (fallback = 0; m == 0 && fallback < 2; fallback++)
4049     {
4050       for (k = 0; k < syms.size (); k += 1)
4051         {
4052           struct type *type = ada_check_typedef (syms[k].symbol->type ());
4053
4054           if (ada_args_match (syms[k].symbol, args, nargs)
4055               && (fallback || return_match (type, context_type)))
4056             {
4057               syms[m] = syms[k];
4058               m += 1;
4059             }
4060         }
4061     }
4062
4063   /* If we got multiple matches, ask the user which one to use.  Don't do this
4064      interactive thing during completion, though, as the purpose of the
4065      completion is providing a list of all possible matches.  Prompting the
4066      user to filter it down would be completely unexpected in this case.  */
4067   if (m == 0)
4068     return -1;
4069   else if (m > 1 && !parse_completion)
4070     {
4071       gdb_printf (_("Multiple matches for %s\n"), name);
4072       user_select_syms (syms.data (), m, 1);
4073       return 0;
4074     }
4075   return 0;
4076 }
4077
4078 /* Type-class predicates */
4079
4080 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4081    or FLOAT).  */
4082
4083 static int
4084 numeric_type_p (struct type *type)
4085 {
4086   if (type == NULL)
4087     return 0;
4088   else
4089     {
4090       switch (type->code ())
4091         {
4092         case TYPE_CODE_INT:
4093         case TYPE_CODE_FLT:
4094         case TYPE_CODE_FIXED_POINT:
4095           return 1;
4096         case TYPE_CODE_RANGE:
4097           return (type == TYPE_TARGET_TYPE (type)
4098                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
4099         default:
4100           return 0;
4101         }
4102     }
4103 }
4104
4105 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
4106
4107 static int
4108 integer_type_p (struct type *type)
4109 {
4110   if (type == NULL)
4111     return 0;
4112   else
4113     {
4114       switch (type->code ())
4115         {
4116         case TYPE_CODE_INT:
4117           return 1;
4118         case TYPE_CODE_RANGE:
4119           return (type == TYPE_TARGET_TYPE (type)
4120                   || integer_type_p (TYPE_TARGET_TYPE (type)));
4121         default:
4122           return 0;
4123         }
4124     }
4125 }
4126
4127 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
4128
4129 static int
4130 scalar_type_p (struct type *type)
4131 {
4132   if (type == NULL)
4133     return 0;
4134   else
4135     {
4136       switch (type->code ())
4137         {
4138         case TYPE_CODE_INT:
4139         case TYPE_CODE_RANGE:
4140         case TYPE_CODE_ENUM:
4141         case TYPE_CODE_FLT:
4142         case TYPE_CODE_FIXED_POINT:
4143           return 1;
4144         default:
4145           return 0;
4146         }
4147     }
4148 }
4149
4150 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
4151
4152 static int
4153 discrete_type_p (struct type *type)
4154 {
4155   if (type == NULL)
4156     return 0;
4157   else
4158     {
4159       switch (type->code ())
4160         {
4161         case TYPE_CODE_INT:
4162         case TYPE_CODE_RANGE:
4163         case TYPE_CODE_ENUM:
4164         case TYPE_CODE_BOOL:
4165           return 1;
4166         default:
4167           return 0;
4168         }
4169     }
4170 }
4171
4172 /* Returns non-zero if OP with operands in the vector ARGS could be
4173    a user-defined function.  Errs on the side of pre-defined operators
4174    (i.e., result 0).  */
4175
4176 static int
4177 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4178 {
4179   struct type *type0 =
4180     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4181   struct type *type1 =
4182     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4183
4184   if (type0 == NULL)
4185     return 0;
4186
4187   switch (op)
4188     {
4189     default:
4190       return 0;
4191
4192     case BINOP_ADD:
4193     case BINOP_SUB:
4194     case BINOP_MUL:
4195     case BINOP_DIV:
4196       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4197
4198     case BINOP_REM:
4199     case BINOP_MOD:
4200     case BINOP_BITWISE_AND:
4201     case BINOP_BITWISE_IOR:
4202     case BINOP_BITWISE_XOR:
4203       return (!(integer_type_p (type0) && integer_type_p (type1)));
4204
4205     case BINOP_EQUAL:
4206     case BINOP_NOTEQUAL:
4207     case BINOP_LESS:
4208     case BINOP_GTR:
4209     case BINOP_LEQ:
4210     case BINOP_GEQ:
4211       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4212
4213     case BINOP_CONCAT:
4214       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4215
4216     case BINOP_EXP:
4217       return (!(numeric_type_p (type0) && integer_type_p (type1)));
4218
4219     case UNOP_NEG:
4220     case UNOP_PLUS:
4221     case UNOP_LOGICAL_NOT:
4222     case UNOP_ABS:
4223       return (!numeric_type_p (type0));
4224
4225     }
4226 }
4227 \f
4228                                 /* Renaming */
4229
4230 /* NOTES: 
4231
4232    1. In the following, we assume that a renaming type's name may
4233       have an ___XD suffix.  It would be nice if this went away at some
4234       point.
4235    2. We handle both the (old) purely type-based representation of 
4236       renamings and the (new) variable-based encoding.  At some point,
4237       it is devoutly to be hoped that the former goes away 
4238       (FIXME: hilfinger-2007-07-09).
4239    3. Subprogram renamings are not implemented, although the XRS
4240       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
4241
4242 /* If SYM encodes a renaming, 
4243
4244        <renaming> renames <renamed entity>,
4245
4246    sets *LEN to the length of the renamed entity's name,
4247    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4248    the string describing the subcomponent selected from the renamed
4249    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4250    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4251    are undefined).  Otherwise, returns a value indicating the category
4252    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4253    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4254    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
4255    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4256    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4257    may be NULL, in which case they are not assigned.
4258
4259    [Currently, however, GCC does not generate subprogram renamings.]  */
4260
4261 enum ada_renaming_category
4262 ada_parse_renaming (struct symbol *sym,
4263                     const char **renamed_entity, int *len, 
4264                     const char **renaming_expr)
4265 {
4266   enum ada_renaming_category kind;
4267   const char *info;
4268   const char *suffix;
4269
4270   if (sym == NULL)
4271     return ADA_NOT_RENAMING;
4272   switch (sym->aclass ()) 
4273     {
4274     default:
4275       return ADA_NOT_RENAMING;
4276     case LOC_LOCAL:
4277     case LOC_STATIC:
4278     case LOC_COMPUTED:
4279     case LOC_OPTIMIZED_OUT:
4280       info = strstr (sym->linkage_name (), "___XR");
4281       if (info == NULL)
4282         return ADA_NOT_RENAMING;
4283       switch (info[5])
4284         {
4285         case '_':
4286           kind = ADA_OBJECT_RENAMING;
4287           info += 6;
4288           break;
4289         case 'E':
4290           kind = ADA_EXCEPTION_RENAMING;
4291           info += 7;
4292           break;
4293         case 'P':
4294           kind = ADA_PACKAGE_RENAMING;
4295           info += 7;
4296           break;
4297         case 'S':
4298           kind = ADA_SUBPROGRAM_RENAMING;
4299           info += 7;
4300           break;
4301         default:
4302           return ADA_NOT_RENAMING;
4303         }
4304     }
4305
4306   if (renamed_entity != NULL)
4307     *renamed_entity = info;
4308   suffix = strstr (info, "___XE");
4309   if (suffix == NULL || suffix == info)
4310     return ADA_NOT_RENAMING;
4311   if (len != NULL)
4312     *len = strlen (info) - strlen (suffix);
4313   suffix += 5;
4314   if (renaming_expr != NULL)
4315     *renaming_expr = suffix;
4316   return kind;
4317 }
4318
4319 /* Compute the value of the given RENAMING_SYM, which is expected to
4320    be a symbol encoding a renaming expression.  BLOCK is the block
4321    used to evaluate the renaming.  */
4322
4323 static struct value *
4324 ada_read_renaming_var_value (struct symbol *renaming_sym,
4325                              const struct block *block)
4326 {
4327   const char *sym_name;
4328
4329   sym_name = renaming_sym->linkage_name ();
4330   expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4331   return evaluate_expression (expr.get ());
4332 }
4333 \f
4334
4335                                 /* Evaluation: Function Calls */
4336
4337 /* Return an lvalue containing the value VAL.  This is the identity on
4338    lvalues, and otherwise has the side-effect of allocating memory
4339    in the inferior where a copy of the value contents is copied.  */
4340
4341 static struct value *
4342 ensure_lval (struct value *val)
4343 {
4344   if (VALUE_LVAL (val) == not_lval
4345       || VALUE_LVAL (val) == lval_internalvar)
4346     {
4347       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4348       const CORE_ADDR addr =
4349         value_as_long (value_allocate_space_in_inferior (len));
4350
4351       VALUE_LVAL (val) = lval_memory;
4352       set_value_address (val, addr);
4353       write_memory (addr, value_contents (val).data (), len);
4354     }
4355
4356   return val;
4357 }
4358
4359 /* Given ARG, a value of type (pointer or reference to a)*
4360    structure/union, extract the component named NAME from the ultimate
4361    target structure/union and return it as a value with its
4362    appropriate type.
4363
4364    The routine searches for NAME among all members of the structure itself
4365    and (recursively) among all members of any wrapper members
4366    (e.g., '_parent').
4367
4368    If NO_ERR, then simply return NULL in case of error, rather than
4369    calling error.  */
4370
4371 static struct value *
4372 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
4373 {
4374   struct type *t, *t1;
4375   struct value *v;
4376   int check_tag;
4377
4378   v = NULL;
4379   t1 = t = ada_check_typedef (value_type (arg));
4380   if (t->code () == TYPE_CODE_REF)
4381     {
4382       t1 = TYPE_TARGET_TYPE (t);
4383       if (t1 == NULL)
4384         goto BadValue;
4385       t1 = ada_check_typedef (t1);
4386       if (t1->code () == TYPE_CODE_PTR)
4387         {
4388           arg = coerce_ref (arg);
4389           t = t1;
4390         }
4391     }
4392
4393   while (t->code () == TYPE_CODE_PTR)
4394     {
4395       t1 = TYPE_TARGET_TYPE (t);
4396       if (t1 == NULL)
4397         goto BadValue;
4398       t1 = ada_check_typedef (t1);
4399       if (t1->code () == TYPE_CODE_PTR)
4400         {
4401           arg = value_ind (arg);
4402           t = t1;
4403         }
4404       else
4405         break;
4406     }
4407
4408   if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4409     goto BadValue;
4410
4411   if (t1 == t)
4412     v = ada_search_struct_field (name, arg, 0, t);
4413   else
4414     {
4415       int bit_offset, bit_size, byte_offset;
4416       struct type *field_type;
4417       CORE_ADDR address;
4418
4419       if (t->code () == TYPE_CODE_PTR)
4420         address = value_address (ada_value_ind (arg));
4421       else
4422         address = value_address (ada_coerce_ref (arg));
4423
4424       /* Check to see if this is a tagged type.  We also need to handle
4425          the case where the type is a reference to a tagged type, but
4426          we have to be careful to exclude pointers to tagged types.
4427          The latter should be shown as usual (as a pointer), whereas
4428          a reference should mostly be transparent to the user.  */
4429
4430       if (ada_is_tagged_type (t1, 0)
4431           || (t1->code () == TYPE_CODE_REF
4432               && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
4433         {
4434           /* We first try to find the searched field in the current type.
4435              If not found then let's look in the fixed type.  */
4436
4437           if (!find_struct_field (name, t1, 0,
4438                                   nullptr, nullptr, nullptr,
4439                                   nullptr, nullptr))
4440             check_tag = 1;
4441           else
4442             check_tag = 0;
4443         }
4444       else
4445         check_tag = 0;
4446
4447       /* Convert to fixed type in all cases, so that we have proper
4448          offsets to each field in unconstrained record types.  */
4449       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4450                               address, NULL, check_tag);
4451
4452       /* Resolve the dynamic type as well.  */
4453       arg = value_from_contents_and_address (t1, nullptr, address);
4454       t1 = value_type (arg);
4455
4456       if (find_struct_field (name, t1, 0,
4457                              &field_type, &byte_offset, &bit_offset,
4458                              &bit_size, NULL))
4459         {
4460           if (bit_size != 0)
4461             {
4462               if (t->code () == TYPE_CODE_REF)
4463                 arg = ada_coerce_ref (arg);
4464               else
4465                 arg = ada_value_ind (arg);
4466               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4467                                                   bit_offset, bit_size,
4468                                                   field_type);
4469             }
4470           else
4471             v = value_at_lazy (field_type, address + byte_offset);
4472         }
4473     }
4474
4475   if (v != NULL || no_err)
4476     return v;
4477   else
4478     error (_("There is no member named %s."), name);
4479
4480  BadValue:
4481   if (no_err)
4482     return NULL;
4483   else
4484     error (_("Attempt to extract a component of "
4485              "a value that is not a record."));
4486 }
4487
4488 /* Return the value ACTUAL, converted to be an appropriate value for a
4489    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4490    allocating any necessary descriptors (fat pointers), or copies of
4491    values not residing in memory, updating it as needed.  */
4492
4493 struct value *
4494 ada_convert_actual (struct value *actual, struct type *formal_type0)
4495 {
4496   struct type *actual_type = ada_check_typedef (value_type (actual));
4497   struct type *formal_type = ada_check_typedef (formal_type0);
4498   struct type *formal_target =
4499     formal_type->code () == TYPE_CODE_PTR
4500     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4501   struct type *actual_target =
4502     actual_type->code () == TYPE_CODE_PTR
4503     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4504
4505   if (ada_is_array_descriptor_type (formal_target)
4506       && actual_target->code () == TYPE_CODE_ARRAY)
4507     return make_array_descriptor (formal_type, actual);
4508   else if (formal_type->code () == TYPE_CODE_PTR
4509            || formal_type->code () == TYPE_CODE_REF)
4510     {
4511       struct value *result;
4512
4513       if (formal_target->code () == TYPE_CODE_ARRAY
4514           && ada_is_array_descriptor_type (actual_target))
4515         result = desc_data (actual);
4516       else if (formal_type->code () != TYPE_CODE_PTR)
4517         {
4518           if (VALUE_LVAL (actual) != lval_memory)
4519             {
4520               struct value *val;
4521
4522               actual_type = ada_check_typedef (value_type (actual));
4523               val = allocate_value (actual_type);
4524               copy (value_contents (actual), value_contents_raw (val));
4525               actual = ensure_lval (val);
4526             }
4527           result = value_addr (actual);
4528         }
4529       else
4530         return actual;
4531       return value_cast_pointers (formal_type, result, 0);
4532     }
4533   else if (actual_type->code () == TYPE_CODE_PTR)
4534     return ada_value_ind (actual);
4535   else if (ada_is_aligner_type (formal_type))
4536     {
4537       /* We need to turn this parameter into an aligner type
4538          as well.  */
4539       struct value *aligner = allocate_value (formal_type);
4540       struct value *component = ada_value_struct_elt (aligner, "F", 0);
4541
4542       value_assign_to_component (aligner, component, actual);
4543       return aligner;
4544     }
4545
4546   return actual;
4547 }
4548
4549 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4550    type TYPE.  This is usually an inefficient no-op except on some targets
4551    (such as AVR) where the representation of a pointer and an address
4552    differs.  */
4553
4554 static CORE_ADDR
4555 value_pointer (struct value *value, struct type *type)
4556 {
4557   unsigned len = TYPE_LENGTH (type);
4558   gdb_byte *buf = (gdb_byte *) alloca (len);
4559   CORE_ADDR addr;
4560
4561   addr = value_address (value);
4562   gdbarch_address_to_pointer (type->arch (), type, buf, addr);
4563   addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4564   return addr;
4565 }
4566
4567
4568 /* Push a descriptor of type TYPE for array value ARR on the stack at
4569    *SP, updating *SP to reflect the new descriptor.  Return either
4570    an lvalue representing the new descriptor, or (if TYPE is a pointer-
4571    to-descriptor type rather than a descriptor type), a struct value *
4572    representing a pointer to this descriptor.  */
4573
4574 static struct value *
4575 make_array_descriptor (struct type *type, struct value *arr)
4576 {
4577   struct type *bounds_type = desc_bounds_type (type);
4578   struct type *desc_type = desc_base_type (type);
4579   struct value *descriptor = allocate_value (desc_type);
4580   struct value *bounds = allocate_value (bounds_type);
4581   int i;
4582
4583   for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4584        i > 0; i -= 1)
4585     {
4586       modify_field (value_type (bounds),
4587                     value_contents_writeable (bounds).data (),
4588                     ada_array_bound (arr, i, 0),
4589                     desc_bound_bitpos (bounds_type, i, 0),
4590                     desc_bound_bitsize (bounds_type, i, 0));
4591       modify_field (value_type (bounds),
4592                     value_contents_writeable (bounds).data (),
4593                     ada_array_bound (arr, i, 1),
4594                     desc_bound_bitpos (bounds_type, i, 1),
4595                     desc_bound_bitsize (bounds_type, i, 1));
4596     }
4597
4598   bounds = ensure_lval (bounds);
4599
4600   modify_field (value_type (descriptor),
4601                 value_contents_writeable (descriptor).data (),
4602                 value_pointer (ensure_lval (arr),
4603                                desc_type->field (0).type ()),
4604                 fat_pntr_data_bitpos (desc_type),
4605                 fat_pntr_data_bitsize (desc_type));
4606
4607   modify_field (value_type (descriptor),
4608                 value_contents_writeable (descriptor).data (),
4609                 value_pointer (bounds,
4610                                desc_type->field (1).type ()),
4611                 fat_pntr_bounds_bitpos (desc_type),
4612                 fat_pntr_bounds_bitsize (desc_type));
4613
4614   descriptor = ensure_lval (descriptor);
4615
4616   if (type->code () == TYPE_CODE_PTR)
4617     return value_addr (descriptor);
4618   else
4619     return descriptor;
4620 }
4621 \f
4622                                 /* Symbol Cache Module */
4623
4624 /* Performance measurements made as of 2010-01-15 indicate that
4625    this cache does bring some noticeable improvements.  Depending
4626    on the type of entity being printed, the cache can make it as much
4627    as an order of magnitude faster than without it.
4628
4629    The descriptive type DWARF extension has significantly reduced
4630    the need for this cache, at least when DWARF is being used.  However,
4631    even in this case, some expensive name-based symbol searches are still
4632    sometimes necessary - to find an XVZ variable, mostly.  */
4633
4634 /* Return the symbol cache associated to the given program space PSPACE.
4635    If not allocated for this PSPACE yet, allocate and initialize one.  */
4636
4637 static struct ada_symbol_cache *
4638 ada_get_symbol_cache (struct program_space *pspace)
4639 {
4640   struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4641
4642   if (pspace_data->sym_cache == nullptr)
4643     pspace_data->sym_cache.reset (new ada_symbol_cache);
4644
4645   return pspace_data->sym_cache.get ();
4646 }
4647
4648 /* Clear all entries from the symbol cache.  */
4649
4650 static void
4651 ada_clear_symbol_cache ()
4652 {
4653   struct ada_pspace_data *pspace_data
4654     = get_ada_pspace_data (current_program_space);
4655
4656   if (pspace_data->sym_cache != nullptr)
4657     pspace_data->sym_cache.reset ();
4658 }
4659
4660 /* Search our cache for an entry matching NAME and DOMAIN.
4661    Return it if found, or NULL otherwise.  */
4662
4663 static struct cache_entry **
4664 find_entry (const char *name, domain_enum domain)
4665 {
4666   struct ada_symbol_cache *sym_cache
4667     = ada_get_symbol_cache (current_program_space);
4668   int h = msymbol_hash (name) % HASH_SIZE;
4669   struct cache_entry **e;
4670
4671   for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4672     {
4673       if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4674         return e;
4675     }
4676   return NULL;
4677 }
4678
4679 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4680    Return 1 if found, 0 otherwise.
4681
4682    If an entry was found and SYM is not NULL, set *SYM to the entry's
4683    SYM.  Same principle for BLOCK if not NULL.  */
4684
4685 static int
4686 lookup_cached_symbol (const char *name, domain_enum domain,
4687                       struct symbol **sym, const struct block **block)
4688 {
4689   struct cache_entry **e = find_entry (name, domain);
4690
4691   if (e == NULL)
4692     return 0;
4693   if (sym != NULL)
4694     *sym = (*e)->sym;
4695   if (block != NULL)
4696     *block = (*e)->block;
4697   return 1;
4698 }
4699
4700 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4701    in domain DOMAIN, save this result in our symbol cache.  */
4702
4703 static void
4704 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4705               const struct block *block)
4706 {
4707   struct ada_symbol_cache *sym_cache
4708     = ada_get_symbol_cache (current_program_space);
4709   int h;
4710   struct cache_entry *e;
4711
4712   /* Symbols for builtin types don't have a block.
4713      For now don't cache such symbols.  */
4714   if (sym != NULL && !sym->is_objfile_owned ())
4715     return;
4716
4717   /* If the symbol is a local symbol, then do not cache it, as a search
4718      for that symbol depends on the context.  To determine whether
4719      the symbol is local or not, we check the block where we found it
4720      against the global and static blocks of its associated symtab.  */
4721   if (sym != nullptr)
4722     {
4723       const blockvector &bv = *sym->symtab ()->compunit ()->blockvector ();
4724
4725       if (bv.global_block () != block && bv.static_block () != block)
4726         return;
4727     }
4728
4729   h = msymbol_hash (name) % HASH_SIZE;
4730   e = XOBNEW (&sym_cache->cache_space, cache_entry);
4731   e->next = sym_cache->root[h];
4732   sym_cache->root[h] = e;
4733   e->name = obstack_strdup (&sym_cache->cache_space, name);
4734   e->sym = sym;
4735   e->domain = domain;
4736   e->block = block;
4737 }
4738 \f
4739                                 /* Symbol Lookup */
4740
4741 /* Return the symbol name match type that should be used used when
4742    searching for all symbols matching LOOKUP_NAME.
4743
4744    LOOKUP_NAME is expected to be a symbol name after transformation
4745    for Ada lookups.  */
4746
4747 static symbol_name_match_type
4748 name_match_type_from_name (const char *lookup_name)
4749 {
4750   return (strstr (lookup_name, "__") == NULL
4751           ? symbol_name_match_type::WILD
4752           : symbol_name_match_type::FULL);
4753 }
4754
4755 /* Return the result of a standard (literal, C-like) lookup of NAME in
4756    given DOMAIN, visible from lexical block BLOCK.  */
4757
4758 static struct symbol *
4759 standard_lookup (const char *name, const struct block *block,
4760                  domain_enum domain)
4761 {
4762   /* Initialize it just to avoid a GCC false warning.  */
4763   struct block_symbol sym = {};
4764
4765   if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4766     return sym.symbol;
4767   ada_lookup_encoded_symbol (name, block, domain, &sym);
4768   cache_symbol (name, domain, sym.symbol, sym.block);
4769   return sym.symbol;
4770 }
4771
4772
4773 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4774    in the symbol fields of SYMS.  We treat enumerals as functions, 
4775    since they contend in overloading in the same way.  */
4776 static int
4777 is_nonfunction (const std::vector<struct block_symbol> &syms)
4778 {
4779   for (const block_symbol &sym : syms)
4780     if (sym.symbol->type ()->code () != TYPE_CODE_FUNC
4781         && (sym.symbol->type ()->code () != TYPE_CODE_ENUM
4782             || sym.symbol->aclass () != LOC_CONST))
4783       return 1;
4784
4785   return 0;
4786 }
4787
4788 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4789    struct types.  Otherwise, they may not.  */
4790
4791 static int
4792 equiv_types (struct type *type0, struct type *type1)
4793 {
4794   if (type0 == type1)
4795     return 1;
4796   if (type0 == NULL || type1 == NULL
4797       || type0->code () != type1->code ())
4798     return 0;
4799   if ((type0->code () == TYPE_CODE_STRUCT
4800        || type0->code () == TYPE_CODE_ENUM)
4801       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4802       && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4803     return 1;
4804
4805   return 0;
4806 }
4807
4808 /* True iff SYM0 represents the same entity as SYM1, or one that is
4809    no more defined than that of SYM1.  */
4810
4811 static int
4812 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4813 {
4814   if (sym0 == sym1)
4815     return 1;
4816   if (sym0->domain () != sym1->domain ()
4817       || sym0->aclass () != sym1->aclass ())
4818     return 0;
4819
4820   switch (sym0->aclass ())
4821     {
4822     case LOC_UNDEF:
4823       return 1;
4824     case LOC_TYPEDEF:
4825       {
4826         struct type *type0 = sym0->type ();
4827         struct type *type1 = sym1->type ();
4828         const char *name0 = sym0->linkage_name ();
4829         const char *name1 = sym1->linkage_name ();
4830         int len0 = strlen (name0);
4831
4832         return
4833           type0->code () == type1->code ()
4834           && (equiv_types (type0, type1)
4835               || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4836                   && startswith (name1 + len0, "___XV")));
4837       }
4838     case LOC_CONST:
4839       return sym0->value_longest () == sym1->value_longest ()
4840         && equiv_types (sym0->type (), sym1->type ());
4841
4842     case LOC_STATIC:
4843       {
4844         const char *name0 = sym0->linkage_name ();
4845         const char *name1 = sym1->linkage_name ();
4846         return (strcmp (name0, name1) == 0
4847                 && sym0->value_address () == sym1->value_address ());
4848       }
4849
4850     default:
4851       return 0;
4852     }
4853 }
4854
4855 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4856    records in RESULT.  Do nothing if SYM is a duplicate.  */
4857
4858 static void
4859 add_defn_to_vec (std::vector<struct block_symbol> &result,
4860                  struct symbol *sym,
4861                  const struct block *block)
4862 {
4863   /* Do not try to complete stub types, as the debugger is probably
4864      already scanning all symbols matching a certain name at the
4865      time when this function is called.  Trying to replace the stub
4866      type by its associated full type will cause us to restart a scan
4867      which may lead to an infinite recursion.  Instead, the client
4868      collecting the matching symbols will end up collecting several
4869      matches, with at least one of them complete.  It can then filter
4870      out the stub ones if needed.  */
4871
4872   for (int i = result.size () - 1; i >= 0; i -= 1)
4873     {
4874       if (lesseq_defined_than (sym, result[i].symbol))
4875         return;
4876       else if (lesseq_defined_than (result[i].symbol, sym))
4877         {
4878           result[i].symbol = sym;
4879           result[i].block = block;
4880           return;
4881         }
4882     }
4883
4884   struct block_symbol info;
4885   info.symbol = sym;
4886   info.block = block;
4887   result.push_back (info);
4888 }
4889
4890 /* Return a bound minimal symbol matching NAME according to Ada
4891    decoding rules.  Returns an invalid symbol if there is no such
4892    minimal symbol.  Names prefixed with "standard__" are handled
4893    specially: "standard__" is first stripped off, and only static and
4894    global symbols are searched.  */
4895
4896 struct bound_minimal_symbol
4897 ada_lookup_simple_minsym (const char *name)
4898 {
4899   struct bound_minimal_symbol result;
4900
4901   symbol_name_match_type match_type = name_match_type_from_name (name);
4902   lookup_name_info lookup_name (name, match_type);
4903
4904   symbol_name_matcher_ftype *match_name
4905     = ada_get_symbol_name_matcher (lookup_name);
4906
4907   for (objfile *objfile : current_program_space->objfiles ())
4908     {
4909       for (minimal_symbol *msymbol : objfile->msymbols ())
4910         {
4911           if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4912               && msymbol->type () != mst_solib_trampoline)
4913             {
4914               result.minsym = msymbol;
4915               result.objfile = objfile;
4916               break;
4917             }
4918         }
4919     }
4920
4921   return result;
4922 }
4923
4924 /* True if TYPE is definitely an artificial type supplied to a symbol
4925    for which no debugging information was given in the symbol file.  */
4926
4927 static int
4928 is_nondebugging_type (struct type *type)
4929 {
4930   const char *name = ada_type_name (type);
4931
4932   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4933 }
4934
4935 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4936    that are deemed "identical" for practical purposes.
4937
4938    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4939    types and that their number of enumerals is identical (in other
4940    words, type1->num_fields () == type2->num_fields ()).  */
4941
4942 static int
4943 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4944 {
4945   int i;
4946
4947   /* The heuristic we use here is fairly conservative.  We consider
4948      that 2 enumerate types are identical if they have the same
4949      number of enumerals and that all enumerals have the same
4950      underlying value and name.  */
4951
4952   /* All enums in the type should have an identical underlying value.  */
4953   for (i = 0; i < type1->num_fields (); i++)
4954     if (type1->field (i).loc_enumval () != type2->field (i).loc_enumval ())
4955       return 0;
4956
4957   /* All enumerals should also have the same name (modulo any numerical
4958      suffix).  */
4959   for (i = 0; i < type1->num_fields (); i++)
4960     {
4961       const char *name_1 = type1->field (i).name ();
4962       const char *name_2 = type2->field (i).name ();
4963       int len_1 = strlen (name_1);
4964       int len_2 = strlen (name_2);
4965
4966       ada_remove_trailing_digits (type1->field (i).name (), &len_1);
4967       ada_remove_trailing_digits (type2->field (i).name (), &len_2);
4968       if (len_1 != len_2
4969           || strncmp (type1->field (i).name (),
4970                       type2->field (i).name (),
4971                       len_1) != 0)
4972         return 0;
4973     }
4974
4975   return 1;
4976 }
4977
4978 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4979    that are deemed "identical" for practical purposes.  Sometimes,
4980    enumerals are not strictly identical, but their types are so similar
4981    that they can be considered identical.
4982
4983    For instance, consider the following code:
4984
4985       type Color is (Black, Red, Green, Blue, White);
4986       type RGB_Color is new Color range Red .. Blue;
4987
4988    Type RGB_Color is a subrange of an implicit type which is a copy
4989    of type Color. If we call that implicit type RGB_ColorB ("B" is
4990    for "Base Type"), then type RGB_ColorB is a copy of type Color.
4991    As a result, when an expression references any of the enumeral
4992    by name (Eg. "print green"), the expression is technically
4993    ambiguous and the user should be asked to disambiguate. But
4994    doing so would only hinder the user, since it wouldn't matter
4995    what choice he makes, the outcome would always be the same.
4996    So, for practical purposes, we consider them as the same.  */
4997
4998 static int
4999 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
5000 {
5001   int i;
5002
5003   /* Before performing a thorough comparison check of each type,
5004      we perform a series of inexpensive checks.  We expect that these
5005      checks will quickly fail in the vast majority of cases, and thus
5006      help prevent the unnecessary use of a more expensive comparison.
5007      Said comparison also expects us to make some of these checks
5008      (see ada_identical_enum_types_p).  */
5009
5010   /* Quick check: All symbols should have an enum type.  */
5011   for (i = 0; i < syms.size (); i++)
5012     if (syms[i].symbol->type ()->code () != TYPE_CODE_ENUM)
5013       return 0;
5014
5015   /* Quick check: They should all have the same value.  */
5016   for (i = 1; i < syms.size (); i++)
5017     if (syms[i].symbol->value_longest () != syms[0].symbol->value_longest ())
5018       return 0;
5019
5020   /* Quick check: They should all have the same number of enumerals.  */
5021   for (i = 1; i < syms.size (); i++)
5022     if (syms[i].symbol->type ()->num_fields ()
5023         != syms[0].symbol->type ()->num_fields ())
5024       return 0;
5025
5026   /* All the sanity checks passed, so we might have a set of
5027      identical enumeration types.  Perform a more complete
5028      comparison of the type of each symbol.  */
5029   for (i = 1; i < syms.size (); i++)
5030     if (!ada_identical_enum_types_p (syms[i].symbol->type (),
5031                                      syms[0].symbol->type ()))
5032       return 0;
5033
5034   return 1;
5035 }
5036
5037 /* Remove any non-debugging symbols in SYMS that definitely
5038    duplicate other symbols in the list (The only case I know of where
5039    this happens is when object files containing stabs-in-ecoff are
5040    linked with files containing ordinary ecoff debugging symbols (or no
5041    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.  */
5042
5043 static void
5044 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5045 {
5046   int i, j;
5047
5048   /* We should never be called with less than 2 symbols, as there
5049      cannot be any extra symbol in that case.  But it's easy to
5050      handle, since we have nothing to do in that case.  */
5051   if (syms->size () < 2)
5052     return;
5053
5054   i = 0;
5055   while (i < syms->size ())
5056     {
5057       int remove_p = 0;
5058
5059       /* If two symbols have the same name and one of them is a stub type,
5060          the get rid of the stub.  */
5061
5062       if ((*syms)[i].symbol->type ()->is_stub ()
5063           && (*syms)[i].symbol->linkage_name () != NULL)
5064         {
5065           for (j = 0; j < syms->size (); j++)
5066             {
5067               if (j != i
5068                   && !(*syms)[j].symbol->type ()->is_stub ()
5069                   && (*syms)[j].symbol->linkage_name () != NULL
5070                   && strcmp ((*syms)[i].symbol->linkage_name (),
5071                              (*syms)[j].symbol->linkage_name ()) == 0)
5072                 remove_p = 1;
5073             }
5074         }
5075
5076       /* Two symbols with the same name, same class and same address
5077          should be identical.  */
5078
5079       else if ((*syms)[i].symbol->linkage_name () != NULL
5080           && (*syms)[i].symbol->aclass () == LOC_STATIC
5081           && is_nondebugging_type ((*syms)[i].symbol->type ()))
5082         {
5083           for (j = 0; j < syms->size (); j += 1)
5084             {
5085               if (i != j
5086                   && (*syms)[j].symbol->linkage_name () != NULL
5087                   && strcmp ((*syms)[i].symbol->linkage_name (),
5088                              (*syms)[j].symbol->linkage_name ()) == 0
5089                   && ((*syms)[i].symbol->aclass ()
5090                       == (*syms)[j].symbol->aclass ())
5091                   && (*syms)[i].symbol->value_address ()
5092                   == (*syms)[j].symbol->value_address ())
5093                 remove_p = 1;
5094             }
5095         }
5096       
5097       if (remove_p)
5098         syms->erase (syms->begin () + i);
5099       else
5100         i += 1;
5101     }
5102
5103   /* If all the remaining symbols are identical enumerals, then
5104      just keep the first one and discard the rest.
5105
5106      Unlike what we did previously, we do not discard any entry
5107      unless they are ALL identical.  This is because the symbol
5108      comparison is not a strict comparison, but rather a practical
5109      comparison.  If all symbols are considered identical, then
5110      we can just go ahead and use the first one and discard the rest.
5111      But if we cannot reduce the list to a single element, we have
5112      to ask the user to disambiguate anyways.  And if we have to
5113      present a multiple-choice menu, it's less confusing if the list
5114      isn't missing some choices that were identical and yet distinct.  */
5115   if (symbols_are_identical_enums (*syms))
5116     syms->resize (1);
5117 }
5118
5119 /* Given a type that corresponds to a renaming entity, use the type name
5120    to extract the scope (package name or function name, fully qualified,
5121    and following the GNAT encoding convention) where this renaming has been
5122    defined.  */
5123
5124 static std::string
5125 xget_renaming_scope (struct type *renaming_type)
5126 {
5127   /* The renaming types adhere to the following convention:
5128      <scope>__<rename>___<XR extension>.
5129      So, to extract the scope, we search for the "___XR" extension,
5130      and then backtrack until we find the first "__".  */
5131
5132   const char *name = renaming_type->name ();
5133   const char *suffix = strstr (name, "___XR");
5134   const char *last;
5135
5136   /* Now, backtrack a bit until we find the first "__".  Start looking
5137      at suffix - 3, as the <rename> part is at least one character long.  */
5138
5139   for (last = suffix - 3; last > name; last--)
5140     if (last[0] == '_' && last[1] == '_')
5141       break;
5142
5143   /* Make a copy of scope and return it.  */
5144   return std::string (name, last);
5145 }
5146
5147 /* Return nonzero if NAME corresponds to a package name.  */
5148
5149 static int
5150 is_package_name (const char *name)
5151 {
5152   /* Here, We take advantage of the fact that no symbols are generated
5153      for packages, while symbols are generated for each function.
5154      So the condition for NAME represent a package becomes equivalent
5155      to NAME not existing in our list of symbols.  There is only one
5156      small complication with library-level functions (see below).  */
5157
5158   /* If it is a function that has not been defined at library level,
5159      then we should be able to look it up in the symbols.  */
5160   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5161     return 0;
5162
5163   /* Library-level function names start with "_ada_".  See if function
5164      "_ada_" followed by NAME can be found.  */
5165
5166   /* Do a quick check that NAME does not contain "__", since library-level
5167      functions names cannot contain "__" in them.  */
5168   if (strstr (name, "__") != NULL)
5169     return 0;
5170
5171   std::string fun_name = string_printf ("_ada_%s", name);
5172
5173   return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5174 }
5175
5176 /* Return nonzero if SYM corresponds to a renaming entity that is
5177    not visible from FUNCTION_NAME.  */
5178
5179 static int
5180 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5181 {
5182   if (sym->aclass () != LOC_TYPEDEF)
5183     return 0;
5184
5185   std::string scope = xget_renaming_scope (sym->type ());
5186
5187   /* If the rename has been defined in a package, then it is visible.  */
5188   if (is_package_name (scope.c_str ()))
5189     return 0;
5190
5191   /* Check that the rename is in the current function scope by checking
5192      that its name starts with SCOPE.  */
5193
5194   /* If the function name starts with "_ada_", it means that it is
5195      a library-level function.  Strip this prefix before doing the
5196      comparison, as the encoding for the renaming does not contain
5197      this prefix.  */
5198   if (startswith (function_name, "_ada_"))
5199     function_name += 5;
5200
5201   return !startswith (function_name, scope.c_str ());
5202 }
5203
5204 /* Remove entries from SYMS that corresponds to a renaming entity that
5205    is not visible from the function associated with CURRENT_BLOCK or
5206    that is superfluous due to the presence of more specific renaming
5207    information.  Places surviving symbols in the initial entries of
5208    SYMS.
5209
5210    Rationale:
5211    First, in cases where an object renaming is implemented as a
5212    reference variable, GNAT may produce both the actual reference
5213    variable and the renaming encoding.  In this case, we discard the
5214    latter.
5215
5216    Second, GNAT emits a type following a specified encoding for each renaming
5217    entity.  Unfortunately, STABS currently does not support the definition
5218    of types that are local to a given lexical block, so all renamings types
5219    are emitted at library level.  As a consequence, if an application
5220    contains two renaming entities using the same name, and a user tries to
5221    print the value of one of these entities, the result of the ada symbol
5222    lookup will also contain the wrong renaming type.
5223
5224    This function partially covers for this limitation by attempting to
5225    remove from the SYMS list renaming symbols that should be visible
5226    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
5227    method with the current information available.  The implementation
5228    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
5229    
5230       - When the user tries to print a rename in a function while there
5231         is another rename entity defined in a package:  Normally, the
5232         rename in the function has precedence over the rename in the
5233         package, so the latter should be removed from the list.  This is
5234         currently not the case.
5235         
5236       - This function will incorrectly remove valid renames if
5237         the CURRENT_BLOCK corresponds to a function which symbol name
5238         has been changed by an "Export" pragma.  As a consequence,
5239         the user will be unable to print such rename entities.  */
5240
5241 static void
5242 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5243                              const struct block *current_block)
5244 {
5245   struct symbol *current_function;
5246   const char *current_function_name;
5247   int i;
5248   int is_new_style_renaming;
5249
5250   /* If there is both a renaming foo___XR... encoded as a variable and
5251      a simple variable foo in the same block, discard the latter.
5252      First, zero out such symbols, then compress.  */
5253   is_new_style_renaming = 0;
5254   for (i = 0; i < syms->size (); i += 1)
5255     {
5256       struct symbol *sym = (*syms)[i].symbol;
5257       const struct block *block = (*syms)[i].block;
5258       const char *name;
5259       const char *suffix;
5260
5261       if (sym == NULL || sym->aclass () == LOC_TYPEDEF)
5262         continue;
5263       name = sym->linkage_name ();
5264       suffix = strstr (name, "___XR");
5265
5266       if (suffix != NULL)
5267         {
5268           int name_len = suffix - name;
5269           int j;
5270
5271           is_new_style_renaming = 1;
5272           for (j = 0; j < syms->size (); j += 1)
5273             if (i != j && (*syms)[j].symbol != NULL
5274                 && strncmp (name, (*syms)[j].symbol->linkage_name (),
5275                             name_len) == 0
5276                 && block == (*syms)[j].block)
5277               (*syms)[j].symbol = NULL;
5278         }
5279     }
5280   if (is_new_style_renaming)
5281     {
5282       int j, k;
5283
5284       for (j = k = 0; j < syms->size (); j += 1)
5285         if ((*syms)[j].symbol != NULL)
5286             {
5287               (*syms)[k] = (*syms)[j];
5288               k += 1;
5289             }
5290       syms->resize (k);
5291       return;
5292     }
5293
5294   /* Extract the function name associated to CURRENT_BLOCK.
5295      Abort if unable to do so.  */
5296
5297   if (current_block == NULL)
5298     return;
5299
5300   current_function = block_linkage_function (current_block);
5301   if (current_function == NULL)
5302     return;
5303
5304   current_function_name = current_function->linkage_name ();
5305   if (current_function_name == NULL)
5306     return;
5307
5308   /* Check each of the symbols, and remove it from the list if it is
5309      a type corresponding to a renaming that is out of the scope of
5310      the current block.  */
5311
5312   i = 0;
5313   while (i < syms->size ())
5314     {
5315       if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5316           == ADA_OBJECT_RENAMING
5317           && old_renaming_is_invisible ((*syms)[i].symbol,
5318                                         current_function_name))
5319         syms->erase (syms->begin () + i);
5320       else
5321         i += 1;
5322     }
5323 }
5324
5325 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
5326    whose name and domain match LOOKUP_NAME and DOMAIN respectively.
5327
5328    Note: This function assumes that RESULT is empty.  */
5329
5330 static void
5331 ada_add_local_symbols (std::vector<struct block_symbol> &result,
5332                        const lookup_name_info &lookup_name,
5333                        const struct block *block, domain_enum domain)
5334 {
5335   while (block != NULL)
5336     {
5337       ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5338
5339       /* If we found a non-function match, assume that's the one.  We
5340          only check this when finding a function boundary, so that we
5341          can accumulate all results from intervening blocks first.  */
5342       if (block->function () != nullptr && is_nonfunction (result))
5343         return;
5344
5345       block = block->superblock ();
5346     }
5347 }
5348
5349 /* An object of this type is used as the callback argument when
5350    calling the map_matching_symbols method.  */
5351
5352 struct match_data
5353 {
5354   explicit match_data (std::vector<struct block_symbol> *rp)
5355     : resultp (rp)
5356   {
5357   }
5358   DISABLE_COPY_AND_ASSIGN (match_data);
5359
5360   bool operator() (struct block_symbol *bsym);
5361
5362   struct objfile *objfile = nullptr;
5363   std::vector<struct block_symbol> *resultp;
5364   struct symbol *arg_sym = nullptr;
5365   bool found_sym = false;
5366 };
5367
5368 /* A callback for add_nonlocal_symbols that adds symbol, found in
5369    BSYM, to a list of symbols.  */
5370
5371 bool
5372 match_data::operator() (struct block_symbol *bsym)
5373 {
5374   const struct block *block = bsym->block;
5375   struct symbol *sym = bsym->symbol;
5376
5377   if (sym == NULL)
5378     {
5379       if (!found_sym && arg_sym != NULL)
5380         add_defn_to_vec (*resultp,
5381                          fixup_symbol_section (arg_sym, objfile),
5382                          block);
5383       found_sym = false;
5384       arg_sym = NULL;
5385     }
5386   else 
5387     {
5388       if (sym->aclass () == LOC_UNRESOLVED)
5389         return true;
5390       else if (sym->is_argument ())
5391         arg_sym = sym;
5392       else
5393         {
5394           found_sym = true;
5395           add_defn_to_vec (*resultp,
5396                            fixup_symbol_section (sym, objfile),
5397                            block);
5398         }
5399     }
5400   return true;
5401 }
5402
5403 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5404    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5405    symbols to RESULT.  Return whether we found such symbols.  */
5406
5407 static int
5408 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5409                          const struct block *block,
5410                          const lookup_name_info &lookup_name,
5411                          domain_enum domain)
5412 {
5413   struct using_direct *renaming;
5414   int defns_mark = result.size ();
5415
5416   symbol_name_matcher_ftype *name_match
5417     = ada_get_symbol_name_matcher (lookup_name);
5418
5419   for (renaming = block_using (block);
5420        renaming != NULL;
5421        renaming = renaming->next)
5422     {
5423       const char *r_name;
5424
5425       /* Avoid infinite recursions: skip this renaming if we are actually
5426          already traversing it.
5427
5428          Currently, symbol lookup in Ada don't use the namespace machinery from
5429          C++/Fortran support: skip namespace imports that use them.  */
5430       if (renaming->searched
5431           || (renaming->import_src != NULL
5432               && renaming->import_src[0] != '\0')
5433           || (renaming->import_dest != NULL
5434               && renaming->import_dest[0] != '\0'))
5435         continue;
5436       renaming->searched = 1;
5437
5438       /* TODO: here, we perform another name-based symbol lookup, which can
5439          pull its own multiple overloads.  In theory, we should be able to do
5440          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5441          not a simple name.  But in order to do this, we would need to enhance
5442          the DWARF reader to associate a symbol to this renaming, instead of a
5443          name.  So, for now, we do something simpler: re-use the C++/Fortran
5444          namespace machinery.  */
5445       r_name = (renaming->alias != NULL
5446                 ? renaming->alias
5447                 : renaming->declaration);
5448       if (name_match (r_name, lookup_name, NULL))
5449         {
5450           lookup_name_info decl_lookup_name (renaming->declaration,
5451                                              lookup_name.match_type ());
5452           ada_add_all_symbols (result, block, decl_lookup_name, domain,
5453                                1, NULL);
5454         }
5455       renaming->searched = 0;
5456     }
5457   return result.size () != defns_mark;
5458 }
5459
5460 /* Implements compare_names, but only applying the comparision using
5461    the given CASING.  */
5462
5463 static int
5464 compare_names_with_case (const char *string1, const char *string2,
5465                          enum case_sensitivity casing)
5466 {
5467   while (*string1 != '\0' && *string2 != '\0')
5468     {
5469       char c1, c2;
5470
5471       if (isspace (*string1) || isspace (*string2))
5472         return strcmp_iw_ordered (string1, string2);
5473
5474       if (casing == case_sensitive_off)
5475         {
5476           c1 = tolower (*string1);
5477           c2 = tolower (*string2);
5478         }
5479       else
5480         {
5481           c1 = *string1;
5482           c2 = *string2;
5483         }
5484       if (c1 != c2)
5485         break;
5486
5487       string1 += 1;
5488       string2 += 1;
5489     }
5490
5491   switch (*string1)
5492     {
5493     case '(':
5494       return strcmp_iw_ordered (string1, string2);
5495     case '_':
5496       if (*string2 == '\0')
5497         {
5498           if (is_name_suffix (string1))
5499             return 0;
5500           else
5501             return 1;
5502         }
5503       /* FALLTHROUGH */
5504     default:
5505       if (*string2 == '(')
5506         return strcmp_iw_ordered (string1, string2);
5507       else
5508         {
5509           if (casing == case_sensitive_off)
5510             return tolower (*string1) - tolower (*string2);
5511           else
5512             return *string1 - *string2;
5513         }
5514     }
5515 }
5516
5517 /* Compare STRING1 to STRING2, with results as for strcmp.
5518    Compatible with strcmp_iw_ordered in that...
5519
5520        strcmp_iw_ordered (STRING1, STRING2) <= 0
5521
5522    ... implies...
5523
5524        compare_names (STRING1, STRING2) <= 0
5525
5526    (they may differ as to what symbols compare equal).  */
5527
5528 static int
5529 compare_names (const char *string1, const char *string2)
5530 {
5531   int result;
5532
5533   /* Similar to what strcmp_iw_ordered does, we need to perform
5534      a case-insensitive comparison first, and only resort to
5535      a second, case-sensitive, comparison if the first one was
5536      not sufficient to differentiate the two strings.  */
5537
5538   result = compare_names_with_case (string1, string2, case_sensitive_off);
5539   if (result == 0)
5540     result = compare_names_with_case (string1, string2, case_sensitive_on);
5541
5542   return result;
5543 }
5544
5545 /* Convenience function to get at the Ada encoded lookup name for
5546    LOOKUP_NAME, as a C string.  */
5547
5548 static const char *
5549 ada_lookup_name (const lookup_name_info &lookup_name)
5550 {
5551   return lookup_name.ada ().lookup_name ().c_str ();
5552 }
5553
5554 /* A helper for add_nonlocal_symbols.  Call expand_matching_symbols
5555    for OBJFILE, then walk the objfile's symtabs and update the
5556    results.  */
5557
5558 static void
5559 map_matching_symbols (struct objfile *objfile,
5560                       const lookup_name_info &lookup_name,
5561                       bool is_wild_match,
5562                       domain_enum domain,
5563                       int global,
5564                       match_data &data)
5565 {
5566   data.objfile = objfile;
5567   objfile->expand_matching_symbols (lookup_name, domain, global,
5568                                     is_wild_match ? nullptr : compare_names);
5569
5570   const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5571   for (compunit_symtab *symtab : objfile->compunits ())
5572     {
5573       const struct block *block
5574         = symtab->blockvector ()->block (block_kind);
5575       if (!iterate_over_symbols_terminated (block, lookup_name,
5576                                             domain, data))
5577         break;
5578     }
5579 }
5580
5581 /* Add to RESULT all non-local symbols whose name and domain match
5582    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5583    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5584    symbols otherwise.  */
5585
5586 static void
5587 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5588                       const lookup_name_info &lookup_name,
5589                       domain_enum domain, int global)
5590 {
5591   struct match_data data (&result);
5592
5593   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5594
5595   for (objfile *objfile : current_program_space->objfiles ())
5596     {
5597       map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5598                             global, data);
5599
5600       for (compunit_symtab *cu : objfile->compunits ())
5601         {
5602           const struct block *global_block
5603             = cu->blockvector ()->global_block ();
5604
5605           if (ada_add_block_renamings (result, global_block, lookup_name,
5606                                        domain))
5607             data.found_sym = true;
5608         }
5609     }
5610
5611   if (result.empty () && global && !is_wild_match)
5612     {
5613       const char *name = ada_lookup_name (lookup_name);
5614       std::string bracket_name = std::string ("<_ada_") + name + '>';
5615       lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5616
5617       for (objfile *objfile : current_program_space->objfiles ())
5618         map_matching_symbols (objfile, name1, false, domain, global, data);
5619     }
5620 }
5621
5622 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5623    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5624    returning the number of matches.  Add these to RESULT.
5625
5626    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5627    symbol match within the nest of blocks whose innermost member is BLOCK,
5628    is the one match returned (no other matches in that or
5629    enclosing blocks is returned).  If there are any matches in or
5630    surrounding BLOCK, then these alone are returned.
5631
5632    Names prefixed with "standard__" are handled specially:
5633    "standard__" is first stripped off (by the lookup_name
5634    constructor), and only static and global symbols are searched.
5635
5636    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5637    to lookup global symbols.  */
5638
5639 static void
5640 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5641                      const struct block *block,
5642                      const lookup_name_info &lookup_name,
5643                      domain_enum domain,
5644                      int full_search,
5645                      int *made_global_lookup_p)
5646 {
5647   struct symbol *sym;
5648
5649   if (made_global_lookup_p)
5650     *made_global_lookup_p = 0;
5651
5652   /* Special case: If the user specifies a symbol name inside package
5653      Standard, do a non-wild matching of the symbol name without
5654      the "standard__" prefix.  This was primarily introduced in order
5655      to allow the user to specifically access the standard exceptions
5656      using, for instance, Standard.Constraint_Error when Constraint_Error
5657      is ambiguous (due to the user defining its own Constraint_Error
5658      entity inside its program).  */
5659   if (lookup_name.ada ().standard_p ())
5660     block = NULL;
5661
5662   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5663
5664   if (block != NULL)
5665     {
5666       if (full_search)
5667         ada_add_local_symbols (result, lookup_name, block, domain);
5668       else
5669         {
5670           /* In the !full_search case we're are being called by
5671              iterate_over_symbols, and we don't want to search
5672              superblocks.  */
5673           ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5674         }
5675       if (!result.empty () || !full_search)
5676         return;
5677     }
5678
5679   /* No non-global symbols found.  Check our cache to see if we have
5680      already performed this search before.  If we have, then return
5681      the same result.  */
5682
5683   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5684                             domain, &sym, &block))
5685     {
5686       if (sym != NULL)
5687         add_defn_to_vec (result, sym, block);
5688       return;
5689     }
5690
5691   if (made_global_lookup_p)
5692     *made_global_lookup_p = 1;
5693
5694   /* Search symbols from all global blocks.  */
5695  
5696   add_nonlocal_symbols (result, lookup_name, domain, 1);
5697
5698   /* Now add symbols from all per-file blocks if we've gotten no hits
5699      (not strictly correct, but perhaps better than an error).  */
5700
5701   if (result.empty ())
5702     add_nonlocal_symbols (result, lookup_name, domain, 0);
5703 }
5704
5705 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5706    is non-zero, enclosing scope and in global scopes.
5707
5708    Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5709    blocks and symbol tables (if any) in which they were found.
5710
5711    When full_search is non-zero, any non-function/non-enumeral
5712    symbol match within the nest of blocks whose innermost member is BLOCK,
5713    is the one match returned (no other matches in that or
5714    enclosing blocks is returned).  If there are any matches in or
5715    surrounding BLOCK, then these alone are returned.
5716
5717    Names prefixed with "standard__" are handled specially: "standard__"
5718    is first stripped off, and only static and global symbols are searched.  */
5719
5720 static std::vector<struct block_symbol>
5721 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5722                                const struct block *block,
5723                                domain_enum domain,
5724                                int full_search)
5725 {
5726   int syms_from_global_search;
5727   std::vector<struct block_symbol> results;
5728
5729   ada_add_all_symbols (results, block, lookup_name,
5730                        domain, full_search, &syms_from_global_search);
5731
5732   remove_extra_symbols (&results);
5733
5734   if (results.empty () && full_search && syms_from_global_search)
5735     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5736
5737   if (results.size () == 1 && full_search && syms_from_global_search)
5738     cache_symbol (ada_lookup_name (lookup_name), domain,
5739                   results[0].symbol, results[0].block);
5740
5741   remove_irrelevant_renamings (&results, block);
5742   return results;
5743 }
5744
5745 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5746    in global scopes, returning (SYM,BLOCK) tuples.
5747
5748    See ada_lookup_symbol_list_worker for further details.  */
5749
5750 std::vector<struct block_symbol>
5751 ada_lookup_symbol_list (const char *name, const struct block *block,
5752                         domain_enum domain)
5753 {
5754   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5755   lookup_name_info lookup_name (name, name_match_type);
5756
5757   return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5758 }
5759
5760 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5761    to 1, but choosing the first symbol found if there are multiple
5762    choices.
5763
5764    The result is stored in *INFO, which must be non-NULL.
5765    If no match is found, INFO->SYM is set to NULL.  */
5766
5767 void
5768 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5769                            domain_enum domain,
5770                            struct block_symbol *info)
5771 {
5772   /* Since we already have an encoded name, wrap it in '<>' to force a
5773      verbatim match.  Otherwise, if the name happens to not look like
5774      an encoded name (because it doesn't include a "__"),
5775      ada_lookup_name_info would re-encode/fold it again, and that
5776      would e.g., incorrectly lowercase object renaming names like
5777      "R28b" -> "r28b".  */
5778   std::string verbatim = add_angle_brackets (name);
5779
5780   gdb_assert (info != NULL);
5781   *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5782 }
5783
5784 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5785    scope and in global scopes, or NULL if none.  NAME is folded and
5786    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5787    choosing the first symbol if there are multiple choices.  */
5788
5789 struct block_symbol
5790 ada_lookup_symbol (const char *name, const struct block *block0,
5791                    domain_enum domain)
5792 {
5793   std::vector<struct block_symbol> candidates
5794     = ada_lookup_symbol_list (name, block0, domain);
5795
5796   if (candidates.empty ())
5797     return {};
5798
5799   block_symbol info = candidates[0];
5800   info.symbol = fixup_symbol_section (info.symbol, NULL);
5801   return info;
5802 }
5803
5804
5805 /* True iff STR is a possible encoded suffix of a normal Ada name
5806    that is to be ignored for matching purposes.  Suffixes of parallel
5807    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5808    are given by any of the regular expressions:
5809
5810    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5811    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5812    TKB              [subprogram suffix for task bodies]
5813    _E[0-9]+[bs]$    [protected object entry suffixes]
5814    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5815
5816    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5817    match is performed.  This sequence is used to differentiate homonyms,
5818    is an optional part of a valid name suffix.  */
5819
5820 static int
5821 is_name_suffix (const char *str)
5822 {
5823   int k;
5824   const char *matching;
5825   const int len = strlen (str);
5826
5827   /* Skip optional leading __[0-9]+.  */
5828
5829   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5830     {
5831       str += 3;
5832       while (isdigit (str[0]))
5833         str += 1;
5834     }
5835   
5836   /* [.$][0-9]+ */
5837
5838   if (str[0] == '.' || str[0] == '$')
5839     {
5840       matching = str + 1;
5841       while (isdigit (matching[0]))
5842         matching += 1;
5843       if (matching[0] == '\0')
5844         return 1;
5845     }
5846
5847   /* ___[0-9]+ */
5848
5849   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5850     {
5851       matching = str + 3;
5852       while (isdigit (matching[0]))
5853         matching += 1;
5854       if (matching[0] == '\0')
5855         return 1;
5856     }
5857
5858   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
5859
5860   if (strcmp (str, "TKB") == 0)
5861     return 1;
5862
5863 #if 0
5864   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5865      with a N at the end.  Unfortunately, the compiler uses the same
5866      convention for other internal types it creates.  So treating
5867      all entity names that end with an "N" as a name suffix causes
5868      some regressions.  For instance, consider the case of an enumerated
5869      type.  To support the 'Image attribute, it creates an array whose
5870      name ends with N.
5871      Having a single character like this as a suffix carrying some
5872      information is a bit risky.  Perhaps we should change the encoding
5873      to be something like "_N" instead.  In the meantime, do not do
5874      the following check.  */
5875   /* Protected Object Subprograms */
5876   if (len == 1 && str [0] == 'N')
5877     return 1;
5878 #endif
5879
5880   /* _E[0-9]+[bs]$ */
5881   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5882     {
5883       matching = str + 3;
5884       while (isdigit (matching[0]))
5885         matching += 1;
5886       if ((matching[0] == 'b' || matching[0] == 's')
5887           && matching [1] == '\0')
5888         return 1;
5889     }
5890
5891   /* ??? We should not modify STR directly, as we are doing below.  This
5892      is fine in this case, but may become problematic later if we find
5893      that this alternative did not work, and want to try matching
5894      another one from the begining of STR.  Since we modified it, we
5895      won't be able to find the begining of the string anymore!  */
5896   if (str[0] == 'X')
5897     {
5898       str += 1;
5899       while (str[0] != '_' && str[0] != '\0')
5900         {
5901           if (str[0] != 'n' && str[0] != 'b')
5902             return 0;
5903           str += 1;
5904         }
5905     }
5906
5907   if (str[0] == '\000')
5908     return 1;
5909
5910   if (str[0] == '_')
5911     {
5912       if (str[1] != '_' || str[2] == '\000')
5913         return 0;
5914       if (str[2] == '_')
5915         {
5916           if (strcmp (str + 3, "JM") == 0)
5917             return 1;
5918           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5919              the LJM suffix in favor of the JM one.  But we will
5920              still accept LJM as a valid suffix for a reasonable
5921              amount of time, just to allow ourselves to debug programs
5922              compiled using an older version of GNAT.  */
5923           if (strcmp (str + 3, "LJM") == 0)
5924             return 1;
5925           if (str[3] != 'X')
5926             return 0;
5927           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5928               || str[4] == 'U' || str[4] == 'P')
5929             return 1;
5930           if (str[4] == 'R' && str[5] != 'T')
5931             return 1;
5932           return 0;
5933         }
5934       if (!isdigit (str[2]))
5935         return 0;
5936       for (k = 3; str[k] != '\0'; k += 1)
5937         if (!isdigit (str[k]) && str[k] != '_')
5938           return 0;
5939       return 1;
5940     }
5941   if (str[0] == '$' && isdigit (str[1]))
5942     {
5943       for (k = 2; str[k] != '\0'; k += 1)
5944         if (!isdigit (str[k]) && str[k] != '_')
5945           return 0;
5946       return 1;
5947     }
5948   return 0;
5949 }
5950
5951 /* Return non-zero if the string starting at NAME and ending before
5952    NAME_END contains no capital letters.  */
5953
5954 static int
5955 is_valid_name_for_wild_match (const char *name0)
5956 {
5957   std::string decoded_name = ada_decode (name0);
5958   int i;
5959
5960   /* If the decoded name starts with an angle bracket, it means that
5961      NAME0 does not follow the GNAT encoding format.  It should then
5962      not be allowed as a possible wild match.  */
5963   if (decoded_name[0] == '<')
5964     return 0;
5965
5966   for (i=0; decoded_name[i] != '\0'; i++)
5967     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5968       return 0;
5969
5970   return 1;
5971 }
5972
5973 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5974    character which could start a simple name.  Assumes that *NAMEP points
5975    somewhere inside the string beginning at NAME0.  */
5976
5977 static int
5978 advance_wild_match (const char **namep, const char *name0, char target0)
5979 {
5980   const char *name = *namep;
5981
5982   while (1)
5983     {
5984       char t0, t1;
5985
5986       t0 = *name;
5987       if (t0 == '_')
5988         {
5989           t1 = name[1];
5990           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5991             {
5992               name += 1;
5993               if (name == name0 + 5 && startswith (name0, "_ada"))
5994                 break;
5995               else
5996                 name += 1;
5997             }
5998           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5999                                  || name[2] == target0))
6000             {
6001               name += 2;
6002               break;
6003             }
6004           else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
6005             {
6006               /* Names like "pkg__B_N__name", where N is a number, are
6007                  block-local.  We can handle these by simply skipping
6008                  the "B_" here.  */
6009               name += 4;
6010             }
6011           else
6012             return 0;
6013         }
6014       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6015         name += 1;
6016       else
6017         return 0;
6018     }
6019
6020   *namep = name;
6021   return 1;
6022 }
6023
6024 /* Return true iff NAME encodes a name of the form prefix.PATN.
6025    Ignores any informational suffixes of NAME (i.e., for which
6026    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
6027    simple name.  */
6028
6029 static bool
6030 wild_match (const char *name, const char *patn)
6031 {
6032   const char *p;
6033   const char *name0 = name;
6034
6035   if (startswith (name, "___ghost_"))
6036     name += 9;
6037
6038   while (1)
6039     {
6040       const char *match = name;
6041
6042       if (*name == *patn)
6043         {
6044           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6045             if (*p != *name)
6046               break;
6047           if (*p == '\0' && is_name_suffix (name))
6048             return match == name0 || is_valid_name_for_wild_match (name0);
6049
6050           if (name[-1] == '_')
6051             name -= 1;
6052         }
6053       if (!advance_wild_match (&name, name0, *patn))
6054         return false;
6055     }
6056 }
6057
6058 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
6059    necessary).  OBJFILE is the section containing BLOCK.  */
6060
6061 static void
6062 ada_add_block_symbols (std::vector<struct block_symbol> &result,
6063                        const struct block *block,
6064                        const lookup_name_info &lookup_name,
6065                        domain_enum domain, struct objfile *objfile)
6066 {
6067   struct block_iterator iter;
6068   /* A matching argument symbol, if any.  */
6069   struct symbol *arg_sym;
6070   /* Set true when we find a matching non-argument symbol.  */
6071   bool found_sym;
6072   struct symbol *sym;
6073
6074   arg_sym = NULL;
6075   found_sym = false;
6076   for (sym = block_iter_match_first (block, lookup_name, &iter);
6077        sym != NULL;
6078        sym = block_iter_match_next (lookup_name, &iter))
6079     {
6080       if (symbol_matches_domain (sym->language (), sym->domain (), domain))
6081         {
6082           if (sym->aclass () != LOC_UNRESOLVED)
6083             {
6084               if (sym->is_argument ())
6085                 arg_sym = sym;
6086               else
6087                 {
6088                   found_sym = true;
6089                   add_defn_to_vec (result,
6090                                    fixup_symbol_section (sym, objfile),
6091                                    block);
6092                 }
6093             }
6094         }
6095     }
6096
6097   /* Handle renamings.  */
6098
6099   if (ada_add_block_renamings (result, block, lookup_name, domain))
6100     found_sym = true;
6101
6102   if (!found_sym && arg_sym != NULL)
6103     {
6104       add_defn_to_vec (result,
6105                        fixup_symbol_section (arg_sym, objfile),
6106                        block);
6107     }
6108
6109   if (!lookup_name.ada ().wild_match_p ())
6110     {
6111       arg_sym = NULL;
6112       found_sym = false;
6113       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6114       const char *name = ada_lookup_name.c_str ();
6115       size_t name_len = ada_lookup_name.size ();
6116
6117       ALL_BLOCK_SYMBOLS (block, iter, sym)
6118       {
6119         if (symbol_matches_domain (sym->language (),
6120                                    sym->domain (), domain))
6121           {
6122             int cmp;
6123
6124             cmp = (int) '_' - (int) sym->linkage_name ()[0];
6125             if (cmp == 0)
6126               {
6127                 cmp = !startswith (sym->linkage_name (), "_ada_");
6128                 if (cmp == 0)
6129                   cmp = strncmp (name, sym->linkage_name () + 5,
6130                                  name_len);
6131               }
6132
6133             if (cmp == 0
6134                 && is_name_suffix (sym->linkage_name () + name_len + 5))
6135               {
6136                 if (sym->aclass () != LOC_UNRESOLVED)
6137                   {
6138                     if (sym->is_argument ())
6139                       arg_sym = sym;
6140                     else
6141                       {
6142                         found_sym = true;
6143                         add_defn_to_vec (result,
6144                                          fixup_symbol_section (sym, objfile),
6145                                          block);
6146                       }
6147                   }
6148               }
6149           }
6150       }
6151
6152       /* NOTE: This really shouldn't be needed for _ada_ symbols.
6153          They aren't parameters, right?  */
6154       if (!found_sym && arg_sym != NULL)
6155         {
6156           add_defn_to_vec (result,
6157                            fixup_symbol_section (arg_sym, objfile),
6158                            block);
6159         }
6160     }
6161 }
6162 \f
6163
6164                                 /* Symbol Completion */
6165
6166 /* See symtab.h.  */
6167
6168 bool
6169 ada_lookup_name_info::matches
6170   (const char *sym_name,
6171    symbol_name_match_type match_type,
6172    completion_match_result *comp_match_res) const
6173 {
6174   bool match = false;
6175   const char *text = m_encoded_name.c_str ();
6176   size_t text_len = m_encoded_name.size ();
6177
6178   /* First, test against the fully qualified name of the symbol.  */
6179
6180   if (strncmp (sym_name, text, text_len) == 0)
6181     match = true;
6182
6183   std::string decoded_name = ada_decode (sym_name);
6184   if (match && !m_encoded_p)
6185     {
6186       /* One needed check before declaring a positive match is to verify
6187          that iff we are doing a verbatim match, the decoded version
6188          of the symbol name starts with '<'.  Otherwise, this symbol name
6189          is not a suitable completion.  */
6190
6191       bool has_angle_bracket = (decoded_name[0] == '<');
6192       match = (has_angle_bracket == m_verbatim_p);
6193     }
6194
6195   if (match && !m_verbatim_p)
6196     {
6197       /* When doing non-verbatim match, another check that needs to
6198          be done is to verify that the potentially matching symbol name
6199          does not include capital letters, because the ada-mode would
6200          not be able to understand these symbol names without the
6201          angle bracket notation.  */
6202       const char *tmp;
6203
6204       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6205       if (*tmp != '\0')
6206         match = false;
6207     }
6208
6209   /* Second: Try wild matching...  */
6210
6211   if (!match && m_wild_match_p)
6212     {
6213       /* Since we are doing wild matching, this means that TEXT
6214          may represent an unqualified symbol name.  We therefore must
6215          also compare TEXT against the unqualified name of the symbol.  */
6216       sym_name = ada_unqualified_name (decoded_name.c_str ());
6217
6218       if (strncmp (sym_name, text, text_len) == 0)
6219         match = true;
6220     }
6221
6222   /* Finally: If we found a match, prepare the result to return.  */
6223
6224   if (!match)
6225     return false;
6226
6227   if (comp_match_res != NULL)
6228     {
6229       std::string &match_str = comp_match_res->match.storage ();
6230
6231       if (!m_encoded_p)
6232         match_str = ada_decode (sym_name);
6233       else
6234         {
6235           if (m_verbatim_p)
6236             match_str = add_angle_brackets (sym_name);
6237           else
6238             match_str = sym_name;
6239
6240         }
6241
6242       comp_match_res->set_match (match_str.c_str ());
6243     }
6244
6245   return true;
6246 }
6247
6248                                 /* Field Access */
6249
6250 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6251    for tagged types.  */
6252
6253 static int
6254 ada_is_dispatch_table_ptr_type (struct type *type)
6255 {
6256   const char *name;
6257
6258   if (type->code () != TYPE_CODE_PTR)
6259     return 0;
6260
6261   name = TYPE_TARGET_TYPE (type)->name ();
6262   if (name == NULL)
6263     return 0;
6264
6265   return (strcmp (name, "ada__tags__dispatch_table") == 0);
6266 }
6267
6268 /* Return non-zero if TYPE is an interface tag.  */
6269
6270 static int
6271 ada_is_interface_tag (struct type *type)
6272 {
6273   const char *name = type->name ();
6274
6275   if (name == NULL)
6276     return 0;
6277
6278   return (strcmp (name, "ada__tags__interface_tag") == 0);
6279 }
6280
6281 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6282    to be invisible to users.  */
6283
6284 int
6285 ada_is_ignored_field (struct type *type, int field_num)
6286 {
6287   if (field_num < 0 || field_num > type->num_fields ())
6288     return 1;
6289
6290   /* Check the name of that field.  */
6291   {
6292     const char *name = type->field (field_num).name ();
6293
6294     /* Anonymous field names should not be printed.
6295        brobecker/2007-02-20: I don't think this can actually happen
6296        but we don't want to print the value of anonymous fields anyway.  */
6297     if (name == NULL)
6298       return 1;
6299
6300     /* Normally, fields whose name start with an underscore ("_")
6301        are fields that have been internally generated by the compiler,
6302        and thus should not be printed.  The "_parent" field is special,
6303        however: This is a field internally generated by the compiler
6304        for tagged types, and it contains the components inherited from
6305        the parent type.  This field should not be printed as is, but
6306        should not be ignored either.  */
6307     if (name[0] == '_' && !startswith (name, "_parent"))
6308       return 1;
6309
6310     /* The compiler doesn't document this, but sometimes it emits
6311        a field whose name starts with a capital letter, like 'V148s'.
6312        These aren't marked as artificial in any way, but we know they
6313        should be ignored.  However, wrapper fields should not be
6314        ignored.  */
6315     if (name[0] == 'S' || name[0] == 'R' || name[0] == 'O')
6316       {
6317         /* Wrapper field.  */
6318       }
6319     else if (isupper (name[0]))
6320       return 1;
6321   }
6322
6323   /* If this is the dispatch table of a tagged type or an interface tag,
6324      then ignore.  */
6325   if (ada_is_tagged_type (type, 1)
6326       && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
6327           || ada_is_interface_tag (type->field (field_num).type ())))
6328     return 1;
6329
6330   /* Not a special field, so it should not be ignored.  */
6331   return 0;
6332 }
6333
6334 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
6335    pointer or reference type whose ultimate target has a tag field.  */
6336
6337 int
6338 ada_is_tagged_type (struct type *type, int refok)
6339 {
6340   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6341 }
6342
6343 /* True iff TYPE represents the type of X'Tag */
6344
6345 int
6346 ada_is_tag_type (struct type *type)
6347 {
6348   type = ada_check_typedef (type);
6349
6350   if (type == NULL || type->code () != TYPE_CODE_PTR)
6351     return 0;
6352   else
6353     {
6354       const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6355
6356       return (name != NULL
6357               && strcmp (name, "ada__tags__dispatch_table") == 0);
6358     }
6359 }
6360
6361 /* The type of the tag on VAL.  */
6362
6363 static struct type *
6364 ada_tag_type (struct value *val)
6365 {
6366   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6367 }
6368
6369 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6370    retired at Ada 05).  */
6371
6372 static int
6373 is_ada95_tag (struct value *tag)
6374 {
6375   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6376 }
6377
6378 /* The value of the tag on VAL.  */
6379
6380 static struct value *
6381 ada_value_tag (struct value *val)
6382 {
6383   return ada_value_struct_elt (val, "_tag", 0);
6384 }
6385
6386 /* The value of the tag on the object of type TYPE whose contents are
6387    saved at VALADDR, if it is non-null, or is at memory address
6388    ADDRESS.  */
6389
6390 static struct value *
6391 value_tag_from_contents_and_address (struct type *type,
6392                                      const gdb_byte *valaddr,
6393                                      CORE_ADDR address)
6394 {
6395   int tag_byte_offset;
6396   struct type *tag_type;
6397
6398   gdb::array_view<const gdb_byte> contents;
6399   if (valaddr != nullptr)
6400     contents = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
6401   struct type *resolved_type = resolve_dynamic_type (type, contents, address);
6402   if (find_struct_field ("_tag", resolved_type, 0, &tag_type, &tag_byte_offset,
6403                          NULL, NULL, NULL))
6404     {
6405       const gdb_byte *valaddr1 = ((valaddr == NULL)
6406                                   ? NULL
6407                                   : valaddr + tag_byte_offset);
6408       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6409
6410       return value_from_contents_and_address (tag_type, valaddr1, address1);
6411     }
6412   return NULL;
6413 }
6414
6415 static struct type *
6416 type_from_tag (struct value *tag)
6417 {
6418   gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6419
6420   if (type_name != NULL)
6421     return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6422   return NULL;
6423 }
6424
6425 /* Given a value OBJ of a tagged type, return a value of this
6426    type at the base address of the object.  The base address, as
6427    defined in Ada.Tags, it is the address of the primary tag of
6428    the object, and therefore where the field values of its full
6429    view can be fetched.  */
6430
6431 struct value *
6432 ada_tag_value_at_base_address (struct value *obj)
6433 {
6434   struct value *val;
6435   LONGEST offset_to_top = 0;
6436   struct type *ptr_type, *obj_type;
6437   struct value *tag;
6438   CORE_ADDR base_address;
6439
6440   obj_type = value_type (obj);
6441
6442   /* It is the responsability of the caller to deref pointers.  */
6443
6444   if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6445     return obj;
6446
6447   tag = ada_value_tag (obj);
6448   if (!tag)
6449     return obj;
6450
6451   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6452
6453   if (is_ada95_tag (tag))
6454     return obj;
6455
6456   struct type *offset_type
6457     = language_lookup_primitive_type (language_def (language_ada),
6458                                       target_gdbarch(), "storage_offset");
6459   ptr_type = lookup_pointer_type (offset_type);
6460   val = value_cast (ptr_type, tag);
6461   if (!val)
6462     return obj;
6463
6464   /* It is perfectly possible that an exception be raised while
6465      trying to determine the base address, just like for the tag;
6466      see ada_tag_name for more details.  We do not print the error
6467      message for the same reason.  */
6468
6469   try
6470     {
6471       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6472     }
6473
6474   catch (const gdb_exception_error &e)
6475     {
6476       return obj;
6477     }
6478
6479   /* If offset is null, nothing to do.  */
6480
6481   if (offset_to_top == 0)
6482     return obj;
6483
6484   /* -1 is a special case in Ada.Tags; however, what should be done
6485      is not quite clear from the documentation.  So do nothing for
6486      now.  */
6487
6488   if (offset_to_top == -1)
6489     return obj;
6490
6491   /* Storage_Offset'Last is used to indicate that a dynamic offset to
6492      top is used.  In this situation the offset is stored just after
6493      the tag, in the object itself.  */
6494   ULONGEST last = (((ULONGEST) 1) << (8 * TYPE_LENGTH (offset_type) - 1)) - 1;
6495   if (offset_to_top == last)
6496     {
6497       struct value *tem = value_addr (tag);
6498       tem = value_ptradd (tem, 1);
6499       tem = value_cast (ptr_type, tem);
6500       offset_to_top = value_as_long (value_ind (tem));
6501     }
6502
6503   if (offset_to_top > 0)
6504     {
6505       /* OFFSET_TO_TOP used to be a positive value to be subtracted
6506          from the base address.  This was however incompatible with
6507          C++ dispatch table: C++ uses a *negative* value to *add*
6508          to the base address.  Ada's convention has therefore been
6509          changed in GNAT 19.0w 20171023: since then, C++ and Ada
6510          use the same convention.  Here, we support both cases by
6511          checking the sign of OFFSET_TO_TOP.  */
6512       offset_to_top = -offset_to_top;
6513     }
6514
6515   base_address = value_address (obj) + offset_to_top;
6516   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6517
6518   /* Make sure that we have a proper tag at the new address.
6519      Otherwise, offset_to_top is bogus (which can happen when
6520      the object is not initialized yet).  */
6521
6522   if (!tag)
6523     return obj;
6524
6525   obj_type = type_from_tag (tag);
6526
6527   if (!obj_type)
6528     return obj;
6529
6530   return value_from_contents_and_address (obj_type, NULL, base_address);
6531 }
6532
6533 /* Return the "ada__tags__type_specific_data" type.  */
6534
6535 static struct type *
6536 ada_get_tsd_type (struct inferior *inf)
6537 {
6538   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6539
6540   if (data->tsd_type == 0)
6541     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6542   return data->tsd_type;
6543 }
6544
6545 /* Return the TSD (type-specific data) associated to the given TAG.
6546    TAG is assumed to be the tag of a tagged-type entity.
6547
6548    May return NULL if we are unable to get the TSD.  */
6549
6550 static struct value *
6551 ada_get_tsd_from_tag (struct value *tag)
6552 {
6553   struct value *val;
6554   struct type *type;
6555
6556   /* First option: The TSD is simply stored as a field of our TAG.
6557      Only older versions of GNAT would use this format, but we have
6558      to test it first, because there are no visible markers for
6559      the current approach except the absence of that field.  */
6560
6561   val = ada_value_struct_elt (tag, "tsd", 1);
6562   if (val)
6563     return val;
6564
6565   /* Try the second representation for the dispatch table (in which
6566      there is no explicit 'tsd' field in the referent of the tag pointer,
6567      and instead the tsd pointer is stored just before the dispatch
6568      table.  */
6569
6570   type = ada_get_tsd_type (current_inferior());
6571   if (type == NULL)
6572     return NULL;
6573   type = lookup_pointer_type (lookup_pointer_type (type));
6574   val = value_cast (type, tag);
6575   if (val == NULL)
6576     return NULL;
6577   return value_ind (value_ptradd (val, -1));
6578 }
6579
6580 /* Given the TSD of a tag (type-specific data), return a string
6581    containing the name of the associated type.
6582
6583    May return NULL if we are unable to determine the tag name.  */
6584
6585 static gdb::unique_xmalloc_ptr<char>
6586 ada_tag_name_from_tsd (struct value *tsd)
6587 {
6588   struct value *val;
6589
6590   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6591   if (val == NULL)
6592     return NULL;
6593   gdb::unique_xmalloc_ptr<char> buffer
6594     = target_read_string (value_as_address (val), INT_MAX);
6595   if (buffer == nullptr)
6596     return nullptr;
6597
6598   try
6599     {
6600       /* Let this throw an exception on error.  If the data is
6601          uninitialized, we'd rather not have the user see a
6602          warning.  */
6603       const char *folded = ada_fold_name (buffer.get (), true);
6604       return make_unique_xstrdup (folded);
6605     }
6606   catch (const gdb_exception &)
6607     {
6608       return nullptr;
6609     }
6610 }
6611
6612 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6613    a C string.
6614
6615    Return NULL if the TAG is not an Ada tag, or if we were unable to
6616    determine the name of that tag.  */
6617
6618 gdb::unique_xmalloc_ptr<char>
6619 ada_tag_name (struct value *tag)
6620 {
6621   gdb::unique_xmalloc_ptr<char> name;
6622
6623   if (!ada_is_tag_type (value_type (tag)))
6624     return NULL;
6625
6626   /* It is perfectly possible that an exception be raised while trying
6627      to determine the TAG's name, even under normal circumstances:
6628      The associated variable may be uninitialized or corrupted, for
6629      instance. We do not let any exception propagate past this point.
6630      instead we return NULL.
6631
6632      We also do not print the error message either (which often is very
6633      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6634      the caller print a more meaningful message if necessary.  */
6635   try
6636     {
6637       struct value *tsd = ada_get_tsd_from_tag (tag);
6638
6639       if (tsd != NULL)
6640         name = ada_tag_name_from_tsd (tsd);
6641     }
6642   catch (const gdb_exception_error &e)
6643     {
6644     }
6645
6646   return name;
6647 }
6648
6649 /* The parent type of TYPE, or NULL if none.  */
6650
6651 struct type *
6652 ada_parent_type (struct type *type)
6653 {
6654   int i;
6655
6656   type = ada_check_typedef (type);
6657
6658   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6659     return NULL;
6660
6661   for (i = 0; i < type->num_fields (); i += 1)
6662     if (ada_is_parent_field (type, i))
6663       {
6664         struct type *parent_type = type->field (i).type ();
6665
6666         /* If the _parent field is a pointer, then dereference it.  */
6667         if (parent_type->code () == TYPE_CODE_PTR)
6668           parent_type = TYPE_TARGET_TYPE (parent_type);
6669         /* If there is a parallel XVS type, get the actual base type.  */
6670         parent_type = ada_get_base_type (parent_type);
6671
6672         return ada_check_typedef (parent_type);
6673       }
6674
6675   return NULL;
6676 }
6677
6678 /* True iff field number FIELD_NUM of structure type TYPE contains the
6679    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6680    a structure type with at least FIELD_NUM+1 fields.  */
6681
6682 int
6683 ada_is_parent_field (struct type *type, int field_num)
6684 {
6685   const char *name = ada_check_typedef (type)->field (field_num).name ();
6686
6687   return (name != NULL
6688           && (startswith (name, "PARENT")
6689               || startswith (name, "_parent")));
6690 }
6691
6692 /* True iff field number FIELD_NUM of structure type TYPE is a
6693    transparent wrapper field (which should be silently traversed when doing
6694    field selection and flattened when printing).  Assumes TYPE is a
6695    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6696    structures.  */
6697
6698 int
6699 ada_is_wrapper_field (struct type *type, int field_num)
6700 {
6701   const char *name = type->field (field_num).name ();
6702
6703   if (name != NULL && strcmp (name, "RETVAL") == 0)
6704     {
6705       /* This happens in functions with "out" or "in out" parameters
6706          which are passed by copy.  For such functions, GNAT describes
6707          the function's return type as being a struct where the return
6708          value is in a field called RETVAL, and where the other "out"
6709          or "in out" parameters are fields of that struct.  This is not
6710          a wrapper.  */
6711       return 0;
6712     }
6713
6714   return (name != NULL
6715           && (startswith (name, "PARENT")
6716               || strcmp (name, "REP") == 0
6717               || startswith (name, "_parent")
6718               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6719 }
6720
6721 /* True iff field number FIELD_NUM of structure or union type TYPE
6722    is a variant wrapper.  Assumes TYPE is a structure type with at least
6723    FIELD_NUM+1 fields.  */
6724
6725 int
6726 ada_is_variant_part (struct type *type, int field_num)
6727 {
6728   /* Only Ada types are eligible.  */
6729   if (!ADA_TYPE_P (type))
6730     return 0;
6731
6732   struct type *field_type = type->field (field_num).type ();
6733
6734   return (field_type->code () == TYPE_CODE_UNION
6735           || (is_dynamic_field (type, field_num)
6736               && (TYPE_TARGET_TYPE (field_type)->code ()
6737                   == TYPE_CODE_UNION)));
6738 }
6739
6740 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6741    whose discriminants are contained in the record type OUTER_TYPE,
6742    returns the type of the controlling discriminant for the variant.
6743    May return NULL if the type could not be found.  */
6744
6745 struct type *
6746 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6747 {
6748   const char *name = ada_variant_discrim_name (var_type);
6749
6750   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6751 }
6752
6753 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6754    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6755    represents a 'when others' clause; otherwise 0.  */
6756
6757 static int
6758 ada_is_others_clause (struct type *type, int field_num)
6759 {
6760   const char *name = type->field (field_num).name ();
6761
6762   return (name != NULL && name[0] == 'O');
6763 }
6764
6765 /* Assuming that TYPE0 is the type of the variant part of a record,
6766    returns the name of the discriminant controlling the variant.
6767    The value is valid until the next call to ada_variant_discrim_name.  */
6768
6769 const char *
6770 ada_variant_discrim_name (struct type *type0)
6771 {
6772   static std::string result;
6773   struct type *type;
6774   const char *name;
6775   const char *discrim_end;
6776   const char *discrim_start;
6777
6778   if (type0->code () == TYPE_CODE_PTR)
6779     type = TYPE_TARGET_TYPE (type0);
6780   else
6781     type = type0;
6782
6783   name = ada_type_name (type);
6784
6785   if (name == NULL || name[0] == '\000')
6786     return "";
6787
6788   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6789        discrim_end -= 1)
6790     {
6791       if (startswith (discrim_end, "___XVN"))
6792         break;
6793     }
6794   if (discrim_end == name)
6795     return "";
6796
6797   for (discrim_start = discrim_end; discrim_start != name + 3;
6798        discrim_start -= 1)
6799     {
6800       if (discrim_start == name + 1)
6801         return "";
6802       if ((discrim_start > name + 3
6803            && startswith (discrim_start - 3, "___"))
6804           || discrim_start[-1] == '.')
6805         break;
6806     }
6807
6808   result = std::string (discrim_start, discrim_end - discrim_start);
6809   return result.c_str ();
6810 }
6811
6812 /* Scan STR for a subtype-encoded number, beginning at position K.
6813    Put the position of the character just past the number scanned in
6814    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
6815    Return 1 if there was a valid number at the given position, and 0
6816    otherwise.  A "subtype-encoded" number consists of the absolute value
6817    in decimal, followed by the letter 'm' to indicate a negative number.
6818    Assumes 0m does not occur.  */
6819
6820 int
6821 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6822 {
6823   ULONGEST RU;
6824
6825   if (!isdigit (str[k]))
6826     return 0;
6827
6828   /* Do it the hard way so as not to make any assumption about
6829      the relationship of unsigned long (%lu scan format code) and
6830      LONGEST.  */
6831   RU = 0;
6832   while (isdigit (str[k]))
6833     {
6834       RU = RU * 10 + (str[k] - '0');
6835       k += 1;
6836     }
6837
6838   if (str[k] == 'm')
6839     {
6840       if (R != NULL)
6841         *R = (-(LONGEST) (RU - 1)) - 1;
6842       k += 1;
6843     }
6844   else if (R != NULL)
6845     *R = (LONGEST) RU;
6846
6847   /* NOTE on the above: Technically, C does not say what the results of
6848      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6849      number representable as a LONGEST (although either would probably work
6850      in most implementations).  When RU>0, the locution in the then branch
6851      above is always equivalent to the negative of RU.  */
6852
6853   if (new_k != NULL)
6854     *new_k = k;
6855   return 1;
6856 }
6857
6858 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6859    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6860    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
6861
6862 static int
6863 ada_in_variant (LONGEST val, struct type *type, int field_num)
6864 {
6865   const char *name = type->field (field_num).name ();
6866   int p;
6867
6868   p = 0;
6869   while (1)
6870     {
6871       switch (name[p])
6872         {
6873         case '\0':
6874           return 0;
6875         case 'S':
6876           {
6877             LONGEST W;
6878
6879             if (!ada_scan_number (name, p + 1, &W, &p))
6880               return 0;
6881             if (val == W)
6882               return 1;
6883             break;
6884           }
6885         case 'R':
6886           {
6887             LONGEST L, U;
6888
6889             if (!ada_scan_number (name, p + 1, &L, &p)
6890                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6891               return 0;
6892             if (val >= L && val <= U)
6893               return 1;
6894             break;
6895           }
6896         case 'O':
6897           return 1;
6898         default:
6899           return 0;
6900         }
6901     }
6902 }
6903
6904 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
6905
6906 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6907    ARG_TYPE, extract and return the value of one of its (non-static)
6908    fields.  FIELDNO says which field.   Differs from value_primitive_field
6909    only in that it can handle packed values of arbitrary type.  */
6910
6911 struct value *
6912 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6913                            struct type *arg_type)
6914 {
6915   struct type *type;
6916
6917   arg_type = ada_check_typedef (arg_type);
6918   type = arg_type->field (fieldno).type ();
6919
6920   /* Handle packed fields.  It might be that the field is not packed
6921      relative to its containing structure, but the structure itself is
6922      packed; in this case we must take the bit-field path.  */
6923   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6924     {
6925       int bit_pos = arg_type->field (fieldno).loc_bitpos ();
6926       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6927
6928       return ada_value_primitive_packed_val (arg1,
6929                                              value_contents (arg1).data (),
6930                                              offset + bit_pos / 8,
6931                                              bit_pos % 8, bit_size, type);
6932     }
6933   else
6934     return value_primitive_field (arg1, offset, fieldno, arg_type);
6935 }
6936
6937 /* Find field with name NAME in object of type TYPE.  If found, 
6938    set the following for each argument that is non-null:
6939     - *FIELD_TYPE_P to the field's type; 
6940     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
6941       an object of that type;
6942     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
6943     - *BIT_SIZE_P to its size in bits if the field is packed, and 
6944       0 otherwise;
6945    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6946    fields up to but not including the desired field, or by the total
6947    number of fields if not found.   A NULL value of NAME never
6948    matches; the function just counts visible fields in this case.
6949    
6950    Notice that we need to handle when a tagged record hierarchy
6951    has some components with the same name, like in this scenario:
6952
6953       type Top_T is tagged record
6954          N : Integer := 1;
6955          U : Integer := 974;
6956          A : Integer := 48;
6957       end record;
6958
6959       type Middle_T is new Top.Top_T with record
6960          N : Character := 'a';
6961          C : Integer := 3;
6962       end record;
6963
6964      type Bottom_T is new Middle.Middle_T with record
6965         N : Float := 4.0;
6966         C : Character := '5';
6967         X : Integer := 6;
6968         A : Character := 'J';
6969      end record;
6970
6971    Let's say we now have a variable declared and initialized as follow:
6972
6973      TC : Top_A := new Bottom_T;
6974
6975    And then we use this variable to call this function
6976
6977      procedure Assign (Obj: in out Top_T; TV : Integer);
6978
6979    as follow:
6980
6981       Assign (Top_T (B), 12);
6982
6983    Now, we're in the debugger, and we're inside that procedure
6984    then and we want to print the value of obj.c:
6985
6986    Usually, the tagged record or one of the parent type owns the
6987    component to print and there's no issue but in this particular
6988    case, what does it mean to ask for Obj.C? Since the actual
6989    type for object is type Bottom_T, it could mean two things: type
6990    component C from the Middle_T view, but also component C from
6991    Bottom_T.  So in that "undefined" case, when the component is
6992    not found in the non-resolved type (which includes all the
6993    components of the parent type), then resolve it and see if we
6994    get better luck once expanded.
6995
6996    In the case of homonyms in the derived tagged type, we don't
6997    guaranty anything, and pick the one that's easiest for us
6998    to program.
6999
7000    Returns 1 if found, 0 otherwise.  */
7001
7002 static int
7003 find_struct_field (const char *name, struct type *type, int offset,
7004                    struct type **field_type_p,
7005                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7006                    int *index_p)
7007 {
7008   int i;
7009   int parent_offset = -1;
7010
7011   type = ada_check_typedef (type);
7012
7013   if (field_type_p != NULL)
7014     *field_type_p = NULL;
7015   if (byte_offset_p != NULL)
7016     *byte_offset_p = 0;
7017   if (bit_offset_p != NULL)
7018     *bit_offset_p = 0;
7019   if (bit_size_p != NULL)
7020     *bit_size_p = 0;
7021
7022   for (i = 0; i < type->num_fields (); i += 1)
7023     {
7024       /* These can't be computed using TYPE_FIELD_BITPOS for a dynamic
7025          type.  However, we only need the values to be correct when
7026          the caller asks for them.  */
7027       int bit_pos = 0, fld_offset = 0;
7028       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7029         {
7030           bit_pos = type->field (i).loc_bitpos ();
7031           fld_offset = offset + bit_pos / 8;
7032         }
7033
7034       const char *t_field_name = type->field (i).name ();
7035
7036       if (t_field_name == NULL)
7037         continue;
7038
7039       else if (ada_is_parent_field (type, i))
7040         {
7041           /* This is a field pointing us to the parent type of a tagged
7042              type.  As hinted in this function's documentation, we give
7043              preference to fields in the current record first, so what
7044              we do here is just record the index of this field before
7045              we skip it.  If it turns out we couldn't find our field
7046              in the current record, then we'll get back to it and search
7047              inside it whether the field might exist in the parent.  */
7048
7049           parent_offset = i;
7050           continue;
7051         }
7052
7053       else if (name != NULL && field_name_match (t_field_name, name))
7054         {
7055           int bit_size = TYPE_FIELD_BITSIZE (type, i);
7056
7057           if (field_type_p != NULL)
7058             *field_type_p = type->field (i).type ();
7059           if (byte_offset_p != NULL)
7060             *byte_offset_p = fld_offset;
7061           if (bit_offset_p != NULL)
7062             *bit_offset_p = bit_pos % 8;
7063           if (bit_size_p != NULL)
7064             *bit_size_p = bit_size;
7065           return 1;
7066         }
7067       else if (ada_is_wrapper_field (type, i))
7068         {
7069           if (find_struct_field (name, type->field (i).type (), fld_offset,
7070                                  field_type_p, byte_offset_p, bit_offset_p,
7071                                  bit_size_p, index_p))
7072             return 1;
7073         }
7074       else if (ada_is_variant_part (type, i))
7075         {
7076           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
7077              fixed type?? */
7078           int j;
7079           struct type *field_type
7080             = ada_check_typedef (type->field (i).type ());
7081
7082           for (j = 0; j < field_type->num_fields (); j += 1)
7083             {
7084               if (find_struct_field (name, field_type->field (j).type (),
7085                                      fld_offset
7086                                      + field_type->field (j).loc_bitpos () / 8,
7087                                      field_type_p, byte_offset_p,
7088                                      bit_offset_p, bit_size_p, index_p))
7089                 return 1;
7090             }
7091         }
7092       else if (index_p != NULL)
7093         *index_p += 1;
7094     }
7095
7096   /* Field not found so far.  If this is a tagged type which
7097      has a parent, try finding that field in the parent now.  */
7098
7099   if (parent_offset != -1)
7100     {
7101       /* As above, only compute the offset when truly needed.  */
7102       int fld_offset = offset;
7103       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
7104         {
7105           int bit_pos = type->field (parent_offset).loc_bitpos ();
7106           fld_offset += bit_pos / 8;
7107         }
7108
7109       if (find_struct_field (name, type->field (parent_offset).type (),
7110                              fld_offset, field_type_p, byte_offset_p,
7111                              bit_offset_p, bit_size_p, index_p))
7112         return 1;
7113     }
7114
7115   return 0;
7116 }
7117
7118 /* Number of user-visible fields in record type TYPE.  */
7119
7120 static int
7121 num_visible_fields (struct type *type)
7122 {
7123   int n;
7124
7125   n = 0;
7126   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7127   return n;
7128 }
7129
7130 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
7131    and search in it assuming it has (class) type TYPE.
7132    If found, return value, else return NULL.
7133
7134    Searches recursively through wrapper fields (e.g., '_parent').
7135
7136    In the case of homonyms in the tagged types, please refer to the
7137    long explanation in find_struct_field's function documentation.  */
7138
7139 static struct value *
7140 ada_search_struct_field (const char *name, struct value *arg, int offset,
7141                          struct type *type)
7142 {
7143   int i;
7144   int parent_offset = -1;
7145
7146   type = ada_check_typedef (type);
7147   for (i = 0; i < type->num_fields (); i += 1)
7148     {
7149       const char *t_field_name = type->field (i).name ();
7150
7151       if (t_field_name == NULL)
7152         continue;
7153
7154       else if (ada_is_parent_field (type, i))
7155         {
7156           /* This is a field pointing us to the parent type of a tagged
7157              type.  As hinted in this function's documentation, we give
7158              preference to fields in the current record first, so what
7159              we do here is just record the index of this field before
7160              we skip it.  If it turns out we couldn't find our field
7161              in the current record, then we'll get back to it and search
7162              inside it whether the field might exist in the parent.  */
7163
7164           parent_offset = i;
7165           continue;
7166         }
7167
7168       else if (field_name_match (t_field_name, name))
7169         return ada_value_primitive_field (arg, offset, i, type);
7170
7171       else if (ada_is_wrapper_field (type, i))
7172         {
7173           struct value *v =     /* Do not let indent join lines here.  */
7174             ada_search_struct_field (name, arg,
7175                                      offset + type->field (i).loc_bitpos () / 8,
7176                                      type->field (i).type ());
7177
7178           if (v != NULL)
7179             return v;
7180         }
7181
7182       else if (ada_is_variant_part (type, i))
7183         {
7184           /* PNH: Do we ever get here?  See find_struct_field.  */
7185           int j;
7186           struct type *field_type = ada_check_typedef (type->field (i).type ());
7187           int var_offset = offset + type->field (i).loc_bitpos () / 8;
7188
7189           for (j = 0; j < field_type->num_fields (); j += 1)
7190             {
7191               struct value *v = ada_search_struct_field /* Force line
7192                                                            break.  */
7193                 (name, arg,
7194                  var_offset + field_type->field (j).loc_bitpos () / 8,
7195                  field_type->field (j).type ());
7196
7197               if (v != NULL)
7198                 return v;
7199             }
7200         }
7201     }
7202
7203   /* Field not found so far.  If this is a tagged type which
7204      has a parent, try finding that field in the parent now.  */
7205
7206   if (parent_offset != -1)
7207     {
7208       struct value *v = ada_search_struct_field (
7209         name, arg, offset + type->field (parent_offset).loc_bitpos () / 8,
7210         type->field (parent_offset).type ());
7211
7212       if (v != NULL)
7213         return v;
7214     }
7215
7216   return NULL;
7217 }
7218
7219 static struct value *ada_index_struct_field_1 (int *, struct value *,
7220                                                int, struct type *);
7221
7222
7223 /* Return field #INDEX in ARG, where the index is that returned by
7224  * find_struct_field through its INDEX_P argument.  Adjust the address
7225  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7226  * If found, return value, else return NULL.  */
7227
7228 static struct value *
7229 ada_index_struct_field (int index, struct value *arg, int offset,
7230                         struct type *type)
7231 {
7232   return ada_index_struct_field_1 (&index, arg, offset, type);
7233 }
7234
7235
7236 /* Auxiliary function for ada_index_struct_field.  Like
7237  * ada_index_struct_field, but takes index from *INDEX_P and modifies
7238  * *INDEX_P.  */
7239
7240 static struct value *
7241 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7242                           struct type *type)
7243 {
7244   int i;
7245   type = ada_check_typedef (type);
7246
7247   for (i = 0; i < type->num_fields (); i += 1)
7248     {
7249       if (type->field (i).name () == NULL)
7250         continue;
7251       else if (ada_is_wrapper_field (type, i))
7252         {
7253           struct value *v =     /* Do not let indent join lines here.  */
7254             ada_index_struct_field_1 (index_p, arg,
7255                                       offset + type->field (i).loc_bitpos () / 8,
7256                                       type->field (i).type ());
7257
7258           if (v != NULL)
7259             return v;
7260         }
7261
7262       else if (ada_is_variant_part (type, i))
7263         {
7264           /* PNH: Do we ever get here?  See ada_search_struct_field,
7265              find_struct_field.  */
7266           error (_("Cannot assign this kind of variant record"));
7267         }
7268       else if (*index_p == 0)
7269         return ada_value_primitive_field (arg, offset, i, type);
7270       else
7271         *index_p -= 1;
7272     }
7273   return NULL;
7274 }
7275
7276 /* Return a string representation of type TYPE.  */
7277
7278 static std::string
7279 type_as_string (struct type *type)
7280 {
7281   string_file tmp_stream;
7282
7283   type_print (type, "", &tmp_stream, -1);
7284
7285   return tmp_stream.release ();
7286 }
7287
7288 /* Given a type TYPE, look up the type of the component of type named NAME.
7289    If DISPP is non-null, add its byte displacement from the beginning of a
7290    structure (pointed to by a value) of type TYPE to *DISPP (does not
7291    work for packed fields).
7292
7293    Matches any field whose name has NAME as a prefix, possibly
7294    followed by "___".
7295
7296    TYPE can be either a struct or union.  If REFOK, TYPE may also 
7297    be a (pointer or reference)+ to a struct or union, and the
7298    ultimate target type will be searched.
7299
7300    Looks recursively into variant clauses and parent types.
7301
7302    In the case of homonyms in the tagged types, please refer to the
7303    long explanation in find_struct_field's function documentation.
7304
7305    If NOERR is nonzero, return NULL if NAME is not suitably defined or
7306    TYPE is not a type of the right kind.  */
7307
7308 static struct type *
7309 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7310                             int noerr)
7311 {
7312   int i;
7313   int parent_offset = -1;
7314
7315   if (name == NULL)
7316     goto BadName;
7317
7318   if (refok && type != NULL)
7319     while (1)
7320       {
7321         type = ada_check_typedef (type);
7322         if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
7323           break;
7324         type = TYPE_TARGET_TYPE (type);
7325       }
7326
7327   if (type == NULL
7328       || (type->code () != TYPE_CODE_STRUCT
7329           && type->code () != TYPE_CODE_UNION))
7330     {
7331       if (noerr)
7332         return NULL;
7333
7334       error (_("Type %s is not a structure or union type"),
7335              type != NULL ? type_as_string (type).c_str () : _("(null)"));
7336     }
7337
7338   type = to_static_fixed_type (type);
7339
7340   for (i = 0; i < type->num_fields (); i += 1)
7341     {
7342       const char *t_field_name = type->field (i).name ();
7343       struct type *t;
7344
7345       if (t_field_name == NULL)
7346         continue;
7347
7348       else if (ada_is_parent_field (type, i))
7349         {
7350           /* This is a field pointing us to the parent type of a tagged
7351              type.  As hinted in this function's documentation, we give
7352              preference to fields in the current record first, so what
7353              we do here is just record the index of this field before
7354              we skip it.  If it turns out we couldn't find our field
7355              in the current record, then we'll get back to it and search
7356              inside it whether the field might exist in the parent.  */
7357
7358           parent_offset = i;
7359           continue;
7360         }
7361
7362       else if (field_name_match (t_field_name, name))
7363         return type->field (i).type ();
7364
7365       else if (ada_is_wrapper_field (type, i))
7366         {
7367           t = ada_lookup_struct_elt_type (type->field (i).type (), name,
7368                                           0, 1);
7369           if (t != NULL)
7370             return t;
7371         }
7372
7373       else if (ada_is_variant_part (type, i))
7374         {
7375           int j;
7376           struct type *field_type = ada_check_typedef (type->field (i).type ());
7377
7378           for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
7379             {
7380               /* FIXME pnh 2008/01/26: We check for a field that is
7381                  NOT wrapped in a struct, since the compiler sometimes
7382                  generates these for unchecked variant types.  Revisit
7383                  if the compiler changes this practice.  */
7384               const char *v_field_name = field_type->field (j).name ();
7385
7386               if (v_field_name != NULL 
7387                   && field_name_match (v_field_name, name))
7388                 t = field_type->field (j).type ();
7389               else
7390                 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
7391                                                 name, 0, 1);
7392
7393               if (t != NULL)
7394                 return t;
7395             }
7396         }
7397
7398     }
7399
7400     /* Field not found so far.  If this is a tagged type which
7401        has a parent, try finding that field in the parent now.  */
7402
7403     if (parent_offset != -1)
7404       {
7405         struct type *t;
7406
7407         t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
7408                                         name, 0, 1);
7409         if (t != NULL)
7410           return t;
7411       }
7412
7413 BadName:
7414   if (!noerr)
7415     {
7416       const char *name_str = name != NULL ? name : _("<null>");
7417
7418       error (_("Type %s has no component named %s"),
7419              type_as_string (type).c_str (), name_str);
7420     }
7421
7422   return NULL;
7423 }
7424
7425 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7426    within a value of type OUTER_TYPE, return true iff VAR_TYPE
7427    represents an unchecked union (that is, the variant part of a
7428    record that is named in an Unchecked_Union pragma).  */
7429
7430 static int
7431 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7432 {
7433   const char *discrim_name = ada_variant_discrim_name (var_type);
7434
7435   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7436 }
7437
7438
7439 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7440    within OUTER, determine which variant clause (field number in VAR_TYPE,
7441    numbering from 0) is applicable.  Returns -1 if none are.  */
7442
7443 int
7444 ada_which_variant_applies (struct type *var_type, struct value *outer)
7445 {
7446   int others_clause;
7447   int i;
7448   const char *discrim_name = ada_variant_discrim_name (var_type);
7449   struct value *discrim;
7450   LONGEST discrim_val;
7451
7452   /* Using plain value_from_contents_and_address here causes problems
7453      because we will end up trying to resolve a type that is currently
7454      being constructed.  */
7455   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7456   if (discrim == NULL)
7457     return -1;
7458   discrim_val = value_as_long (discrim);
7459
7460   others_clause = -1;
7461   for (i = 0; i < var_type->num_fields (); i += 1)
7462     {
7463       if (ada_is_others_clause (var_type, i))
7464         others_clause = i;
7465       else if (ada_in_variant (discrim_val, var_type, i))
7466         return i;
7467     }
7468
7469   return others_clause;
7470 }
7471 \f
7472
7473
7474                                 /* Dynamic-Sized Records */
7475
7476 /* Strategy: The type ostensibly attached to a value with dynamic size
7477    (i.e., a size that is not statically recorded in the debugging
7478    data) does not accurately reflect the size or layout of the value.
7479    Our strategy is to convert these values to values with accurate,
7480    conventional types that are constructed on the fly.  */
7481
7482 /* There is a subtle and tricky problem here.  In general, we cannot
7483    determine the size of dynamic records without its data.  However,
7484    the 'struct value' data structure, which GDB uses to represent
7485    quantities in the inferior process (the target), requires the size
7486    of the type at the time of its allocation in order to reserve space
7487    for GDB's internal copy of the data.  That's why the
7488    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7489    rather than struct value*s.
7490
7491    However, GDB's internal history variables ($1, $2, etc.) are
7492    struct value*s containing internal copies of the data that are not, in
7493    general, the same as the data at their corresponding addresses in
7494    the target.  Fortunately, the types we give to these values are all
7495    conventional, fixed-size types (as per the strategy described
7496    above), so that we don't usually have to perform the
7497    'to_fixed_xxx_type' conversions to look at their values.
7498    Unfortunately, there is one exception: if one of the internal
7499    history variables is an array whose elements are unconstrained
7500    records, then we will need to create distinct fixed types for each
7501    element selected.  */
7502
7503 /* The upshot of all of this is that many routines take a (type, host
7504    address, target address) triple as arguments to represent a value.
7505    The host address, if non-null, is supposed to contain an internal
7506    copy of the relevant data; otherwise, the program is to consult the
7507    target at the target address.  */
7508
7509 /* Assuming that VAL0 represents a pointer value, the result of
7510    dereferencing it.  Differs from value_ind in its treatment of
7511    dynamic-sized types.  */
7512
7513 struct value *
7514 ada_value_ind (struct value *val0)
7515 {
7516   struct value *val = value_ind (val0);
7517
7518   if (ada_is_tagged_type (value_type (val), 0))
7519     val = ada_tag_value_at_base_address (val);
7520
7521   return ada_to_fixed_value (val);
7522 }
7523
7524 /* The value resulting from dereferencing any "reference to"
7525    qualifiers on VAL0.  */
7526
7527 static struct value *
7528 ada_coerce_ref (struct value *val0)
7529 {
7530   if (value_type (val0)->code () == TYPE_CODE_REF)
7531     {
7532       struct value *val = val0;
7533
7534       val = coerce_ref (val);
7535
7536       if (ada_is_tagged_type (value_type (val), 0))
7537         val = ada_tag_value_at_base_address (val);
7538
7539       return ada_to_fixed_value (val);
7540     }
7541   else
7542     return val0;
7543 }
7544
7545 /* Return the bit alignment required for field #F of template type TYPE.  */
7546
7547 static unsigned int
7548 field_alignment (struct type *type, int f)
7549 {
7550   const char *name = type->field (f).name ();
7551   int len;
7552   int align_offset;
7553
7554   /* The field name should never be null, unless the debugging information
7555      is somehow malformed.  In this case, we assume the field does not
7556      require any alignment.  */
7557   if (name == NULL)
7558     return 1;
7559
7560   len = strlen (name);
7561
7562   if (!isdigit (name[len - 1]))
7563     return 1;
7564
7565   if (isdigit (name[len - 2]))
7566     align_offset = len - 2;
7567   else
7568     align_offset = len - 1;
7569
7570   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7571     return TARGET_CHAR_BIT;
7572
7573   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7574 }
7575
7576 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7577
7578 static struct symbol *
7579 ada_find_any_type_symbol (const char *name)
7580 {
7581   struct symbol *sym;
7582
7583   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7584   if (sym != NULL && sym->aclass () == LOC_TYPEDEF)
7585     return sym;
7586
7587   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7588   return sym;
7589 }
7590
7591 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7592    solely for types defined by debug info, it will not search the GDB
7593    primitive types.  */
7594
7595 static struct type *
7596 ada_find_any_type (const char *name)
7597 {
7598   struct symbol *sym = ada_find_any_type_symbol (name);
7599
7600   if (sym != NULL)
7601     return sym->type ();
7602
7603   return NULL;
7604 }
7605
7606 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7607    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
7608    symbol, in which case it is returned.  Otherwise, this looks for
7609    symbols whose name is that of NAME_SYM suffixed with  "___XR".
7610    Return symbol if found, and NULL otherwise.  */
7611
7612 static bool
7613 ada_is_renaming_symbol (struct symbol *name_sym)
7614 {
7615   const char *name = name_sym->linkage_name ();
7616   return strstr (name, "___XR") != NULL;
7617 }
7618
7619 /* Because of GNAT encoding conventions, several GDB symbols may match a
7620    given type name.  If the type denoted by TYPE0 is to be preferred to
7621    that of TYPE1 for purposes of type printing, return non-zero;
7622    otherwise return 0.  */
7623
7624 int
7625 ada_prefer_type (struct type *type0, struct type *type1)
7626 {
7627   if (type1 == NULL)
7628     return 1;
7629   else if (type0 == NULL)
7630     return 0;
7631   else if (type1->code () == TYPE_CODE_VOID)
7632     return 1;
7633   else if (type0->code () == TYPE_CODE_VOID)
7634     return 0;
7635   else if (type1->name () == NULL && type0->name () != NULL)
7636     return 1;
7637   else if (ada_is_constrained_packed_array_type (type0))
7638     return 1;
7639   else if (ada_is_array_descriptor_type (type0)
7640            && !ada_is_array_descriptor_type (type1))
7641     return 1;
7642   else
7643     {
7644       const char *type0_name = type0->name ();
7645       const char *type1_name = type1->name ();
7646
7647       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7648           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7649         return 1;
7650     }
7651   return 0;
7652 }
7653
7654 /* The name of TYPE, which is its TYPE_NAME.  Null if TYPE is
7655    null.  */
7656
7657 const char *
7658 ada_type_name (struct type *type)
7659 {
7660   if (type == NULL)
7661     return NULL;
7662   return type->name ();
7663 }
7664
7665 /* Search the list of "descriptive" types associated to TYPE for a type
7666    whose name is NAME.  */
7667
7668 static struct type *
7669 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7670 {
7671   struct type *result, *tmp;
7672
7673   if (ada_ignore_descriptive_types_p)
7674     return NULL;
7675
7676   /* If there no descriptive-type info, then there is no parallel type
7677      to be found.  */
7678   if (!HAVE_GNAT_AUX_INFO (type))
7679     return NULL;
7680
7681   result = TYPE_DESCRIPTIVE_TYPE (type);
7682   while (result != NULL)
7683     {
7684       const char *result_name = ada_type_name (result);
7685
7686       if (result_name == NULL)
7687         {
7688           warning (_("unexpected null name on descriptive type"));
7689           return NULL;
7690         }
7691
7692       /* If the names match, stop.  */
7693       if (strcmp (result_name, name) == 0)
7694         break;
7695
7696       /* Otherwise, look at the next item on the list, if any.  */
7697       if (HAVE_GNAT_AUX_INFO (result))
7698         tmp = TYPE_DESCRIPTIVE_TYPE (result);
7699       else
7700         tmp = NULL;
7701
7702       /* If not found either, try after having resolved the typedef.  */
7703       if (tmp != NULL)
7704         result = tmp;
7705       else
7706         {
7707           result = check_typedef (result);
7708           if (HAVE_GNAT_AUX_INFO (result))
7709             result = TYPE_DESCRIPTIVE_TYPE (result);
7710           else
7711             result = NULL;
7712         }
7713     }
7714
7715   /* If we didn't find a match, see whether this is a packed array.  With
7716      older compilers, the descriptive type information is either absent or
7717      irrelevant when it comes to packed arrays so the above lookup fails.
7718      Fall back to using a parallel lookup by name in this case.  */
7719   if (result == NULL && ada_is_constrained_packed_array_type (type))
7720     return ada_find_any_type (name);
7721
7722   return result;
7723 }
7724
7725 /* Find a parallel type to TYPE with the specified NAME, using the
7726    descriptive type taken from the debugging information, if available,
7727    and otherwise using the (slower) name-based method.  */
7728
7729 static struct type *
7730 ada_find_parallel_type_with_name (struct type *type, const char *name)
7731 {
7732   struct type *result = NULL;
7733
7734   if (HAVE_GNAT_AUX_INFO (type))
7735     result = find_parallel_type_by_descriptive_type (type, name);
7736   else
7737     result = ada_find_any_type (name);
7738
7739   return result;
7740 }
7741
7742 /* Same as above, but specify the name of the parallel type by appending
7743    SUFFIX to the name of TYPE.  */
7744
7745 struct type *
7746 ada_find_parallel_type (struct type *type, const char *suffix)
7747 {
7748   char *name;
7749   const char *type_name = ada_type_name (type);
7750   int len;
7751
7752   if (type_name == NULL)
7753     return NULL;
7754
7755   len = strlen (type_name);
7756
7757   name = (char *) alloca (len + strlen (suffix) + 1);
7758
7759   strcpy (name, type_name);
7760   strcpy (name + len, suffix);
7761
7762   return ada_find_parallel_type_with_name (type, name);
7763 }
7764
7765 /* If TYPE is a variable-size record type, return the corresponding template
7766    type describing its fields.  Otherwise, return NULL.  */
7767
7768 static struct type *
7769 dynamic_template_type (struct type *type)
7770 {
7771   type = ada_check_typedef (type);
7772
7773   if (type == NULL || type->code () != TYPE_CODE_STRUCT
7774       || ada_type_name (type) == NULL)
7775     return NULL;
7776   else
7777     {
7778       int len = strlen (ada_type_name (type));
7779
7780       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7781         return type;
7782       else
7783         return ada_find_parallel_type (type, "___XVE");
7784     }
7785 }
7786
7787 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7788    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
7789
7790 static int
7791 is_dynamic_field (struct type *templ_type, int field_num)
7792 {
7793   const char *name = templ_type->field (field_num).name ();
7794
7795   return name != NULL
7796     && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7797     && strstr (name, "___XVL") != NULL;
7798 }
7799
7800 /* The index of the variant field of TYPE, or -1 if TYPE does not
7801    represent a variant record type.  */
7802
7803 static int
7804 variant_field_index (struct type *type)
7805 {
7806   int f;
7807
7808   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7809     return -1;
7810
7811   for (f = 0; f < type->num_fields (); f += 1)
7812     {
7813       if (ada_is_variant_part (type, f))
7814         return f;
7815     }
7816   return -1;
7817 }
7818
7819 /* A record type with no fields.  */
7820
7821 static struct type *
7822 empty_record (struct type *templ)
7823 {
7824   struct type *type = alloc_type_copy (templ);
7825
7826   type->set_code (TYPE_CODE_STRUCT);
7827   INIT_NONE_SPECIFIC (type);
7828   type->set_name ("<empty>");
7829   TYPE_LENGTH (type) = 0;
7830   return type;
7831 }
7832
7833 /* An ordinary record type (with fixed-length fields) that describes
7834    the value of type TYPE at VALADDR or ADDRESS (see comments at
7835    the beginning of this section) VAL according to GNAT conventions.
7836    DVAL0 should describe the (portion of a) record that contains any
7837    necessary discriminants.  It should be NULL if value_type (VAL) is
7838    an outer-level type (i.e., as opposed to a branch of a variant.)  A
7839    variant field (unless unchecked) is replaced by a particular branch
7840    of the variant.
7841
7842    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7843    length are not statically known are discarded.  As a consequence,
7844    VALADDR, ADDRESS and DVAL0 are ignored.
7845
7846    NOTE: Limitations: For now, we assume that dynamic fields and
7847    variants occupy whole numbers of bytes.  However, they need not be
7848    byte-aligned.  */
7849
7850 struct type *
7851 ada_template_to_fixed_record_type_1 (struct type *type,
7852                                      const gdb_byte *valaddr,
7853                                      CORE_ADDR address, struct value *dval0,
7854                                      int keep_dynamic_fields)
7855 {
7856   struct value *mark = value_mark ();
7857   struct value *dval;
7858   struct type *rtype;
7859   int nfields, bit_len;
7860   int variant_field;
7861   long off;
7862   int fld_bit_len;
7863   int f;
7864
7865   /* Compute the number of fields in this record type that are going
7866      to be processed: unless keep_dynamic_fields, this includes only
7867      fields whose position and length are static will be processed.  */
7868   if (keep_dynamic_fields)
7869     nfields = type->num_fields ();
7870   else
7871     {
7872       nfields = 0;
7873       while (nfields < type->num_fields ()
7874              && !ada_is_variant_part (type, nfields)
7875              && !is_dynamic_field (type, nfields))
7876         nfields++;
7877     }
7878
7879   rtype = alloc_type_copy (type);
7880   rtype->set_code (TYPE_CODE_STRUCT);
7881   INIT_NONE_SPECIFIC (rtype);
7882   rtype->set_num_fields (nfields);
7883   rtype->set_fields
7884    ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7885   rtype->set_name (ada_type_name (type));
7886   rtype->set_is_fixed_instance (true);
7887
7888   off = 0;
7889   bit_len = 0;
7890   variant_field = -1;
7891
7892   for (f = 0; f < nfields; f += 1)
7893     {
7894       off = align_up (off, field_alignment (type, f))
7895         + type->field (f).loc_bitpos ();
7896       rtype->field (f).set_loc_bitpos (off);
7897       TYPE_FIELD_BITSIZE (rtype, f) = 0;
7898
7899       if (ada_is_variant_part (type, f))
7900         {
7901           variant_field = f;
7902           fld_bit_len = 0;
7903         }
7904       else if (is_dynamic_field (type, f))
7905         {
7906           const gdb_byte *field_valaddr = valaddr;
7907           CORE_ADDR field_address = address;
7908           struct type *field_type =
7909             TYPE_TARGET_TYPE (type->field (f).type ());
7910
7911           if (dval0 == NULL)
7912             {
7913               /* Using plain value_from_contents_and_address here
7914                  causes problems because we will end up trying to
7915                  resolve a type that is currently being
7916                  constructed.  */
7917               dval = value_from_contents_and_address_unresolved (rtype,
7918                                                                  valaddr,
7919                                                                  address);
7920               rtype = value_type (dval);
7921             }
7922           else
7923             dval = dval0;
7924
7925           /* If the type referenced by this field is an aligner type, we need
7926              to unwrap that aligner type, because its size might not be set.
7927              Keeping the aligner type would cause us to compute the wrong
7928              size for this field, impacting the offset of the all the fields
7929              that follow this one.  */
7930           if (ada_is_aligner_type (field_type))
7931             {
7932               long field_offset = type->field (f).loc_bitpos ();
7933
7934               field_valaddr = cond_offset_host (field_valaddr, field_offset);
7935               field_address = cond_offset_target (field_address, field_offset);
7936               field_type = ada_aligned_type (field_type);
7937             }
7938
7939           field_valaddr = cond_offset_host (field_valaddr,
7940                                             off / TARGET_CHAR_BIT);
7941           field_address = cond_offset_target (field_address,
7942                                               off / TARGET_CHAR_BIT);
7943
7944           /* Get the fixed type of the field.  Note that, in this case,
7945              we do not want to get the real type out of the tag: if
7946              the current field is the parent part of a tagged record,
7947              we will get the tag of the object.  Clearly wrong: the real
7948              type of the parent is not the real type of the child.  We
7949              would end up in an infinite loop.  */
7950           field_type = ada_get_base_type (field_type);
7951           field_type = ada_to_fixed_type (field_type, field_valaddr,
7952                                           field_address, dval, 0);
7953
7954           rtype->field (f).set_type (field_type);
7955           rtype->field (f).set_name (type->field (f).name ());
7956           /* The multiplication can potentially overflow.  But because
7957              the field length has been size-checked just above, and
7958              assuming that the maximum size is a reasonable value,
7959              an overflow should not happen in practice.  So rather than
7960              adding overflow recovery code to this already complex code,
7961              we just assume that it's not going to happen.  */
7962           fld_bit_len =
7963             TYPE_LENGTH (rtype->field (f).type ()) * TARGET_CHAR_BIT;
7964         }
7965       else
7966         {
7967           /* Note: If this field's type is a typedef, it is important
7968              to preserve the typedef layer.
7969
7970              Otherwise, we might be transforming a typedef to a fat
7971              pointer (encoding a pointer to an unconstrained array),
7972              into a basic fat pointer (encoding an unconstrained
7973              array).  As both types are implemented using the same
7974              structure, the typedef is the only clue which allows us
7975              to distinguish between the two options.  Stripping it
7976              would prevent us from printing this field appropriately.  */
7977           rtype->field (f).set_type (type->field (f).type ());
7978           rtype->field (f).set_name (type->field (f).name ());
7979           if (TYPE_FIELD_BITSIZE (type, f) > 0)
7980             fld_bit_len =
7981               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7982           else
7983             {
7984               struct type *field_type = type->field (f).type ();
7985
7986               /* We need to be careful of typedefs when computing
7987                  the length of our field.  If this is a typedef,
7988                  get the length of the target type, not the length
7989                  of the typedef.  */
7990               if (field_type->code () == TYPE_CODE_TYPEDEF)
7991                 field_type = ada_typedef_target_type (field_type);
7992
7993               fld_bit_len =
7994                 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7995             }
7996         }
7997       if (off + fld_bit_len > bit_len)
7998         bit_len = off + fld_bit_len;
7999       off += fld_bit_len;
8000       TYPE_LENGTH (rtype) =
8001         align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8002     }
8003
8004   /* We handle the variant part, if any, at the end because of certain
8005      odd cases in which it is re-ordered so as NOT to be the last field of
8006      the record.  This can happen in the presence of representation
8007      clauses.  */
8008   if (variant_field >= 0)
8009     {
8010       struct type *branch_type;
8011
8012       off = rtype->field (variant_field).loc_bitpos ();
8013
8014       if (dval0 == NULL)
8015         {
8016           /* Using plain value_from_contents_and_address here causes
8017              problems because we will end up trying to resolve a type
8018              that is currently being constructed.  */
8019           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8020                                                              address);
8021           rtype = value_type (dval);
8022         }
8023       else
8024         dval = dval0;
8025
8026       branch_type =
8027         to_fixed_variant_branch_type
8028         (type->field (variant_field).type (),
8029          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8030          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8031       if (branch_type == NULL)
8032         {
8033           for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
8034             rtype->field (f - 1) = rtype->field (f);
8035           rtype->set_num_fields (rtype->num_fields () - 1);
8036         }
8037       else
8038         {
8039           rtype->field (variant_field).set_type (branch_type);
8040           rtype->field (variant_field).set_name ("S");
8041           fld_bit_len =
8042             TYPE_LENGTH (rtype->field (variant_field).type ()) *
8043             TARGET_CHAR_BIT;
8044           if (off + fld_bit_len > bit_len)
8045             bit_len = off + fld_bit_len;
8046           TYPE_LENGTH (rtype) =
8047             align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8048         }
8049     }
8050
8051   /* According to exp_dbug.ads, the size of TYPE for variable-size records
8052      should contain the alignment of that record, which should be a strictly
8053      positive value.  If null or negative, then something is wrong, most
8054      probably in the debug info.  In that case, we don't round up the size
8055      of the resulting type.  If this record is not part of another structure,
8056      the current RTYPE length might be good enough for our purposes.  */
8057   if (TYPE_LENGTH (type) <= 0)
8058     {
8059       if (rtype->name ())
8060         warning (_("Invalid type size for `%s' detected: %s."),
8061                  rtype->name (), pulongest (TYPE_LENGTH (type)));
8062       else
8063         warning (_("Invalid type size for <unnamed> detected: %s."),
8064                  pulongest (TYPE_LENGTH (type)));
8065     }
8066   else
8067     {
8068       TYPE_LENGTH (rtype) = align_up (TYPE_LENGTH (rtype),
8069                                       TYPE_LENGTH (type));
8070     }
8071
8072   value_free_to_mark (mark);
8073   return rtype;
8074 }
8075
8076 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8077    of 1.  */
8078
8079 static struct type *
8080 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8081                                CORE_ADDR address, struct value *dval0)
8082 {
8083   return ada_template_to_fixed_record_type_1 (type, valaddr,
8084                                               address, dval0, 1);
8085 }
8086
8087 /* An ordinary record type in which ___XVL-convention fields and
8088    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8089    static approximations, containing all possible fields.  Uses
8090    no runtime values.  Useless for use in values, but that's OK,
8091    since the results are used only for type determinations.   Works on both
8092    structs and unions.  Representation note: to save space, we memorize
8093    the result of this function in the TYPE_TARGET_TYPE of the
8094    template type.  */
8095
8096 static struct type *
8097 template_to_static_fixed_type (struct type *type0)
8098 {
8099   struct type *type;
8100   int nfields;
8101   int f;
8102
8103   /* No need no do anything if the input type is already fixed.  */
8104   if (type0->is_fixed_instance ())
8105     return type0;
8106
8107   /* Likewise if we already have computed the static approximation.  */
8108   if (TYPE_TARGET_TYPE (type0) != NULL)
8109     return TYPE_TARGET_TYPE (type0);
8110
8111   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
8112   type = type0;
8113   nfields = type0->num_fields ();
8114
8115   /* Whether or not we cloned TYPE0, cache the result so that we don't do
8116      recompute all over next time.  */
8117   type0->set_target_type (type);
8118
8119   for (f = 0; f < nfields; f += 1)
8120     {
8121       struct type *field_type = type0->field (f).type ();
8122       struct type *new_type;
8123
8124       if (is_dynamic_field (type0, f))
8125         {
8126           field_type = ada_check_typedef (field_type);
8127           new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8128         }
8129       else
8130         new_type = static_unwrap_type (field_type);
8131
8132       if (new_type != field_type)
8133         {
8134           /* Clone TYPE0 only the first time we get a new field type.  */
8135           if (type == type0)
8136             {
8137               type = alloc_type_copy (type0);
8138               type0->set_target_type (type);
8139               type->set_code (type0->code ());
8140               INIT_NONE_SPECIFIC (type);
8141               type->set_num_fields (nfields);
8142
8143               field *fields =
8144                 ((struct field *)
8145                  TYPE_ALLOC (type, nfields * sizeof (struct field)));
8146               memcpy (fields, type0->fields (),
8147                       sizeof (struct field) * nfields);
8148               type->set_fields (fields);
8149
8150               type->set_name (ada_type_name (type0));
8151               type->set_is_fixed_instance (true);
8152               TYPE_LENGTH (type) = 0;
8153             }
8154           type->field (f).set_type (new_type);
8155           type->field (f).set_name (type0->field (f).name ());
8156         }
8157     }
8158
8159   return type;
8160 }
8161
8162 /* Given an object of type TYPE whose contents are at VALADDR and
8163    whose address in memory is ADDRESS, returns a revision of TYPE,
8164    which should be a non-dynamic-sized record, in which the variant
8165    part, if any, is replaced with the appropriate branch.  Looks
8166    for discriminant values in DVAL0, which can be NULL if the record
8167    contains the necessary discriminant values.  */
8168
8169 static struct type *
8170 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8171                                    CORE_ADDR address, struct value *dval0)
8172 {
8173   struct value *mark = value_mark ();
8174   struct value *dval;
8175   struct type *rtype;
8176   struct type *branch_type;
8177   int nfields = type->num_fields ();
8178   int variant_field = variant_field_index (type);
8179
8180   if (variant_field == -1)
8181     return type;
8182
8183   if (dval0 == NULL)
8184     {
8185       dval = value_from_contents_and_address (type, valaddr, address);
8186       type = value_type (dval);
8187     }
8188   else
8189     dval = dval0;
8190
8191   rtype = alloc_type_copy (type);
8192   rtype->set_code (TYPE_CODE_STRUCT);
8193   INIT_NONE_SPECIFIC (rtype);
8194   rtype->set_num_fields (nfields);
8195
8196   field *fields =
8197     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8198   memcpy (fields, type->fields (), sizeof (struct field) * nfields);
8199   rtype->set_fields (fields);
8200
8201   rtype->set_name (ada_type_name (type));
8202   rtype->set_is_fixed_instance (true);
8203   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8204
8205   branch_type = to_fixed_variant_branch_type
8206     (type->field (variant_field).type (),
8207      cond_offset_host (valaddr,
8208                        type->field (variant_field).loc_bitpos ()
8209                        / TARGET_CHAR_BIT),
8210      cond_offset_target (address,
8211                          type->field (variant_field).loc_bitpos ()
8212                          / TARGET_CHAR_BIT), dval);
8213   if (branch_type == NULL)
8214     {
8215       int f;
8216
8217       for (f = variant_field + 1; f < nfields; f += 1)
8218         rtype->field (f - 1) = rtype->field (f);
8219       rtype->set_num_fields (rtype->num_fields () - 1);
8220     }
8221   else
8222     {
8223       rtype->field (variant_field).set_type (branch_type);
8224       rtype->field (variant_field).set_name ("S");
8225       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8226       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8227     }
8228   TYPE_LENGTH (rtype) -= TYPE_LENGTH (type->field (variant_field).type ());
8229
8230   value_free_to_mark (mark);
8231   return rtype;
8232 }
8233
8234 /* An ordinary record type (with fixed-length fields) that describes
8235    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8236    beginning of this section].   Any necessary discriminants' values
8237    should be in DVAL, a record value; it may be NULL if the object
8238    at ADDR itself contains any necessary discriminant values.
8239    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8240    values from the record are needed.  Except in the case that DVAL,
8241    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8242    unchecked) is replaced by a particular branch of the variant.
8243
8244    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8245    is questionable and may be removed.  It can arise during the
8246    processing of an unconstrained-array-of-record type where all the
8247    variant branches have exactly the same size.  This is because in
8248    such cases, the compiler does not bother to use the XVS convention
8249    when encoding the record.  I am currently dubious of this
8250    shortcut and suspect the compiler should be altered.  FIXME.  */
8251
8252 static struct type *
8253 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8254                       CORE_ADDR address, struct value *dval)
8255 {
8256   struct type *templ_type;
8257
8258   if (type0->is_fixed_instance ())
8259     return type0;
8260
8261   templ_type = dynamic_template_type (type0);
8262
8263   if (templ_type != NULL)
8264     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8265   else if (variant_field_index (type0) >= 0)
8266     {
8267       if (dval == NULL && valaddr == NULL && address == 0)
8268         return type0;
8269       return to_record_with_fixed_variant_part (type0, valaddr, address,
8270                                                 dval);
8271     }
8272   else
8273     {
8274       type0->set_is_fixed_instance (true);
8275       return type0;
8276     }
8277
8278 }
8279
8280 /* An ordinary record type (with fixed-length fields) that describes
8281    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8282    union type.  Any necessary discriminants' values should be in DVAL,
8283    a record value.  That is, this routine selects the appropriate
8284    branch of the union at ADDR according to the discriminant value
8285    indicated in the union's type name.  Returns VAR_TYPE0 itself if
8286    it represents a variant subject to a pragma Unchecked_Union.  */
8287
8288 static struct type *
8289 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8290                               CORE_ADDR address, struct value *dval)
8291 {
8292   int which;
8293   struct type *templ_type;
8294   struct type *var_type;
8295
8296   if (var_type0->code () == TYPE_CODE_PTR)
8297     var_type = TYPE_TARGET_TYPE (var_type0);
8298   else
8299     var_type = var_type0;
8300
8301   templ_type = ada_find_parallel_type (var_type, "___XVU");
8302
8303   if (templ_type != NULL)
8304     var_type = templ_type;
8305
8306   if (is_unchecked_variant (var_type, value_type (dval)))
8307       return var_type0;
8308   which = ada_which_variant_applies (var_type, dval);
8309
8310   if (which < 0)
8311     return empty_record (var_type);
8312   else if (is_dynamic_field (var_type, which))
8313     return to_fixed_record_type
8314       (TYPE_TARGET_TYPE (var_type->field (which).type ()),
8315        valaddr, address, dval);
8316   else if (variant_field_index (var_type->field (which).type ()) >= 0)
8317     return
8318       to_fixed_record_type
8319       (var_type->field (which).type (), valaddr, address, dval);
8320   else
8321     return var_type->field (which).type ();
8322 }
8323
8324 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8325    ENCODING_TYPE, a type following the GNAT conventions for discrete
8326    type encodings, only carries redundant information.  */
8327
8328 static int
8329 ada_is_redundant_range_encoding (struct type *range_type,
8330                                  struct type *encoding_type)
8331 {
8332   const char *bounds_str;
8333   int n;
8334   LONGEST lo, hi;
8335
8336   gdb_assert (range_type->code () == TYPE_CODE_RANGE);
8337
8338   if (get_base_type (range_type)->code ()
8339       != get_base_type (encoding_type)->code ())
8340     {
8341       /* The compiler probably used a simple base type to describe
8342          the range type instead of the range's actual base type,
8343          expecting us to get the real base type from the encoding
8344          anyway.  In this situation, the encoding cannot be ignored
8345          as redundant.  */
8346       return 0;
8347     }
8348
8349   if (is_dynamic_type (range_type))
8350     return 0;
8351
8352   if (encoding_type->name () == NULL)
8353     return 0;
8354
8355   bounds_str = strstr (encoding_type->name (), "___XDLU_");
8356   if (bounds_str == NULL)
8357     return 0;
8358
8359   n = 8; /* Skip "___XDLU_".  */
8360   if (!ada_scan_number (bounds_str, n, &lo, &n))
8361     return 0;
8362   if (range_type->bounds ()->low.const_val () != lo)
8363     return 0;
8364
8365   n += 2; /* Skip the "__" separator between the two bounds.  */
8366   if (!ada_scan_number (bounds_str, n, &hi, &n))
8367     return 0;
8368   if (range_type->bounds ()->high.const_val () != hi)
8369     return 0;
8370
8371   return 1;
8372 }
8373
8374 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8375    a type following the GNAT encoding for describing array type
8376    indices, only carries redundant information.  */
8377
8378 static int
8379 ada_is_redundant_index_type_desc (struct type *array_type,
8380                                   struct type *desc_type)
8381 {
8382   struct type *this_layer = check_typedef (array_type);
8383   int i;
8384
8385   for (i = 0; i < desc_type->num_fields (); i++)
8386     {
8387       if (!ada_is_redundant_range_encoding (this_layer->index_type (),
8388                                             desc_type->field (i).type ()))
8389         return 0;
8390       this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8391     }
8392
8393   return 1;
8394 }
8395
8396 /* Assuming that TYPE0 is an array type describing the type of a value
8397    at ADDR, and that DVAL describes a record containing any
8398    discriminants used in TYPE0, returns a type for the value that
8399    contains no dynamic components (that is, no components whose sizes
8400    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
8401    true, gives an error message if the resulting type's size is over
8402    varsize_limit.  */
8403
8404 static struct type *
8405 to_fixed_array_type (struct type *type0, struct value *dval,
8406                      int ignore_too_big)
8407 {
8408   struct type *index_type_desc;
8409   struct type *result;
8410   int constrained_packed_array_p;
8411   static const char *xa_suffix = "___XA";
8412
8413   type0 = ada_check_typedef (type0);
8414   if (type0->is_fixed_instance ())
8415     return type0;
8416
8417   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8418   if (constrained_packed_array_p)
8419     {
8420       type0 = decode_constrained_packed_array_type (type0);
8421       if (type0 == nullptr)
8422         error (_("could not decode constrained packed array type"));
8423     }
8424
8425   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8426
8427   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8428      encoding suffixed with 'P' may still be generated.  If so,
8429      it should be used to find the XA type.  */
8430
8431   if (index_type_desc == NULL)
8432     {
8433       const char *type_name = ada_type_name (type0);
8434
8435       if (type_name != NULL)
8436         {
8437           const int len = strlen (type_name);
8438           char *name = (char *) alloca (len + strlen (xa_suffix));
8439
8440           if (type_name[len - 1] == 'P')
8441             {
8442               strcpy (name, type_name);
8443               strcpy (name + len - 1, xa_suffix);
8444               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8445             }
8446         }
8447     }
8448
8449   ada_fixup_array_indexes_type (index_type_desc);
8450   if (index_type_desc != NULL
8451       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8452     {
8453       /* Ignore this ___XA parallel type, as it does not bring any
8454          useful information.  This allows us to avoid creating fixed
8455          versions of the array's index types, which would be identical
8456          to the original ones.  This, in turn, can also help avoid
8457          the creation of fixed versions of the array itself.  */
8458       index_type_desc = NULL;
8459     }
8460
8461   if (index_type_desc == NULL)
8462     {
8463       struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8464
8465       /* NOTE: elt_type---the fixed version of elt_type0---should never
8466          depend on the contents of the array in properly constructed
8467          debugging data.  */
8468       /* Create a fixed version of the array element type.
8469          We're not providing the address of an element here,
8470          and thus the actual object value cannot be inspected to do
8471          the conversion.  This should not be a problem, since arrays of
8472          unconstrained objects are not allowed.  In particular, all
8473          the elements of an array of a tagged type should all be of
8474          the same type specified in the debugging info.  No need to
8475          consult the object tag.  */
8476       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8477
8478       /* Make sure we always create a new array type when dealing with
8479          packed array types, since we're going to fix-up the array
8480          type length and element bitsize a little further down.  */
8481       if (elt_type0 == elt_type && !constrained_packed_array_p)
8482         result = type0;
8483       else
8484         result = create_array_type (alloc_type_copy (type0),
8485                                     elt_type, type0->index_type ());
8486     }
8487   else
8488     {
8489       int i;
8490       struct type *elt_type0;
8491
8492       elt_type0 = type0;
8493       for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8494         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8495
8496       /* NOTE: result---the fixed version of elt_type0---should never
8497          depend on the contents of the array in properly constructed
8498          debugging data.  */
8499       /* Create a fixed version of the array element type.
8500          We're not providing the address of an element here,
8501          and thus the actual object value cannot be inspected to do
8502          the conversion.  This should not be a problem, since arrays of
8503          unconstrained objects are not allowed.  In particular, all
8504          the elements of an array of a tagged type should all be of
8505          the same type specified in the debugging info.  No need to
8506          consult the object tag.  */
8507       result =
8508         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8509
8510       elt_type0 = type0;
8511       for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8512         {
8513           struct type *range_type =
8514             to_fixed_range_type (index_type_desc->field (i).type (), dval);
8515
8516           result = create_array_type (alloc_type_copy (elt_type0),
8517                                       result, range_type);
8518           elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8519         }
8520     }
8521
8522   /* We want to preserve the type name.  This can be useful when
8523      trying to get the type name of a value that has already been
8524      printed (for instance, if the user did "print VAR; whatis $".  */
8525   result->set_name (type0->name ());
8526
8527   if (constrained_packed_array_p)
8528     {
8529       /* So far, the resulting type has been created as if the original
8530          type was a regular (non-packed) array type.  As a result, the
8531          bitsize of the array elements needs to be set again, and the array
8532          length needs to be recomputed based on that bitsize.  */
8533       int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8534       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8535
8536       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8537       TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8538       if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8539         TYPE_LENGTH (result)++;
8540     }
8541
8542   result->set_is_fixed_instance (true);
8543   return result;
8544 }
8545
8546
8547 /* A standard type (containing no dynamically sized components)
8548    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8549    DVAL describes a record containing any discriminants used in TYPE0,
8550    and may be NULL if there are none, or if the object of type TYPE at
8551    ADDRESS or in VALADDR contains these discriminants.
8552    
8553    If CHECK_TAG is not null, in the case of tagged types, this function
8554    attempts to locate the object's tag and use it to compute the actual
8555    type.  However, when ADDRESS is null, we cannot use it to determine the
8556    location of the tag, and therefore compute the tagged type's actual type.
8557    So we return the tagged type without consulting the tag.  */
8558    
8559 static struct type *
8560 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8561                    CORE_ADDR address, struct value *dval, int check_tag)
8562 {
8563   type = ada_check_typedef (type);
8564
8565   /* Only un-fixed types need to be handled here.  */
8566   if (!HAVE_GNAT_AUX_INFO (type))
8567     return type;
8568
8569   switch (type->code ())
8570     {
8571     default:
8572       return type;
8573     case TYPE_CODE_STRUCT:
8574       {
8575         struct type *static_type = to_static_fixed_type (type);
8576         struct type *fixed_record_type =
8577           to_fixed_record_type (type, valaddr, address, NULL);
8578
8579         /* If STATIC_TYPE is a tagged type and we know the object's address,
8580            then we can determine its tag, and compute the object's actual
8581            type from there.  Note that we have to use the fixed record
8582            type (the parent part of the record may have dynamic fields
8583            and the way the location of _tag is expressed may depend on
8584            them).  */
8585
8586         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8587           {
8588             struct value *tag =
8589               value_tag_from_contents_and_address
8590               (fixed_record_type,
8591                valaddr,
8592                address);
8593             struct type *real_type = type_from_tag (tag);
8594             struct value *obj =
8595               value_from_contents_and_address (fixed_record_type,
8596                                                valaddr,
8597                                                address);
8598             fixed_record_type = value_type (obj);
8599             if (real_type != NULL)
8600               return to_fixed_record_type
8601                 (real_type, NULL,
8602                  value_address (ada_tag_value_at_base_address (obj)), NULL);
8603           }
8604
8605         /* Check to see if there is a parallel ___XVZ variable.
8606            If there is, then it provides the actual size of our type.  */
8607         else if (ada_type_name (fixed_record_type) != NULL)
8608           {
8609             const char *name = ada_type_name (fixed_record_type);
8610             char *xvz_name
8611               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8612             bool xvz_found = false;
8613             LONGEST size;
8614
8615             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8616             try
8617               {
8618                 xvz_found = get_int_var_value (xvz_name, size);
8619               }
8620             catch (const gdb_exception_error &except)
8621               {
8622                 /* We found the variable, but somehow failed to read
8623                    its value.  Rethrow the same error, but with a little
8624                    bit more information, to help the user understand
8625                    what went wrong (Eg: the variable might have been
8626                    optimized out).  */
8627                 throw_error (except.error,
8628                              _("unable to read value of %s (%s)"),
8629                              xvz_name, except.what ());
8630               }
8631
8632             if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8633               {
8634                 fixed_record_type = copy_type (fixed_record_type);
8635                 TYPE_LENGTH (fixed_record_type) = size;
8636
8637                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
8638                    observed this when the debugging info is STABS, and
8639                    apparently it is something that is hard to fix.
8640
8641                    In practice, we don't need the actual type definition
8642                    at all, because the presence of the XVZ variable allows us
8643                    to assume that there must be a XVS type as well, which we
8644                    should be able to use later, when we need the actual type
8645                    definition.
8646
8647                    In the meantime, pretend that the "fixed" type we are
8648                    returning is NOT a stub, because this can cause trouble
8649                    when using this type to create new types targeting it.
8650                    Indeed, the associated creation routines often check
8651                    whether the target type is a stub and will try to replace
8652                    it, thus using a type with the wrong size.  This, in turn,
8653                    might cause the new type to have the wrong size too.
8654                    Consider the case of an array, for instance, where the size
8655                    of the array is computed from the number of elements in
8656                    our array multiplied by the size of its element.  */
8657                 fixed_record_type->set_is_stub (false);
8658               }
8659           }
8660         return fixed_record_type;
8661       }
8662     case TYPE_CODE_ARRAY:
8663       return to_fixed_array_type (type, dval, 1);
8664     case TYPE_CODE_UNION:
8665       if (dval == NULL)
8666         return type;
8667       else
8668         return to_fixed_variant_branch_type (type, valaddr, address, dval);
8669     }
8670 }
8671
8672 /* The same as ada_to_fixed_type_1, except that it preserves the type
8673    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8674
8675    The typedef layer needs be preserved in order to differentiate between
8676    arrays and array pointers when both types are implemented using the same
8677    fat pointer.  In the array pointer case, the pointer is encoded as
8678    a typedef of the pointer type.  For instance, considering:
8679
8680           type String_Access is access String;
8681           S1 : String_Access := null;
8682
8683    To the debugger, S1 is defined as a typedef of type String.  But
8684    to the user, it is a pointer.  So if the user tries to print S1,
8685    we should not dereference the array, but print the array address
8686    instead.
8687
8688    If we didn't preserve the typedef layer, we would lose the fact that
8689    the type is to be presented as a pointer (needs de-reference before
8690    being printed).  And we would also use the source-level type name.  */
8691
8692 struct type *
8693 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8694                    CORE_ADDR address, struct value *dval, int check_tag)
8695
8696 {
8697   struct type *fixed_type =
8698     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8699
8700   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8701       then preserve the typedef layer.
8702
8703       Implementation note: We can only check the main-type portion of
8704       the TYPE and FIXED_TYPE, because eliminating the typedef layer
8705       from TYPE now returns a type that has the same instance flags
8706       as TYPE.  For instance, if TYPE is a "typedef const", and its
8707       target type is a "struct", then the typedef elimination will return
8708       a "const" version of the target type.  See check_typedef for more
8709       details about how the typedef layer elimination is done.
8710
8711       brobecker/2010-11-19: It seems to me that the only case where it is
8712       useful to preserve the typedef layer is when dealing with fat pointers.
8713       Perhaps, we could add a check for that and preserve the typedef layer
8714       only in that situation.  But this seems unnecessary so far, probably
8715       because we call check_typedef/ada_check_typedef pretty much everywhere.
8716       */
8717   if (type->code () == TYPE_CODE_TYPEDEF
8718       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8719           == TYPE_MAIN_TYPE (fixed_type)))
8720     return type;
8721
8722   return fixed_type;
8723 }
8724
8725 /* A standard (static-sized) type corresponding as well as possible to
8726    TYPE0, but based on no runtime data.  */
8727
8728 static struct type *
8729 to_static_fixed_type (struct type *type0)
8730 {
8731   struct type *type;
8732
8733   if (type0 == NULL)
8734     return NULL;
8735
8736   if (type0->is_fixed_instance ())
8737     return type0;
8738
8739   type0 = ada_check_typedef (type0);
8740
8741   switch (type0->code ())
8742     {
8743     default:
8744       return type0;
8745     case TYPE_CODE_STRUCT:
8746       type = dynamic_template_type (type0);
8747       if (type != NULL)
8748         return template_to_static_fixed_type (type);
8749       else
8750         return template_to_static_fixed_type (type0);
8751     case TYPE_CODE_UNION:
8752       type = ada_find_parallel_type (type0, "___XVU");
8753       if (type != NULL)
8754         return template_to_static_fixed_type (type);
8755       else
8756         return template_to_static_fixed_type (type0);
8757     }
8758 }
8759
8760 /* A static approximation of TYPE with all type wrappers removed.  */
8761
8762 static struct type *
8763 static_unwrap_type (struct type *type)
8764 {
8765   if (ada_is_aligner_type (type))
8766     {
8767       struct type *type1 = ada_check_typedef (type)->field (0).type ();
8768       if (ada_type_name (type1) == NULL)
8769         type1->set_name (ada_type_name (type));
8770
8771       return static_unwrap_type (type1);
8772     }
8773   else
8774     {
8775       struct type *raw_real_type = ada_get_base_type (type);
8776
8777       if (raw_real_type == type)
8778         return type;
8779       else
8780         return to_static_fixed_type (raw_real_type);
8781     }
8782 }
8783
8784 /* In some cases, incomplete and private types require
8785    cross-references that are not resolved as records (for example,
8786       type Foo;
8787       type FooP is access Foo;
8788       V: FooP;
8789       type Foo is array ...;
8790    ).  In these cases, since there is no mechanism for producing
8791    cross-references to such types, we instead substitute for FooP a
8792    stub enumeration type that is nowhere resolved, and whose tag is
8793    the name of the actual type.  Call these types "non-record stubs".  */
8794
8795 /* A type equivalent to TYPE that is not a non-record stub, if one
8796    exists, otherwise TYPE.  */
8797
8798 struct type *
8799 ada_check_typedef (struct type *type)
8800 {
8801   if (type == NULL)
8802     return NULL;
8803
8804   /* If our type is an access to an unconstrained array, which is encoded
8805      as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8806      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8807      what allows us to distinguish between fat pointers that represent
8808      array types, and fat pointers that represent array access types
8809      (in both cases, the compiler implements them as fat pointers).  */
8810   if (ada_is_access_to_unconstrained_array (type))
8811     return type;
8812
8813   type = check_typedef (type);
8814   if (type == NULL || type->code () != TYPE_CODE_ENUM
8815       || !type->is_stub ()
8816       || type->name () == NULL)
8817     return type;
8818   else
8819     {
8820       const char *name = type->name ();
8821       struct type *type1 = ada_find_any_type (name);
8822
8823       if (type1 == NULL)
8824         return type;
8825
8826       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8827          stubs pointing to arrays, as we don't create symbols for array
8828          types, only for the typedef-to-array types).  If that's the case,
8829          strip the typedef layer.  */
8830       if (type1->code () == TYPE_CODE_TYPEDEF)
8831         type1 = ada_check_typedef (type1);
8832
8833       return type1;
8834     }
8835 }
8836
8837 /* A value representing the data at VALADDR/ADDRESS as described by
8838    type TYPE0, but with a standard (static-sized) type that correctly
8839    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
8840    type, then return VAL0 [this feature is simply to avoid redundant
8841    creation of struct values].  */
8842
8843 static struct value *
8844 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8845                            struct value *val0)
8846 {
8847   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8848
8849   if (type == type0 && val0 != NULL)
8850     return val0;
8851
8852   if (VALUE_LVAL (val0) != lval_memory)
8853     {
8854       /* Our value does not live in memory; it could be a convenience
8855          variable, for instance.  Create a not_lval value using val0's
8856          contents.  */
8857       return value_from_contents (type, value_contents (val0).data ());
8858     }
8859
8860   return value_from_contents_and_address (type, 0, address);
8861 }
8862
8863 /* A value representing VAL, but with a standard (static-sized) type
8864    that correctly describes it.  Does not necessarily create a new
8865    value.  */
8866
8867 struct value *
8868 ada_to_fixed_value (struct value *val)
8869 {
8870   val = unwrap_value (val);
8871   val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8872   return val;
8873 }
8874 \f
8875
8876 /* Attributes */
8877
8878 /* Table mapping attribute numbers to names.
8879    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
8880
8881 static const char * const attribute_names[] = {
8882   "<?>",
8883
8884   "first",
8885   "last",
8886   "length",
8887   "image",
8888   "max",
8889   "min",
8890   "modulus",
8891   "pos",
8892   "size",
8893   "tag",
8894   "val",
8895   0
8896 };
8897
8898 static const char *
8899 ada_attribute_name (enum exp_opcode n)
8900 {
8901   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8902     return attribute_names[n - OP_ATR_FIRST + 1];
8903   else
8904     return attribute_names[0];
8905 }
8906
8907 /* Evaluate the 'POS attribute applied to ARG.  */
8908
8909 static LONGEST
8910 pos_atr (struct value *arg)
8911 {
8912   struct value *val = coerce_ref (arg);
8913   struct type *type = value_type (val);
8914
8915   if (!discrete_type_p (type))
8916     error (_("'POS only defined on discrete types"));
8917
8918   gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8919   if (!result.has_value ())
8920     error (_("enumeration value is invalid: can't find 'POS"));
8921
8922   return *result;
8923 }
8924
8925 struct value *
8926 ada_pos_atr (struct type *expect_type,
8927              struct expression *exp,
8928              enum noside noside, enum exp_opcode op,
8929              struct value *arg)
8930 {
8931   struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8932   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8933     return value_zero (type, not_lval);
8934   return value_from_longest (type, pos_atr (arg));
8935 }
8936
8937 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
8938
8939 static struct value *
8940 val_atr (struct type *type, LONGEST val)
8941 {
8942   gdb_assert (discrete_type_p (type));
8943   if (type->code () == TYPE_CODE_RANGE)
8944     type = TYPE_TARGET_TYPE (type);
8945   if (type->code () == TYPE_CODE_ENUM)
8946     {
8947       if (val < 0 || val >= type->num_fields ())
8948         error (_("argument to 'VAL out of range"));
8949       val = type->field (val).loc_enumval ();
8950     }
8951   return value_from_longest (type, val);
8952 }
8953
8954 struct value *
8955 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8956 {
8957   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8958     return value_zero (type, not_lval);
8959
8960   if (!discrete_type_p (type))
8961     error (_("'VAL only defined on discrete types"));
8962   if (!integer_type_p (value_type (arg)))
8963     error (_("'VAL requires integral argument"));
8964
8965   return val_atr (type, value_as_long (arg));
8966 }
8967 \f
8968
8969                                 /* Evaluation */
8970
8971 /* True if TYPE appears to be an Ada character type.
8972    [At the moment, this is true only for Character and Wide_Character;
8973    It is a heuristic test that could stand improvement].  */
8974
8975 bool
8976 ada_is_character_type (struct type *type)
8977 {
8978   const char *name;
8979
8980   /* If the type code says it's a character, then assume it really is,
8981      and don't check any further.  */
8982   if (type->code () == TYPE_CODE_CHAR)
8983     return true;
8984   
8985   /* Otherwise, assume it's a character type iff it is a discrete type
8986      with a known character type name.  */
8987   name = ada_type_name (type);
8988   return (name != NULL
8989           && (type->code () == TYPE_CODE_INT
8990               || type->code () == TYPE_CODE_RANGE)
8991           && (strcmp (name, "character") == 0
8992               || strcmp (name, "wide_character") == 0
8993               || strcmp (name, "wide_wide_character") == 0
8994               || strcmp (name, "unsigned char") == 0));
8995 }
8996
8997 /* True if TYPE appears to be an Ada string type.  */
8998
8999 bool
9000 ada_is_string_type (struct type *type)
9001 {
9002   type = ada_check_typedef (type);
9003   if (type != NULL
9004       && type->code () != TYPE_CODE_PTR
9005       && (ada_is_simple_array_type (type)
9006           || ada_is_array_descriptor_type (type))
9007       && ada_array_arity (type) == 1)
9008     {
9009       struct type *elttype = ada_array_element_type (type, 1);
9010
9011       return ada_is_character_type (elttype);
9012     }
9013   else
9014     return false;
9015 }
9016
9017 /* The compiler sometimes provides a parallel XVS type for a given
9018    PAD type.  Normally, it is safe to follow the PAD type directly,
9019    but older versions of the compiler have a bug that causes the offset
9020    of its "F" field to be wrong.  Following that field in that case
9021    would lead to incorrect results, but this can be worked around
9022    by ignoring the PAD type and using the associated XVS type instead.
9023
9024    Set to True if the debugger should trust the contents of PAD types.
9025    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
9026 static bool trust_pad_over_xvs = true;
9027
9028 /* True if TYPE is a struct type introduced by the compiler to force the
9029    alignment of a value.  Such types have a single field with a
9030    distinctive name.  */
9031
9032 int
9033 ada_is_aligner_type (struct type *type)
9034 {
9035   type = ada_check_typedef (type);
9036
9037   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9038     return 0;
9039
9040   return (type->code () == TYPE_CODE_STRUCT
9041           && type->num_fields () == 1
9042           && strcmp (type->field (0).name (), "F") == 0);
9043 }
9044
9045 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9046    the parallel type.  */
9047
9048 struct type *
9049 ada_get_base_type (struct type *raw_type)
9050 {
9051   struct type *real_type_namer;
9052   struct type *raw_real_type;
9053
9054   if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
9055     return raw_type;
9056
9057   if (ada_is_aligner_type (raw_type))
9058     /* The encoding specifies that we should always use the aligner type.
9059        So, even if this aligner type has an associated XVS type, we should
9060        simply ignore it.
9061
9062        According to the compiler gurus, an XVS type parallel to an aligner
9063        type may exist because of a stabs limitation.  In stabs, aligner
9064        types are empty because the field has a variable-sized type, and
9065        thus cannot actually be used as an aligner type.  As a result,
9066        we need the associated parallel XVS type to decode the type.
9067        Since the policy in the compiler is to not change the internal
9068        representation based on the debugging info format, we sometimes
9069        end up having a redundant XVS type parallel to the aligner type.  */
9070     return raw_type;
9071
9072   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9073   if (real_type_namer == NULL
9074       || real_type_namer->code () != TYPE_CODE_STRUCT
9075       || real_type_namer->num_fields () != 1)
9076     return raw_type;
9077
9078   if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
9079     {
9080       /* This is an older encoding form where the base type needs to be
9081          looked up by name.  We prefer the newer encoding because it is
9082          more efficient.  */
9083       raw_real_type = ada_find_any_type (real_type_namer->field (0).name ());
9084       if (raw_real_type == NULL)
9085         return raw_type;
9086       else
9087         return raw_real_type;
9088     }
9089
9090   /* The field in our XVS type is a reference to the base type.  */
9091   return TYPE_TARGET_TYPE (real_type_namer->field (0).type ());
9092 }
9093
9094 /* The type of value designated by TYPE, with all aligners removed.  */
9095
9096 struct type *
9097 ada_aligned_type (struct type *type)
9098 {
9099   if (ada_is_aligner_type (type))
9100     return ada_aligned_type (type->field (0).type ());
9101   else
9102     return ada_get_base_type (type);
9103 }
9104
9105
9106 /* The address of the aligned value in an object at address VALADDR
9107    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
9108
9109 const gdb_byte *
9110 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9111 {
9112   if (ada_is_aligner_type (type))
9113     return ada_aligned_value_addr
9114       (type->field (0).type (),
9115        valaddr + type->field (0).loc_bitpos () / TARGET_CHAR_BIT);
9116   else
9117     return valaddr;
9118 }
9119
9120
9121
9122 /* The printed representation of an enumeration literal with encoded
9123    name NAME.  The value is good to the next call of ada_enum_name.  */
9124 const char *
9125 ada_enum_name (const char *name)
9126 {
9127   static std::string storage;
9128   const char *tmp;
9129
9130   /* First, unqualify the enumeration name:
9131      1. Search for the last '.' character.  If we find one, then skip
9132      all the preceding characters, the unqualified name starts
9133      right after that dot.
9134      2. Otherwise, we may be debugging on a target where the compiler
9135      translates dots into "__".  Search forward for double underscores,
9136      but stop searching when we hit an overloading suffix, which is
9137      of the form "__" followed by digits.  */
9138
9139   tmp = strrchr (name, '.');
9140   if (tmp != NULL)
9141     name = tmp + 1;
9142   else
9143     {
9144       while ((tmp = strstr (name, "__")) != NULL)
9145         {
9146           if (isdigit (tmp[2]))
9147             break;
9148           else
9149             name = tmp + 2;
9150         }
9151     }
9152
9153   if (name[0] == 'Q')
9154     {
9155       int v;
9156
9157       if (name[1] == 'U' || name[1] == 'W')
9158         {
9159           int offset = 2;
9160           if (name[1] == 'W' && name[2] == 'W')
9161             {
9162               /* Also handle the QWW case.  */
9163               ++offset;
9164             }
9165           if (sscanf (name + offset, "%x", &v) != 1)
9166             return name;
9167         }
9168       else if (((name[1] >= '0' && name[1] <= '9')
9169                 || (name[1] >= 'a' && name[1] <= 'z'))
9170                && name[2] == '\0')
9171         {
9172           storage = string_printf ("'%c'", name[1]);
9173           return storage.c_str ();
9174         }
9175       else
9176         return name;
9177
9178       if (isascii (v) && isprint (v))
9179         storage = string_printf ("'%c'", v);
9180       else if (name[1] == 'U')
9181         storage = string_printf ("'[\"%02x\"]'", v);
9182       else if (name[2] != 'W')
9183         storage = string_printf ("'[\"%04x\"]'", v);
9184       else
9185         storage = string_printf ("'[\"%06x\"]'", v);
9186
9187       return storage.c_str ();
9188     }
9189   else
9190     {
9191       tmp = strstr (name, "__");
9192       if (tmp == NULL)
9193         tmp = strstr (name, "$");
9194       if (tmp != NULL)
9195         {
9196           storage = std::string (name, tmp - name);
9197           return storage.c_str ();
9198         }
9199
9200       return name;
9201     }
9202 }
9203
9204 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9205    value it wraps.  */
9206
9207 static struct value *
9208 unwrap_value (struct value *val)
9209 {
9210   struct type *type = ada_check_typedef (value_type (val));
9211
9212   if (ada_is_aligner_type (type))
9213     {
9214       struct value *v = ada_value_struct_elt (val, "F", 0);
9215       struct type *val_type = ada_check_typedef (value_type (v));
9216
9217       if (ada_type_name (val_type) == NULL)
9218         val_type->set_name (ada_type_name (type));
9219
9220       return unwrap_value (v);
9221     }
9222   else
9223     {
9224       struct type *raw_real_type =
9225         ada_check_typedef (ada_get_base_type (type));
9226
9227       /* If there is no parallel XVS or XVE type, then the value is
9228          already unwrapped.  Return it without further modification.  */
9229       if ((type == raw_real_type)
9230           && ada_find_parallel_type (type, "___XVE") == NULL)
9231         return val;
9232
9233       return
9234         coerce_unspec_val_to_type
9235         (val, ada_to_fixed_type (raw_real_type, 0,
9236                                  value_address (val),
9237                                  NULL, 1));
9238     }
9239 }
9240
9241 /* Given two array types T1 and T2, return nonzero iff both arrays
9242    contain the same number of elements.  */
9243
9244 static int
9245 ada_same_array_size_p (struct type *t1, struct type *t2)
9246 {
9247   LONGEST lo1, hi1, lo2, hi2;
9248
9249   /* Get the array bounds in order to verify that the size of
9250      the two arrays match.  */
9251   if (!get_array_bounds (t1, &lo1, &hi1)
9252       || !get_array_bounds (t2, &lo2, &hi2))
9253     error (_("unable to determine array bounds"));
9254
9255   /* To make things easier for size comparison, normalize a bit
9256      the case of empty arrays by making sure that the difference
9257      between upper bound and lower bound is always -1.  */
9258   if (lo1 > hi1)
9259     hi1 = lo1 - 1;
9260   if (lo2 > hi2)
9261     hi2 = lo2 - 1;
9262
9263   return (hi1 - lo1 == hi2 - lo2);
9264 }
9265
9266 /* Assuming that VAL is an array of integrals, and TYPE represents
9267    an array with the same number of elements, but with wider integral
9268    elements, return an array "casted" to TYPE.  In practice, this
9269    means that the returned array is built by casting each element
9270    of the original array into TYPE's (wider) element type.  */
9271
9272 static struct value *
9273 ada_promote_array_of_integrals (struct type *type, struct value *val)
9274 {
9275   struct type *elt_type = TYPE_TARGET_TYPE (type);
9276   LONGEST lo, hi;
9277   LONGEST i;
9278
9279   /* Verify that both val and type are arrays of scalars, and
9280      that the size of val's elements is smaller than the size
9281      of type's element.  */
9282   gdb_assert (type->code () == TYPE_CODE_ARRAY);
9283   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9284   gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
9285   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9286   gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9287               > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9288
9289   if (!get_array_bounds (type, &lo, &hi))
9290     error (_("unable to determine array bounds"));
9291
9292   value *res = allocate_value (type);
9293   gdb::array_view<gdb_byte> res_contents = value_contents_writeable (res);
9294
9295   /* Promote each array element.  */
9296   for (i = 0; i < hi - lo + 1; i++)
9297     {
9298       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9299       int elt_len = TYPE_LENGTH (elt_type);
9300
9301       copy (value_contents_all (elt), res_contents.slice (elt_len * i, elt_len));
9302     }
9303
9304   return res;
9305 }
9306
9307 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9308    return the converted value.  */
9309
9310 static struct value *
9311 coerce_for_assign (struct type *type, struct value *val)
9312 {
9313   struct type *type2 = value_type (val);
9314
9315   if (type == type2)
9316     return val;
9317
9318   type2 = ada_check_typedef (type2);
9319   type = ada_check_typedef (type);
9320
9321   if (type2->code () == TYPE_CODE_PTR
9322       && type->code () == TYPE_CODE_ARRAY)
9323     {
9324       val = ada_value_ind (val);
9325       type2 = value_type (val);
9326     }
9327
9328   if (type2->code () == TYPE_CODE_ARRAY
9329       && type->code () == TYPE_CODE_ARRAY)
9330     {
9331       if (!ada_same_array_size_p (type, type2))
9332         error (_("cannot assign arrays of different length"));
9333
9334       if (is_integral_type (TYPE_TARGET_TYPE (type))
9335           && is_integral_type (TYPE_TARGET_TYPE (type2))
9336           && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9337                < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9338         {
9339           /* Allow implicit promotion of the array elements to
9340              a wider type.  */
9341           return ada_promote_array_of_integrals (type, val);
9342         }
9343
9344       if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9345           != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9346         error (_("Incompatible types in assignment"));
9347       deprecated_set_value_type (val, type);
9348     }
9349   return val;
9350 }
9351
9352 static struct value *
9353 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9354 {
9355   struct value *val;
9356   struct type *type1, *type2;
9357   LONGEST v, v1, v2;
9358
9359   arg1 = coerce_ref (arg1);
9360   arg2 = coerce_ref (arg2);
9361   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9362   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9363
9364   if (type1->code () != TYPE_CODE_INT
9365       || type2->code () != TYPE_CODE_INT)
9366     return value_binop (arg1, arg2, op);
9367
9368   switch (op)
9369     {
9370     case BINOP_MOD:
9371     case BINOP_DIV:
9372     case BINOP_REM:
9373       break;
9374     default:
9375       return value_binop (arg1, arg2, op);
9376     }
9377
9378   v2 = value_as_long (arg2);
9379   if (v2 == 0)
9380     {
9381       const char *name;
9382       if (op == BINOP_MOD)
9383         name = "mod";
9384       else if (op == BINOP_DIV)
9385         name = "/";
9386       else
9387         {
9388           gdb_assert (op == BINOP_REM);
9389           name = "rem";
9390         }
9391
9392       error (_("second operand of %s must not be zero."), name);
9393     }
9394
9395   if (type1->is_unsigned () || op == BINOP_MOD)
9396     return value_binop (arg1, arg2, op);
9397
9398   v1 = value_as_long (arg1);
9399   switch (op)
9400     {
9401     case BINOP_DIV:
9402       v = v1 / v2;
9403       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9404         v += v > 0 ? -1 : 1;
9405       break;
9406     case BINOP_REM:
9407       v = v1 % v2;
9408       if (v * v1 < 0)
9409         v -= v2;
9410       break;
9411     default:
9412       /* Should not reach this point.  */
9413       v = 0;
9414     }
9415
9416   val = allocate_value (type1);
9417   store_unsigned_integer (value_contents_raw (val).data (),
9418                           TYPE_LENGTH (value_type (val)),
9419                           type_byte_order (type1), v);
9420   return val;
9421 }
9422
9423 static int
9424 ada_value_equal (struct value *arg1, struct value *arg2)
9425 {
9426   if (ada_is_direct_array_type (value_type (arg1))
9427       || ada_is_direct_array_type (value_type (arg2)))
9428     {
9429       struct type *arg1_type, *arg2_type;
9430
9431       /* Automatically dereference any array reference before
9432          we attempt to perform the comparison.  */
9433       arg1 = ada_coerce_ref (arg1);
9434       arg2 = ada_coerce_ref (arg2);
9435
9436       arg1 = ada_coerce_to_simple_array (arg1);
9437       arg2 = ada_coerce_to_simple_array (arg2);
9438
9439       arg1_type = ada_check_typedef (value_type (arg1));
9440       arg2_type = ada_check_typedef (value_type (arg2));
9441
9442       if (arg1_type->code () != TYPE_CODE_ARRAY
9443           || arg2_type->code () != TYPE_CODE_ARRAY)
9444         error (_("Attempt to compare array with non-array"));
9445       /* FIXME: The following works only for types whose
9446          representations use all bits (no padding or undefined bits)
9447          and do not have user-defined equality.  */
9448       return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9449               && memcmp (value_contents (arg1).data (),
9450                          value_contents (arg2).data (),
9451                          TYPE_LENGTH (arg1_type)) == 0);
9452     }
9453   return value_equal (arg1, arg2);
9454 }
9455
9456 namespace expr
9457 {
9458
9459 bool
9460 check_objfile (const std::unique_ptr<ada_component> &comp,
9461                struct objfile *objfile)
9462 {
9463   return comp->uses_objfile (objfile);
9464 }
9465
9466 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9467    component of LHS (a simple array or a record).  Does not modify the
9468    inferior's memory, nor does it modify LHS (unless LHS ==
9469    CONTAINER).  */
9470
9471 static void
9472 assign_component (struct value *container, struct value *lhs, LONGEST index,
9473                   struct expression *exp, operation_up &arg)
9474 {
9475   scoped_value_mark mark;
9476
9477   struct value *elt;
9478   struct type *lhs_type = check_typedef (value_type (lhs));
9479
9480   if (lhs_type->code () == TYPE_CODE_ARRAY)
9481     {
9482       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9483       struct value *index_val = value_from_longest (index_type, index);
9484
9485       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9486     }
9487   else
9488     {
9489       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9490       elt = ada_to_fixed_value (elt);
9491     }
9492
9493   ada_aggregate_operation *ag_op
9494     = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9495   if (ag_op != nullptr)
9496     ag_op->assign_aggregate (container, elt, exp);
9497   else
9498     value_assign_to_component (container, elt,
9499                                arg->evaluate (nullptr, exp,
9500                                               EVAL_NORMAL));
9501 }
9502
9503 bool
9504 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9505 {
9506   for (const auto &item : m_components)
9507     if (item->uses_objfile (objfile))
9508       return true;
9509   return false;
9510 }
9511
9512 void
9513 ada_aggregate_component::dump (ui_file *stream, int depth)
9514 {
9515   gdb_printf (stream, _("%*sAggregate\n"), depth, "");
9516   for (const auto &item : m_components)
9517     item->dump (stream, depth + 1);
9518 }
9519
9520 void
9521 ada_aggregate_component::assign (struct value *container,
9522                                  struct value *lhs, struct expression *exp,
9523                                  std::vector<LONGEST> &indices,
9524                                  LONGEST low, LONGEST high)
9525 {
9526   for (auto &item : m_components)
9527     item->assign (container, lhs, exp, indices, low, high);
9528 }
9529
9530 /* See ada-exp.h.  */
9531
9532 value *
9533 ada_aggregate_operation::assign_aggregate (struct value *container,
9534                                            struct value *lhs,
9535                                            struct expression *exp)
9536 {
9537   struct type *lhs_type;
9538   LONGEST low_index, high_index;
9539
9540   container = ada_coerce_ref (container);
9541   if (ada_is_direct_array_type (value_type (container)))
9542     container = ada_coerce_to_simple_array (container);
9543   lhs = ada_coerce_ref (lhs);
9544   if (!deprecated_value_modifiable (lhs))
9545     error (_("Left operand of assignment is not a modifiable lvalue."));
9546
9547   lhs_type = check_typedef (value_type (lhs));
9548   if (ada_is_direct_array_type (lhs_type))
9549     {
9550       lhs = ada_coerce_to_simple_array (lhs);
9551       lhs_type = check_typedef (value_type (lhs));
9552       low_index = lhs_type->bounds ()->low.const_val ();
9553       high_index = lhs_type->bounds ()->high.const_val ();
9554     }
9555   else if (lhs_type->code () == TYPE_CODE_STRUCT)
9556     {
9557       low_index = 0;
9558       high_index = num_visible_fields (lhs_type) - 1;
9559     }
9560   else
9561     error (_("Left-hand side must be array or record."));
9562
9563   std::vector<LONGEST> indices (4);
9564   indices[0] = indices[1] = low_index - 1;
9565   indices[2] = indices[3] = high_index + 1;
9566
9567   std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9568                                    low_index, high_index);
9569
9570   return container;
9571 }
9572
9573 bool
9574 ada_positional_component::uses_objfile (struct objfile *objfile)
9575 {
9576   return m_op->uses_objfile (objfile);
9577 }
9578
9579 void
9580 ada_positional_component::dump (ui_file *stream, int depth)
9581 {
9582   gdb_printf (stream, _("%*sPositional, index = %d\n"),
9583               depth, "", m_index);
9584   m_op->dump (stream, depth + 1);
9585 }
9586
9587 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9588    construct, given that the positions are relative to lower bound
9589    LOW, where HIGH is the upper bound.  Record the position in
9590    INDICES.  CONTAINER is as for assign_aggregate.  */
9591 void
9592 ada_positional_component::assign (struct value *container,
9593                                   struct value *lhs, struct expression *exp,
9594                                   std::vector<LONGEST> &indices,
9595                                   LONGEST low, LONGEST high)
9596 {
9597   LONGEST ind = m_index + low;
9598
9599   if (ind - 1 == high)
9600     warning (_("Extra components in aggregate ignored."));
9601   if (ind <= high)
9602     {
9603       add_component_interval (ind, ind, indices);
9604       assign_component (container, lhs, ind, exp, m_op);
9605     }
9606 }
9607
9608 bool
9609 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9610 {
9611   return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9612 }
9613
9614 void
9615 ada_discrete_range_association::dump (ui_file *stream, int depth)
9616 {
9617   gdb_printf (stream, _("%*sDiscrete range:\n"), depth, "");
9618   m_low->dump (stream, depth + 1);
9619   m_high->dump (stream, depth + 1);
9620 }
9621
9622 void
9623 ada_discrete_range_association::assign (struct value *container,
9624                                         struct value *lhs,
9625                                         struct expression *exp,
9626                                         std::vector<LONGEST> &indices,
9627                                         LONGEST low, LONGEST high,
9628                                         operation_up &op)
9629 {
9630   LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9631   LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9632
9633   if (lower <= upper && (lower < low || upper > high))
9634     error (_("Index in component association out of bounds."));
9635
9636   add_component_interval (lower, upper, indices);
9637   while (lower <= upper)
9638     {
9639       assign_component (container, lhs, lower, exp, op);
9640       lower += 1;
9641     }
9642 }
9643
9644 bool
9645 ada_name_association::uses_objfile (struct objfile *objfile)
9646 {
9647   return m_val->uses_objfile (objfile);
9648 }
9649
9650 void
9651 ada_name_association::dump (ui_file *stream, int depth)
9652 {
9653   gdb_printf (stream, _("%*sName:\n"), depth, "");
9654   m_val->dump (stream, depth + 1);
9655 }
9656
9657 void
9658 ada_name_association::assign (struct value *container,
9659                               struct value *lhs,
9660                               struct expression *exp,
9661                               std::vector<LONGEST> &indices,
9662                               LONGEST low, LONGEST high,
9663                               operation_up &op)
9664 {
9665   int index;
9666
9667   if (ada_is_direct_array_type (value_type (lhs)))
9668     index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9669                                                             EVAL_NORMAL)));
9670   else
9671     {
9672       ada_string_operation *strop
9673         = dynamic_cast<ada_string_operation *> (m_val.get ());
9674
9675       const char *name;
9676       if (strop != nullptr)
9677         name = strop->get_name ();
9678       else
9679         {
9680           ada_var_value_operation *vvo
9681             = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9682           if (vvo != nullptr)
9683             error (_("Invalid record component association."));
9684           name = vvo->get_symbol ()->natural_name ();
9685         }
9686
9687       index = 0;
9688       if (! find_struct_field (name, value_type (lhs), 0,
9689                                NULL, NULL, NULL, NULL, &index))
9690         error (_("Unknown component name: %s."), name);
9691     }
9692
9693   add_component_interval (index, index, indices);
9694   assign_component (container, lhs, index, exp, op);
9695 }
9696
9697 bool
9698 ada_choices_component::uses_objfile (struct objfile *objfile)
9699 {
9700   if (m_op->uses_objfile (objfile))
9701     return true;
9702   for (const auto &item : m_assocs)
9703     if (item->uses_objfile (objfile))
9704       return true;
9705   return false;
9706 }
9707
9708 void
9709 ada_choices_component::dump (ui_file *stream, int depth)
9710 {
9711   gdb_printf (stream, _("%*sChoices:\n"), depth, "");
9712   m_op->dump (stream, depth + 1);
9713   for (const auto &item : m_assocs)
9714     item->dump (stream, depth + 1);
9715 }
9716
9717 /* Assign into the components of LHS indexed by the OP_CHOICES
9718    construct at *POS, updating *POS past the construct, given that
9719    the allowable indices are LOW..HIGH.  Record the indices assigned
9720    to in INDICES.  CONTAINER is as for assign_aggregate.  */
9721 void
9722 ada_choices_component::assign (struct value *container,
9723                                struct value *lhs, struct expression *exp,
9724                                std::vector<LONGEST> &indices,
9725                                LONGEST low, LONGEST high)
9726 {
9727   for (auto &item : m_assocs)
9728     item->assign (container, lhs, exp, indices, low, high, m_op);
9729 }
9730
9731 bool
9732 ada_others_component::uses_objfile (struct objfile *objfile)
9733 {
9734   return m_op->uses_objfile (objfile);
9735 }
9736
9737 void
9738 ada_others_component::dump (ui_file *stream, int depth)
9739 {
9740   gdb_printf (stream, _("%*sOthers:\n"), depth, "");
9741   m_op->dump (stream, depth + 1);
9742 }
9743
9744 /* Assign the value of the expression in the OP_OTHERS construct in
9745    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9746    have not been previously assigned.  The index intervals already assigned
9747    are in INDICES.  CONTAINER is as for assign_aggregate.  */
9748 void
9749 ada_others_component::assign (struct value *container,
9750                               struct value *lhs, struct expression *exp,
9751                               std::vector<LONGEST> &indices,
9752                               LONGEST low, LONGEST high)
9753 {
9754   int num_indices = indices.size ();
9755   for (int i = 0; i < num_indices - 2; i += 2)
9756     {
9757       for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9758         assign_component (container, lhs, ind, exp, m_op);
9759     }
9760 }
9761
9762 struct value *
9763 ada_assign_operation::evaluate (struct type *expect_type,
9764                                 struct expression *exp,
9765                                 enum noside noside)
9766 {
9767   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9768
9769   ada_aggregate_operation *ag_op
9770     = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9771   if (ag_op != nullptr)
9772     {
9773       if (noside != EVAL_NORMAL)
9774         return arg1;
9775
9776       arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9777       return ada_value_assign (arg1, arg1);
9778     }
9779   /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9780      except if the lhs of our assignment is a convenience variable.
9781      In the case of assigning to a convenience variable, the lhs
9782      should be exactly the result of the evaluation of the rhs.  */
9783   struct type *type = value_type (arg1);
9784   if (VALUE_LVAL (arg1) == lval_internalvar)
9785     type = NULL;
9786   value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9787   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9788     return arg1;
9789   if (VALUE_LVAL (arg1) == lval_internalvar)
9790     {
9791       /* Nothing.  */
9792     }
9793   else
9794     arg2 = coerce_for_assign (value_type (arg1), arg2);
9795   return ada_value_assign (arg1, arg2);
9796 }
9797
9798 } /* namespace expr */
9799
9800 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9801    [ INDICES[0] .. INDICES[1] ],...  The resulting intervals do not
9802    overlap.  */
9803 static void
9804 add_component_interval (LONGEST low, LONGEST high, 
9805                         std::vector<LONGEST> &indices)
9806 {
9807   int i, j;
9808
9809   int size = indices.size ();
9810   for (i = 0; i < size; i += 2) {
9811     if (high >= indices[i] && low <= indices[i + 1])
9812       {
9813         int kh;
9814
9815         for (kh = i + 2; kh < size; kh += 2)
9816           if (high < indices[kh])
9817             break;
9818         if (low < indices[i])
9819           indices[i] = low;
9820         indices[i + 1] = indices[kh - 1];
9821         if (high > indices[i + 1])
9822           indices[i + 1] = high;
9823         memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9824         indices.resize (kh - i - 2);
9825         return;
9826       }
9827     else if (high < indices[i])
9828       break;
9829   }
9830         
9831   indices.resize (indices.size () + 2);
9832   for (j = indices.size () - 1; j >= i + 2; j -= 1)
9833     indices[j] = indices[j - 2];
9834   indices[i] = low;
9835   indices[i + 1] = high;
9836 }
9837
9838 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9839    is different.  */
9840
9841 static struct value *
9842 ada_value_cast (struct type *type, struct value *arg2)
9843 {
9844   if (type == ada_check_typedef (value_type (arg2)))
9845     return arg2;
9846
9847   return value_cast (type, arg2);
9848 }
9849
9850 /*  Evaluating Ada expressions, and printing their result.
9851     ------------------------------------------------------
9852
9853     1. Introduction:
9854     ----------------
9855
9856     We usually evaluate an Ada expression in order to print its value.
9857     We also evaluate an expression in order to print its type, which
9858     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9859     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
9860     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9861     the evaluation compared to the EVAL_NORMAL, but is otherwise very
9862     similar.
9863
9864     Evaluating expressions is a little more complicated for Ada entities
9865     than it is for entities in languages such as C.  The main reason for
9866     this is that Ada provides types whose definition might be dynamic.
9867     One example of such types is variant records.  Or another example
9868     would be an array whose bounds can only be known at run time.
9869
9870     The following description is a general guide as to what should be
9871     done (and what should NOT be done) in order to evaluate an expression
9872     involving such types, and when.  This does not cover how the semantic
9873     information is encoded by GNAT as this is covered separatly.  For the
9874     document used as the reference for the GNAT encoding, see exp_dbug.ads
9875     in the GNAT sources.
9876
9877     Ideally, we should embed each part of this description next to its
9878     associated code.  Unfortunately, the amount of code is so vast right
9879     now that it's hard to see whether the code handling a particular
9880     situation might be duplicated or not.  One day, when the code is
9881     cleaned up, this guide might become redundant with the comments
9882     inserted in the code, and we might want to remove it.
9883
9884     2. ``Fixing'' an Entity, the Simple Case:
9885     -----------------------------------------
9886
9887     When evaluating Ada expressions, the tricky issue is that they may
9888     reference entities whose type contents and size are not statically
9889     known.  Consider for instance a variant record:
9890
9891        type Rec (Empty : Boolean := True) is record
9892           case Empty is
9893              when True => null;
9894              when False => Value : Integer;
9895           end case;
9896        end record;
9897        Yes : Rec := (Empty => False, Value => 1);
9898        No  : Rec := (empty => True);
9899
9900     The size and contents of that record depends on the value of the
9901     descriminant (Rec.Empty).  At this point, neither the debugging
9902     information nor the associated type structure in GDB are able to
9903     express such dynamic types.  So what the debugger does is to create
9904     "fixed" versions of the type that applies to the specific object.
9905     We also informally refer to this operation as "fixing" an object,
9906     which means creating its associated fixed type.
9907
9908     Example: when printing the value of variable "Yes" above, its fixed
9909     type would look like this:
9910
9911        type Rec is record
9912           Empty : Boolean;
9913           Value : Integer;
9914        end record;
9915
9916     On the other hand, if we printed the value of "No", its fixed type
9917     would become:
9918
9919        type Rec is record
9920           Empty : Boolean;
9921        end record;
9922
9923     Things become a little more complicated when trying to fix an entity
9924     with a dynamic type that directly contains another dynamic type,
9925     such as an array of variant records, for instance.  There are
9926     two possible cases: Arrays, and records.
9927
9928     3. ``Fixing'' Arrays:
9929     ---------------------
9930
9931     The type structure in GDB describes an array in terms of its bounds,
9932     and the type of its elements.  By design, all elements in the array
9933     have the same type and we cannot represent an array of variant elements
9934     using the current type structure in GDB.  When fixing an array,
9935     we cannot fix the array element, as we would potentially need one
9936     fixed type per element of the array.  As a result, the best we can do
9937     when fixing an array is to produce an array whose bounds and size
9938     are correct (allowing us to read it from memory), but without having
9939     touched its element type.  Fixing each element will be done later,
9940     when (if) necessary.
9941
9942     Arrays are a little simpler to handle than records, because the same
9943     amount of memory is allocated for each element of the array, even if
9944     the amount of space actually used by each element differs from element
9945     to element.  Consider for instance the following array of type Rec:
9946
9947        type Rec_Array is array (1 .. 2) of Rec;
9948
9949     The actual amount of memory occupied by each element might be different
9950     from element to element, depending on the value of their discriminant.
9951     But the amount of space reserved for each element in the array remains
9952     fixed regardless.  So we simply need to compute that size using
9953     the debugging information available, from which we can then determine
9954     the array size (we multiply the number of elements of the array by
9955     the size of each element).
9956
9957     The simplest case is when we have an array of a constrained element
9958     type. For instance, consider the following type declarations:
9959
9960         type Bounded_String (Max_Size : Integer) is
9961            Length : Integer;
9962            Buffer : String (1 .. Max_Size);
9963         end record;
9964         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9965
9966     In this case, the compiler describes the array as an array of
9967     variable-size elements (identified by its XVS suffix) for which
9968     the size can be read in the parallel XVZ variable.
9969
9970     In the case of an array of an unconstrained element type, the compiler
9971     wraps the array element inside a private PAD type.  This type should not
9972     be shown to the user, and must be "unwrap"'ed before printing.  Note
9973     that we also use the adjective "aligner" in our code to designate
9974     these wrapper types.
9975
9976     In some cases, the size allocated for each element is statically
9977     known.  In that case, the PAD type already has the correct size,
9978     and the array element should remain unfixed.
9979
9980     But there are cases when this size is not statically known.
9981     For instance, assuming that "Five" is an integer variable:
9982
9983         type Dynamic is array (1 .. Five) of Integer;
9984         type Wrapper (Has_Length : Boolean := False) is record
9985            Data : Dynamic;
9986            case Has_Length is
9987               when True => Length : Integer;
9988               when False => null;
9989            end case;
9990         end record;
9991         type Wrapper_Array is array (1 .. 2) of Wrapper;
9992
9993         Hello : Wrapper_Array := (others => (Has_Length => True,
9994                                              Data => (others => 17),
9995                                              Length => 1));
9996
9997
9998     The debugging info would describe variable Hello as being an
9999     array of a PAD type.  The size of that PAD type is not statically
10000     known, but can be determined using a parallel XVZ variable.
10001     In that case, a copy of the PAD type with the correct size should
10002     be used for the fixed array.
10003
10004     3. ``Fixing'' record type objects:
10005     ----------------------------------
10006
10007     Things are slightly different from arrays in the case of dynamic
10008     record types.  In this case, in order to compute the associated
10009     fixed type, we need to determine the size and offset of each of
10010     its components.  This, in turn, requires us to compute the fixed
10011     type of each of these components.
10012
10013     Consider for instance the example:
10014
10015         type Bounded_String (Max_Size : Natural) is record
10016            Str : String (1 .. Max_Size);
10017            Length : Natural;
10018         end record;
10019         My_String : Bounded_String (Max_Size => 10);
10020
10021     In that case, the position of field "Length" depends on the size
10022     of field Str, which itself depends on the value of the Max_Size
10023     discriminant.  In order to fix the type of variable My_String,
10024     we need to fix the type of field Str.  Therefore, fixing a variant
10025     record requires us to fix each of its components.
10026
10027     However, if a component does not have a dynamic size, the component
10028     should not be fixed.  In particular, fields that use a PAD type
10029     should not fixed.  Here is an example where this might happen
10030     (assuming type Rec above):
10031
10032        type Container (Big : Boolean) is record
10033           First : Rec;
10034           After : Integer;
10035           case Big is
10036              when True => Another : Integer;
10037              when False => null;
10038           end case;
10039        end record;
10040        My_Container : Container := (Big => False,
10041                                     First => (Empty => True),
10042                                     After => 42);
10043
10044     In that example, the compiler creates a PAD type for component First,
10045     whose size is constant, and then positions the component After just
10046     right after it.  The offset of component After is therefore constant
10047     in this case.
10048
10049     The debugger computes the position of each field based on an algorithm
10050     that uses, among other things, the actual position and size of the field
10051     preceding it.  Let's now imagine that the user is trying to print
10052     the value of My_Container.  If the type fixing was recursive, we would
10053     end up computing the offset of field After based on the size of the
10054     fixed version of field First.  And since in our example First has
10055     only one actual field, the size of the fixed type is actually smaller
10056     than the amount of space allocated to that field, and thus we would
10057     compute the wrong offset of field After.
10058
10059     To make things more complicated, we need to watch out for dynamic
10060     components of variant records (identified by the ___XVL suffix in
10061     the component name).  Even if the target type is a PAD type, the size
10062     of that type might not be statically known.  So the PAD type needs
10063     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
10064     we might end up with the wrong size for our component.  This can be
10065     observed with the following type declarations:
10066
10067         type Octal is new Integer range 0 .. 7;
10068         type Octal_Array is array (Positive range <>) of Octal;
10069         pragma Pack (Octal_Array);
10070
10071         type Octal_Buffer (Size : Positive) is record
10072            Buffer : Octal_Array (1 .. Size);
10073            Length : Integer;
10074         end record;
10075
10076     In that case, Buffer is a PAD type whose size is unset and needs
10077     to be computed by fixing the unwrapped type.
10078
10079     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10080     ----------------------------------------------------------
10081
10082     Lastly, when should the sub-elements of an entity that remained unfixed
10083     thus far, be actually fixed?
10084
10085     The answer is: Only when referencing that element.  For instance
10086     when selecting one component of a record, this specific component
10087     should be fixed at that point in time.  Or when printing the value
10088     of a record, each component should be fixed before its value gets
10089     printed.  Similarly for arrays, the element of the array should be
10090     fixed when printing each element of the array, or when extracting
10091     one element out of that array.  On the other hand, fixing should
10092     not be performed on the elements when taking a slice of an array!
10093
10094     Note that one of the side effects of miscomputing the offset and
10095     size of each field is that we end up also miscomputing the size
10096     of the containing type.  This can have adverse results when computing
10097     the value of an entity.  GDB fetches the value of an entity based
10098     on the size of its type, and thus a wrong size causes GDB to fetch
10099     the wrong amount of memory.  In the case where the computed size is
10100     too small, GDB fetches too little data to print the value of our
10101     entity.  Results in this case are unpredictable, as we usually read
10102     past the buffer containing the data =:-o.  */
10103
10104 /* A helper function for TERNOP_IN_RANGE.  */
10105
10106 static value *
10107 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
10108                       enum noside noside,
10109                       value *arg1, value *arg2, value *arg3)
10110 {
10111   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10112   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10113   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10114   return
10115     value_from_longest (type,
10116                         (value_less (arg1, arg3)
10117                          || value_equal (arg1, arg3))
10118                         && (value_less (arg2, arg1)
10119                             || value_equal (arg2, arg1)));
10120 }
10121
10122 /* A helper function for UNOP_NEG.  */
10123
10124 value *
10125 ada_unop_neg (struct type *expect_type,
10126               struct expression *exp,
10127               enum noside noside, enum exp_opcode op,
10128               struct value *arg1)
10129 {
10130   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10131   return value_neg (arg1);
10132 }
10133
10134 /* A helper function for UNOP_IN_RANGE.  */
10135
10136 value *
10137 ada_unop_in_range (struct type *expect_type,
10138                    struct expression *exp,
10139                    enum noside noside, enum exp_opcode op,
10140                    struct value *arg1, struct type *type)
10141 {
10142   struct value *arg2, *arg3;
10143   switch (type->code ())
10144     {
10145     default:
10146       lim_warning (_("Membership test incompletely implemented; "
10147                      "always returns true"));
10148       type = language_bool_type (exp->language_defn, exp->gdbarch);
10149       return value_from_longest (type, (LONGEST) 1);
10150
10151     case TYPE_CODE_RANGE:
10152       arg2 = value_from_longest (type,
10153                                  type->bounds ()->low.const_val ());
10154       arg3 = value_from_longest (type,
10155                                  type->bounds ()->high.const_val ());
10156       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10157       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10158       type = language_bool_type (exp->language_defn, exp->gdbarch);
10159       return
10160         value_from_longest (type,
10161                             (value_less (arg1, arg3)
10162                              || value_equal (arg1, arg3))
10163                             && (value_less (arg2, arg1)
10164                                 || value_equal (arg2, arg1)));
10165     }
10166 }
10167
10168 /* A helper function for OP_ATR_TAG.  */
10169
10170 value *
10171 ada_atr_tag (struct type *expect_type,
10172              struct expression *exp,
10173              enum noside noside, enum exp_opcode op,
10174              struct value *arg1)
10175 {
10176   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10177     return value_zero (ada_tag_type (arg1), not_lval);
10178
10179   return ada_value_tag (arg1);
10180 }
10181
10182 /* A helper function for OP_ATR_SIZE.  */
10183
10184 value *
10185 ada_atr_size (struct type *expect_type,
10186               struct expression *exp,
10187               enum noside noside, enum exp_opcode op,
10188               struct value *arg1)
10189 {
10190   struct type *type = value_type (arg1);
10191
10192   /* If the argument is a reference, then dereference its type, since
10193      the user is really asking for the size of the actual object,
10194      not the size of the pointer.  */
10195   if (type->code () == TYPE_CODE_REF)
10196     type = TYPE_TARGET_TYPE (type);
10197
10198   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10199     return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
10200   else
10201     return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
10202                                TARGET_CHAR_BIT * TYPE_LENGTH (type));
10203 }
10204
10205 /* A helper function for UNOP_ABS.  */
10206
10207 value *
10208 ada_abs (struct type *expect_type,
10209          struct expression *exp,
10210          enum noside noside, enum exp_opcode op,
10211          struct value *arg1)
10212 {
10213   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10214   if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
10215     return value_neg (arg1);
10216   else
10217     return arg1;
10218 }
10219
10220 /* A helper function for BINOP_MUL.  */
10221
10222 value *
10223 ada_mult_binop (struct type *expect_type,
10224                 struct expression *exp,
10225                 enum noside noside, enum exp_opcode op,
10226                 struct value *arg1, struct value *arg2)
10227 {
10228   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10229     {
10230       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10231       return value_zero (value_type (arg1), not_lval);
10232     }
10233   else
10234     {
10235       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10236       return ada_value_binop (arg1, arg2, op);
10237     }
10238 }
10239
10240 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL.  */
10241
10242 value *
10243 ada_equal_binop (struct type *expect_type,
10244                  struct expression *exp,
10245                  enum noside noside, enum exp_opcode op,
10246                  struct value *arg1, struct value *arg2)
10247 {
10248   int tem;
10249   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10250     tem = 0;
10251   else
10252     {
10253       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10254       tem = ada_value_equal (arg1, arg2);
10255     }
10256   if (op == BINOP_NOTEQUAL)
10257     tem = !tem;
10258   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
10259   return value_from_longest (type, (LONGEST) tem);
10260 }
10261
10262 /* A helper function for TERNOP_SLICE.  */
10263
10264 value *
10265 ada_ternop_slice (struct expression *exp,
10266                   enum noside noside,
10267                   struct value *array, struct value *low_bound_val,
10268                   struct value *high_bound_val)
10269 {
10270   LONGEST low_bound;
10271   LONGEST high_bound;
10272
10273   low_bound_val = coerce_ref (low_bound_val);
10274   high_bound_val = coerce_ref (high_bound_val);
10275   low_bound = value_as_long (low_bound_val);
10276   high_bound = value_as_long (high_bound_val);
10277
10278   /* If this is a reference to an aligner type, then remove all
10279      the aligners.  */
10280   if (value_type (array)->code () == TYPE_CODE_REF
10281       && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10282     value_type (array)->set_target_type
10283       (ada_aligned_type (TYPE_TARGET_TYPE (value_type (array))));
10284
10285   if (ada_is_any_packed_array_type (value_type (array)))
10286     error (_("cannot slice a packed array"));
10287
10288   /* If this is a reference to an array or an array lvalue,
10289      convert to a pointer.  */
10290   if (value_type (array)->code () == TYPE_CODE_REF
10291       || (value_type (array)->code () == TYPE_CODE_ARRAY
10292           && VALUE_LVAL (array) == lval_memory))
10293     array = value_addr (array);
10294
10295   if (noside == EVAL_AVOID_SIDE_EFFECTS
10296       && ada_is_array_descriptor_type (ada_check_typedef
10297                                        (value_type (array))))
10298     return empty_array (ada_type_of_array (array, 0), low_bound,
10299                         high_bound);
10300
10301   array = ada_coerce_to_simple_array_ptr (array);
10302
10303   /* If we have more than one level of pointer indirection,
10304      dereference the value until we get only one level.  */
10305   while (value_type (array)->code () == TYPE_CODE_PTR
10306          && (TYPE_TARGET_TYPE (value_type (array))->code ()
10307              == TYPE_CODE_PTR))
10308     array = value_ind (array);
10309
10310   /* Make sure we really do have an array type before going further,
10311      to avoid a SEGV when trying to get the index type or the target
10312      type later down the road if the debug info generated by
10313      the compiler is incorrect or incomplete.  */
10314   if (!ada_is_simple_array_type (value_type (array)))
10315     error (_("cannot take slice of non-array"));
10316
10317   if (ada_check_typedef (value_type (array))->code ()
10318       == TYPE_CODE_PTR)
10319     {
10320       struct type *type0 = ada_check_typedef (value_type (array));
10321
10322       if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10323         return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
10324       else
10325         {
10326           struct type *arr_type0 =
10327             to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
10328
10329           return ada_value_slice_from_ptr (array, arr_type0,
10330                                            longest_to_int (low_bound),
10331                                            longest_to_int (high_bound));
10332         }
10333     }
10334   else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10335     return array;
10336   else if (high_bound < low_bound)
10337     return empty_array (value_type (array), low_bound, high_bound);
10338   else
10339     return ada_value_slice (array, longest_to_int (low_bound),
10340                             longest_to_int (high_bound));
10341 }
10342
10343 /* A helper function for BINOP_IN_BOUNDS.  */
10344
10345 value *
10346 ada_binop_in_bounds (struct expression *exp, enum noside noside,
10347                      struct value *arg1, struct value *arg2, int n)
10348 {
10349   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10350     {
10351       struct type *type = language_bool_type (exp->language_defn,
10352                                               exp->gdbarch);
10353       return value_zero (type, not_lval);
10354     }
10355
10356   struct type *type = ada_index_type (value_type (arg2), n, "range");
10357   if (!type)
10358     type = value_type (arg1);
10359
10360   value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
10361   arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
10362
10363   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10364   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10365   type = language_bool_type (exp->language_defn, exp->gdbarch);
10366   return value_from_longest (type,
10367                              (value_less (arg1, arg3)
10368                               || value_equal (arg1, arg3))
10369                              && (value_less (arg2, arg1)
10370                                  || value_equal (arg2, arg1)));
10371 }
10372
10373 /* A helper function for some attribute operations.  */
10374
10375 static value *
10376 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
10377               struct value *arg1, struct type *type_arg, int tem)
10378 {
10379   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10380     {
10381       if (type_arg == NULL)
10382         type_arg = value_type (arg1);
10383
10384       if (ada_is_constrained_packed_array_type (type_arg))
10385         type_arg = decode_constrained_packed_array_type (type_arg);
10386
10387       if (!discrete_type_p (type_arg))
10388         {
10389           switch (op)
10390             {
10391             default:          /* Should never happen.  */
10392               error (_("unexpected attribute encountered"));
10393             case OP_ATR_FIRST:
10394             case OP_ATR_LAST:
10395               type_arg = ada_index_type (type_arg, tem,
10396                                          ada_attribute_name (op));
10397               break;
10398             case OP_ATR_LENGTH:
10399               type_arg = builtin_type (exp->gdbarch)->builtin_int;
10400               break;
10401             }
10402         }
10403
10404       return value_zero (type_arg, not_lval);
10405     }
10406   else if (type_arg == NULL)
10407     {
10408       arg1 = ada_coerce_ref (arg1);
10409
10410       if (ada_is_constrained_packed_array_type (value_type (arg1)))
10411         arg1 = ada_coerce_to_simple_array (arg1);
10412
10413       struct type *type;
10414       if (op == OP_ATR_LENGTH)
10415         type = builtin_type (exp->gdbarch)->builtin_int;
10416       else
10417         {
10418           type = ada_index_type (value_type (arg1), tem,
10419                                  ada_attribute_name (op));
10420           if (type == NULL)
10421             type = builtin_type (exp->gdbarch)->builtin_int;
10422         }
10423
10424       switch (op)
10425         {
10426         default:          /* Should never happen.  */
10427           error (_("unexpected attribute encountered"));
10428         case OP_ATR_FIRST:
10429           return value_from_longest
10430             (type, ada_array_bound (arg1, tem, 0));
10431         case OP_ATR_LAST:
10432           return value_from_longest
10433             (type, ada_array_bound (arg1, tem, 1));
10434         case OP_ATR_LENGTH:
10435           return value_from_longest
10436             (type, ada_array_length (arg1, tem));
10437         }
10438     }
10439   else if (discrete_type_p (type_arg))
10440     {
10441       struct type *range_type;
10442       const char *name = ada_type_name (type_arg);
10443
10444       range_type = NULL;
10445       if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10446         range_type = to_fixed_range_type (type_arg, NULL);
10447       if (range_type == NULL)
10448         range_type = type_arg;
10449       switch (op)
10450         {
10451         default:
10452           error (_("unexpected attribute encountered"));
10453         case OP_ATR_FIRST:
10454           return value_from_longest 
10455             (range_type, ada_discrete_type_low_bound (range_type));
10456         case OP_ATR_LAST:
10457           return value_from_longest
10458             (range_type, ada_discrete_type_high_bound (range_type));
10459         case OP_ATR_LENGTH:
10460           error (_("the 'length attribute applies only to array types"));
10461         }
10462     }
10463   else if (type_arg->code () == TYPE_CODE_FLT)
10464     error (_("unimplemented type attribute"));
10465   else
10466     {
10467       LONGEST low, high;
10468
10469       if (ada_is_constrained_packed_array_type (type_arg))
10470         type_arg = decode_constrained_packed_array_type (type_arg);
10471
10472       struct type *type;
10473       if (op == OP_ATR_LENGTH)
10474         type = builtin_type (exp->gdbarch)->builtin_int;
10475       else
10476         {
10477           type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10478           if (type == NULL)
10479             type = builtin_type (exp->gdbarch)->builtin_int;
10480         }
10481
10482       switch (op)
10483         {
10484         default:
10485           error (_("unexpected attribute encountered"));
10486         case OP_ATR_FIRST:
10487           low = ada_array_bound_from_type (type_arg, tem, 0);
10488           return value_from_longest (type, low);
10489         case OP_ATR_LAST:
10490           high = ada_array_bound_from_type (type_arg, tem, 1);
10491           return value_from_longest (type, high);
10492         case OP_ATR_LENGTH:
10493           low = ada_array_bound_from_type (type_arg, tem, 0);
10494           high = ada_array_bound_from_type (type_arg, tem, 1);
10495           return value_from_longest (type, high - low + 1);
10496         }
10497     }
10498 }
10499
10500 /* A helper function for OP_ATR_MIN and OP_ATR_MAX.  */
10501
10502 struct value *
10503 ada_binop_minmax (struct type *expect_type,
10504                   struct expression *exp,
10505                   enum noside noside, enum exp_opcode op,
10506                   struct value *arg1, struct value *arg2)
10507 {
10508   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10509     return value_zero (value_type (arg1), not_lval);
10510   else
10511     {
10512       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10513       return value_binop (arg1, arg2, op);
10514     }
10515 }
10516
10517 /* A helper function for BINOP_EXP.  */
10518
10519 struct value *
10520 ada_binop_exp (struct type *expect_type,
10521                struct expression *exp,
10522                enum noside noside, enum exp_opcode op,
10523                struct value *arg1, struct value *arg2)
10524 {
10525   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10526     return value_zero (value_type (arg1), not_lval);
10527   else
10528     {
10529       /* For integer exponentiation operations,
10530          only promote the first argument.  */
10531       if (is_integral_type (value_type (arg2)))
10532         unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10533       else
10534         binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10535
10536       return value_binop (arg1, arg2, op);
10537     }
10538 }
10539
10540 namespace expr
10541 {
10542
10543 /* See ada-exp.h.  */
10544
10545 operation_up
10546 ada_resolvable::replace (operation_up &&owner,
10547                          struct expression *exp,
10548                          bool deprocedure_p,
10549                          bool parse_completion,
10550                          innermost_block_tracker *tracker,
10551                          struct type *context_type)
10552 {
10553   if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10554     return (make_operation<ada_funcall_operation>
10555             (std::move (owner),
10556              std::vector<operation_up> ()));
10557   return std::move (owner);
10558 }
10559
10560 /* Convert the character literal whose value would be VAL to the
10561    appropriate value of type TYPE, if there is a translation.
10562    Otherwise return VAL.  Hence, in an enumeration type ('A', 'B'),
10563    the literal 'A' (VAL == 65), returns 0.  */
10564
10565 static LONGEST
10566 convert_char_literal (struct type *type, LONGEST val)
10567 {
10568   char name[12];
10569   int f;
10570
10571   if (type == NULL)
10572     return val;
10573   type = check_typedef (type);
10574   if (type->code () != TYPE_CODE_ENUM)
10575     return val;
10576
10577   if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10578     xsnprintf (name, sizeof (name), "Q%c", (int) val);
10579   else if (val >= 0 && val < 256)
10580     xsnprintf (name, sizeof (name), "QU%02x", (unsigned) val);
10581   else if (val >= 0 && val < 0x10000)
10582     xsnprintf (name, sizeof (name), "QW%04x", (unsigned) val);
10583   else
10584     xsnprintf (name, sizeof (name), "QWW%08lx", (unsigned long) val);
10585   size_t len = strlen (name);
10586   for (f = 0; f < type->num_fields (); f += 1)
10587     {
10588       /* Check the suffix because an enum constant in a package will
10589          have a name like "pkg__QUxx".  This is safe enough because we
10590          already have the correct type, and because mangling means
10591          there can't be clashes.  */
10592       const char *ename = type->field (f).name ();
10593       size_t elen = strlen (ename);
10594
10595       if (elen >= len && strcmp (name, ename + elen - len) == 0)
10596         return type->field (f).loc_enumval ();
10597     }
10598   return val;
10599 }
10600
10601 value *
10602 ada_char_operation::evaluate (struct type *expect_type,
10603                               struct expression *exp,
10604                               enum noside noside)
10605 {
10606   value *result = long_const_operation::evaluate (expect_type, exp, noside);
10607   if (expect_type != nullptr)
10608     result = ada_value_cast (expect_type, result);
10609   return result;
10610 }
10611
10612 /* See ada-exp.h.  */
10613
10614 operation_up
10615 ada_char_operation::replace (operation_up &&owner,
10616                              struct expression *exp,
10617                              bool deprocedure_p,
10618                              bool parse_completion,
10619                              innermost_block_tracker *tracker,
10620                              struct type *context_type)
10621 {
10622   operation_up result = std::move (owner);
10623
10624   if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10625     {
10626       gdb_assert (result.get () == this);
10627       std::get<0> (m_storage) = context_type;
10628       std::get<1> (m_storage)
10629         = convert_char_literal (context_type, std::get<1> (m_storage));
10630     }
10631
10632   return result;
10633 }
10634
10635 value *
10636 ada_wrapped_operation::evaluate (struct type *expect_type,
10637                                  struct expression *exp,
10638                                  enum noside noside)
10639 {
10640   value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10641   if (noside == EVAL_NORMAL)
10642     result = unwrap_value (result);
10643
10644   /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10645      then we need to perform the conversion manually, because
10646      evaluate_subexp_standard doesn't do it.  This conversion is
10647      necessary in Ada because the different kinds of float/fixed
10648      types in Ada have different representations.
10649
10650      Similarly, we need to perform the conversion from OP_LONG
10651      ourselves.  */
10652   if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10653     result = ada_value_cast (expect_type, result);
10654
10655   return result;
10656 }
10657
10658 value *
10659 ada_string_operation::evaluate (struct type *expect_type,
10660                                 struct expression *exp,
10661                                 enum noside noside)
10662 {
10663   struct type *char_type;
10664   if (expect_type != nullptr && ada_is_string_type (expect_type))
10665     char_type = ada_array_element_type (expect_type, 1);
10666   else
10667     char_type = language_string_char_type (exp->language_defn, exp->gdbarch);
10668
10669   const std::string &str = std::get<0> (m_storage);
10670   const char *encoding;
10671   switch (TYPE_LENGTH (char_type))
10672     {
10673     case 1:
10674       {
10675         /* Simply copy over the data -- this isn't perhaps strictly
10676            correct according to the encodings, but it is gdb's
10677            historical behavior.  */
10678         struct type *stringtype
10679           = lookup_array_range_type (char_type, 1, str.length ());
10680         struct value *val = allocate_value (stringtype);
10681         memcpy (value_contents_raw (val).data (), str.c_str (),
10682                 str.length ());
10683         return val;
10684       }
10685
10686     case 2:
10687       if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10688         encoding = "UTF-16BE";
10689       else
10690         encoding = "UTF-16LE";
10691       break;
10692
10693     case 4:
10694       if (gdbarch_byte_order (exp->gdbarch) == BFD_ENDIAN_BIG)
10695         encoding = "UTF-32BE";
10696       else
10697         encoding = "UTF-32LE";
10698       break;
10699
10700     default:
10701       error (_("unexpected character type size %s"),
10702              pulongest (TYPE_LENGTH (char_type)));
10703     }
10704
10705   auto_obstack converted;
10706   convert_between_encodings (host_charset (), encoding,
10707                              (const gdb_byte *) str.c_str (),
10708                              str.length (), 1,
10709                              &converted, translit_none);
10710
10711   struct type *stringtype
10712     = lookup_array_range_type (char_type, 1,
10713                                obstack_object_size (&converted)
10714                                / TYPE_LENGTH (char_type));
10715   struct value *val = allocate_value (stringtype);
10716   memcpy (value_contents_raw (val).data (),
10717           obstack_base (&converted),
10718           obstack_object_size (&converted));
10719   return val;
10720 }
10721
10722 value *
10723 ada_concat_operation::evaluate (struct type *expect_type,
10724                                 struct expression *exp,
10725                                 enum noside noside)
10726 {
10727   /* If one side is a literal, evaluate the other side first so that
10728      the expected type can be set properly.  */
10729   const operation_up &lhs_expr = std::get<0> (m_storage);
10730   const operation_up &rhs_expr = std::get<1> (m_storage);
10731
10732   value *lhs, *rhs;
10733   if (dynamic_cast<ada_string_operation *> (lhs_expr.get ()) != nullptr)
10734     {
10735       rhs = rhs_expr->evaluate (nullptr, exp, noside);
10736       lhs = lhs_expr->evaluate (value_type (rhs), exp, noside);
10737     }
10738   else if (dynamic_cast<ada_char_operation *> (lhs_expr.get ()) != nullptr)
10739     {
10740       rhs = rhs_expr->evaluate (nullptr, exp, noside);
10741       struct type *rhs_type = check_typedef (value_type (rhs));
10742       struct type *elt_type = nullptr;
10743       if (rhs_type->code () == TYPE_CODE_ARRAY)
10744         elt_type = TYPE_TARGET_TYPE (rhs_type);
10745       lhs = lhs_expr->evaluate (elt_type, exp, noside);
10746     }
10747   else if (dynamic_cast<ada_string_operation *> (rhs_expr.get ()) != nullptr)
10748     {
10749       lhs = lhs_expr->evaluate (nullptr, exp, noside);
10750       rhs = rhs_expr->evaluate (value_type (lhs), exp, noside);
10751     }
10752   else if (dynamic_cast<ada_char_operation *> (rhs_expr.get ()) != nullptr)
10753     {
10754       lhs = lhs_expr->evaluate (nullptr, exp, noside);
10755       struct type *lhs_type = check_typedef (value_type (lhs));
10756       struct type *elt_type = nullptr;
10757       if (lhs_type->code () == TYPE_CODE_ARRAY)
10758         elt_type = TYPE_TARGET_TYPE (lhs_type);
10759       rhs = rhs_expr->evaluate (elt_type, exp, noside);
10760     }
10761   else
10762     return concat_operation::evaluate (expect_type, exp, noside);
10763
10764   return value_concat (lhs, rhs);
10765 }
10766
10767 value *
10768 ada_qual_operation::evaluate (struct type *expect_type,
10769                               struct expression *exp,
10770                               enum noside noside)
10771 {
10772   struct type *type = std::get<1> (m_storage);
10773   return std::get<0> (m_storage)->evaluate (type, exp, noside);
10774 }
10775
10776 value *
10777 ada_ternop_range_operation::evaluate (struct type *expect_type,
10778                                       struct expression *exp,
10779                                       enum noside noside)
10780 {
10781   value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10782   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10783   value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10784   return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10785 }
10786
10787 value *
10788 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10789                                       struct expression *exp,
10790                                       enum noside noside)
10791 {
10792   value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10793   value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10794
10795   auto do_op = [=] (LONGEST x, LONGEST y)
10796     {
10797       if (std::get<0> (m_storage) == BINOP_ADD)
10798         return x + y;
10799       return x - y;
10800     };
10801
10802   if (value_type (arg1)->code () == TYPE_CODE_PTR)
10803     return (value_from_longest
10804             (value_type (arg1),
10805              do_op (value_as_long (arg1), value_as_long (arg2))));
10806   if (value_type (arg2)->code () == TYPE_CODE_PTR)
10807     return (value_from_longest
10808             (value_type (arg2),
10809              do_op (value_as_long (arg1), value_as_long (arg2))));
10810   /* Preserve the original type for use by the range case below.
10811      We cannot cast the result to a reference type, so if ARG1 is
10812      a reference type, find its underlying type.  */
10813   struct type *type = value_type (arg1);
10814   while (type->code () == TYPE_CODE_REF)
10815     type = TYPE_TARGET_TYPE (type);
10816   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10817   arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10818   /* We need to special-case the result with a range.
10819      This is done for the benefit of "ptype".  gdb's Ada support
10820      historically used the LHS to set the result type here, so
10821      preserve this behavior.  */
10822   if (type->code () == TYPE_CODE_RANGE)
10823     arg1 = value_cast (type, arg1);
10824   return arg1;
10825 }
10826
10827 value *
10828 ada_unop_atr_operation::evaluate (struct type *expect_type,
10829                                   struct expression *exp,
10830                                   enum noside noside)
10831 {
10832   struct type *type_arg = nullptr;
10833   value *val = nullptr;
10834
10835   if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10836     {
10837       value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10838                                                       EVAL_AVOID_SIDE_EFFECTS);
10839       type_arg = value_type (tem);
10840     }
10841   else
10842     val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10843
10844   return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10845                        val, type_arg, std::get<2> (m_storage));
10846 }
10847
10848 value *
10849 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10850                                                  struct expression *exp,
10851                                                  enum noside noside)
10852 {
10853   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10854     return value_zero (expect_type, not_lval);
10855
10856   const bound_minimal_symbol &b = std::get<0> (m_storage);
10857   value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10858
10859   val = ada_value_cast (expect_type, val);
10860
10861   /* Follow the Ada language semantics that do not allow taking
10862      an address of the result of a cast (view conversion in Ada).  */
10863   if (VALUE_LVAL (val) == lval_memory)
10864     {
10865       if (value_lazy (val))
10866         value_fetch_lazy (val);
10867       VALUE_LVAL (val) = not_lval;
10868     }
10869   return val;
10870 }
10871
10872 value *
10873 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10874                                             struct expression *exp,
10875                                             enum noside noside)
10876 {
10877   value *val = evaluate_var_value (noside,
10878                                    std::get<0> (m_storage).block,
10879                                    std::get<0> (m_storage).symbol);
10880
10881   val = ada_value_cast (expect_type, val);
10882
10883   /* Follow the Ada language semantics that do not allow taking
10884      an address of the result of a cast (view conversion in Ada).  */
10885   if (VALUE_LVAL (val) == lval_memory)
10886     {
10887       if (value_lazy (val))
10888         value_fetch_lazy (val);
10889       VALUE_LVAL (val) = not_lval;
10890     }
10891   return val;
10892 }
10893
10894 value *
10895 ada_var_value_operation::evaluate (struct type *expect_type,
10896                                    struct expression *exp,
10897                                    enum noside noside)
10898 {
10899   symbol *sym = std::get<0> (m_storage).symbol;
10900
10901   if (sym->domain () == UNDEF_DOMAIN)
10902     /* Only encountered when an unresolved symbol occurs in a
10903        context other than a function call, in which case, it is
10904        invalid.  */
10905     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10906            sym->print_name ());
10907
10908   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10909     {
10910       struct type *type = static_unwrap_type (sym->type ());
10911       /* Check to see if this is a tagged type.  We also need to handle
10912          the case where the type is a reference to a tagged type, but
10913          we have to be careful to exclude pointers to tagged types.
10914          The latter should be shown as usual (as a pointer), whereas
10915          a reference should mostly be transparent to the user.  */
10916       if (ada_is_tagged_type (type, 0)
10917           || (type->code () == TYPE_CODE_REF
10918               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10919         {
10920           /* Tagged types are a little special in the fact that the real
10921              type is dynamic and can only be determined by inspecting the
10922              object's tag.  This means that we need to get the object's
10923              value first (EVAL_NORMAL) and then extract the actual object
10924              type from its tag.
10925
10926              Note that we cannot skip the final step where we extract
10927              the object type from its tag, because the EVAL_NORMAL phase
10928              results in dynamic components being resolved into fixed ones.
10929              This can cause problems when trying to print the type
10930              description of tagged types whose parent has a dynamic size:
10931              We use the type name of the "_parent" component in order
10932              to print the name of the ancestor type in the type description.
10933              If that component had a dynamic size, the resolution into
10934              a fixed type would result in the loss of that type name,
10935              thus preventing us from printing the name of the ancestor
10936              type in the type description.  */
10937           value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10938
10939           if (type->code () != TYPE_CODE_REF)
10940             {
10941               struct type *actual_type;
10942
10943               actual_type = type_from_tag (ada_value_tag (arg1));
10944               if (actual_type == NULL)
10945                 /* If, for some reason, we were unable to determine
10946                    the actual type from the tag, then use the static
10947                    approximation that we just computed as a fallback.
10948                    This can happen if the debugging information is
10949                    incomplete, for instance.  */
10950                 actual_type = type;
10951               return value_zero (actual_type, not_lval);
10952             }
10953           else
10954             {
10955               /* In the case of a ref, ada_coerce_ref takes care
10956                  of determining the actual type.  But the evaluation
10957                  should return a ref as it should be valid to ask
10958                  for its address; so rebuild a ref after coerce.  */
10959               arg1 = ada_coerce_ref (arg1);
10960               return value_ref (arg1, TYPE_CODE_REF);
10961             }
10962         }
10963
10964       /* Records and unions for which GNAT encodings have been
10965          generated need to be statically fixed as well.
10966          Otherwise, non-static fixing produces a type where
10967          all dynamic properties are removed, which prevents "ptype"
10968          from being able to completely describe the type.
10969          For instance, a case statement in a variant record would be
10970          replaced by the relevant components based on the actual
10971          value of the discriminants.  */
10972       if ((type->code () == TYPE_CODE_STRUCT
10973            && dynamic_template_type (type) != NULL)
10974           || (type->code () == TYPE_CODE_UNION
10975               && ada_find_parallel_type (type, "___XVU") != NULL))
10976         return value_zero (to_static_fixed_type (type), not_lval);
10977     }
10978
10979   value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10980   return ada_to_fixed_value (arg1);
10981 }
10982
10983 bool
10984 ada_var_value_operation::resolve (struct expression *exp,
10985                                   bool deprocedure_p,
10986                                   bool parse_completion,
10987                                   innermost_block_tracker *tracker,
10988                                   struct type *context_type)
10989 {
10990   symbol *sym = std::get<0> (m_storage).symbol;
10991   if (sym->domain () == UNDEF_DOMAIN)
10992     {
10993       block_symbol resolved
10994         = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10995                                 context_type, parse_completion,
10996                                 deprocedure_p, tracker);
10997       std::get<0> (m_storage) = resolved;
10998     }
10999
11000   if (deprocedure_p
11001       && (std::get<0> (m_storage).symbol->type ()->code ()
11002           == TYPE_CODE_FUNC))
11003     return true;
11004
11005   return false;
11006 }
11007
11008 value *
11009 ada_atr_val_operation::evaluate (struct type *expect_type,
11010                                  struct expression *exp,
11011                                  enum noside noside)
11012 {
11013   value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
11014   return ada_val_atr (noside, std::get<0> (m_storage), arg);
11015 }
11016
11017 value *
11018 ada_unop_ind_operation::evaluate (struct type *expect_type,
11019                                   struct expression *exp,
11020                                   enum noside noside)
11021 {
11022   value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
11023
11024   struct type *type = ada_check_typedef (value_type (arg1));
11025   if (noside == EVAL_AVOID_SIDE_EFFECTS)
11026     {
11027       if (ada_is_array_descriptor_type (type))
11028         /* GDB allows dereferencing GNAT array descriptors.  */
11029         {
11030           struct type *arrType = ada_type_of_array (arg1, 0);
11031
11032           if (arrType == NULL)
11033             error (_("Attempt to dereference null array pointer."));
11034           return value_at_lazy (arrType, 0);
11035         }
11036       else if (type->code () == TYPE_CODE_PTR
11037                || type->code () == TYPE_CODE_REF
11038                /* In C you can dereference an array to get the 1st elt.  */
11039                || type->code () == TYPE_CODE_ARRAY)
11040         {
11041           /* As mentioned in the OP_VAR_VALUE case, tagged types can
11042              only be determined by inspecting the object's tag.
11043              This means that we need to evaluate completely the
11044              expression in order to get its type.  */
11045
11046           if ((type->code () == TYPE_CODE_REF
11047                || type->code () == TYPE_CODE_PTR)
11048               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11049             {
11050               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11051                                                         EVAL_NORMAL);
11052               type = value_type (ada_value_ind (arg1));
11053             }
11054           else
11055             {
11056               type = to_static_fixed_type
11057                 (ada_aligned_type
11058                  (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11059             }
11060           return value_zero (type, lval_memory);
11061         }
11062       else if (type->code () == TYPE_CODE_INT)
11063         {
11064           /* GDB allows dereferencing an int.  */
11065           if (expect_type == NULL)
11066             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11067                                lval_memory);
11068           else
11069             {
11070               expect_type =
11071                 to_static_fixed_type (ada_aligned_type (expect_type));
11072               return value_zero (expect_type, lval_memory);
11073             }
11074         }
11075       else
11076         error (_("Attempt to take contents of a non-pointer value."));
11077     }
11078   arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
11079   type = ada_check_typedef (value_type (arg1));
11080
11081   if (type->code () == TYPE_CODE_INT)
11082     /* GDB allows dereferencing an int.  If we were given
11083        the expect_type, then use that as the target type.
11084        Otherwise, assume that the target type is an int.  */
11085     {
11086       if (expect_type != NULL)
11087         return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11088                                           arg1));
11089       else
11090         return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11091                               (CORE_ADDR) value_as_address (arg1));
11092     }
11093
11094   if (ada_is_array_descriptor_type (type))
11095     /* GDB allows dereferencing GNAT array descriptors.  */
11096     return ada_coerce_to_simple_array (arg1);
11097   else
11098     return ada_value_ind (arg1);
11099 }
11100
11101 value *
11102 ada_structop_operation::evaluate (struct type *expect_type,
11103                                   struct expression *exp,
11104                                   enum noside noside)
11105 {
11106   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
11107   const char *str = std::get<1> (m_storage).c_str ();
11108   if (noside == EVAL_AVOID_SIDE_EFFECTS)
11109     {
11110       struct type *type;
11111       struct type *type1 = value_type (arg1);
11112
11113       if (ada_is_tagged_type (type1, 1))
11114         {
11115           type = ada_lookup_struct_elt_type (type1, str, 1, 1);
11116
11117           /* If the field is not found, check if it exists in the
11118              extension of this object's type. This means that we
11119              need to evaluate completely the expression.  */
11120
11121           if (type == NULL)
11122             {
11123               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
11124                                                         EVAL_NORMAL);
11125               arg1 = ada_value_struct_elt (arg1, str, 0);
11126               arg1 = unwrap_value (arg1);
11127               type = value_type (ada_to_fixed_value (arg1));
11128             }
11129         }
11130       else
11131         type = ada_lookup_struct_elt_type (type1, str, 1, 0);
11132
11133       return value_zero (ada_aligned_type (type), lval_memory);
11134     }
11135   else
11136     {
11137       arg1 = ada_value_struct_elt (arg1, str, 0);
11138       arg1 = unwrap_value (arg1);
11139       return ada_to_fixed_value (arg1);
11140     }
11141 }
11142
11143 value *
11144 ada_funcall_operation::evaluate (struct type *expect_type,
11145                                  struct expression *exp,
11146                                  enum noside noside)
11147 {
11148   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11149   int nargs = args_up.size ();
11150   std::vector<value *> argvec (nargs);
11151   operation_up &callee_op = std::get<0> (m_storage);
11152
11153   ada_var_value_operation *avv
11154     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11155   if (avv != nullptr
11156       && avv->get_symbol ()->domain () == UNDEF_DOMAIN)
11157     error (_("Unexpected unresolved symbol, %s, during evaluation"),
11158            avv->get_symbol ()->print_name ());
11159
11160   value *callee = callee_op->evaluate (nullptr, exp, noside);
11161   for (int i = 0; i < args_up.size (); ++i)
11162     argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
11163
11164   if (ada_is_constrained_packed_array_type
11165       (desc_base_type (value_type (callee))))
11166     callee = ada_coerce_to_simple_array (callee);
11167   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11168            && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
11169     /* This is a packed array that has already been fixed, and
11170        therefore already coerced to a simple array.  Nothing further
11171        to do.  */
11172     ;
11173   else if (value_type (callee)->code () == TYPE_CODE_REF)
11174     {
11175       /* Make sure we dereference references so that all the code below
11176          feels like it's really handling the referenced value.  Wrapping
11177          types (for alignment) may be there, so make sure we strip them as
11178          well.  */
11179       callee = ada_to_fixed_value (coerce_ref (callee));
11180     }
11181   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
11182            && VALUE_LVAL (callee) == lval_memory)
11183     callee = value_addr (callee);
11184
11185   struct type *type = ada_check_typedef (value_type (callee));
11186
11187   /* Ada allows us to implicitly dereference arrays when subscripting
11188      them.  So, if this is an array typedef (encoding use for array
11189      access types encoded as fat pointers), strip it now.  */
11190   if (type->code () == TYPE_CODE_TYPEDEF)
11191     type = ada_typedef_target_type (type);
11192
11193   if (type->code () == TYPE_CODE_PTR)
11194     {
11195       switch (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ())
11196         {
11197         case TYPE_CODE_FUNC:
11198           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
11199           break;
11200         case TYPE_CODE_ARRAY:
11201           break;
11202         case TYPE_CODE_STRUCT:
11203           if (noside != EVAL_AVOID_SIDE_EFFECTS)
11204             callee = ada_value_ind (callee);
11205           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
11206           break;
11207         default:
11208           error (_("cannot subscript or call something of type `%s'"),
11209                  ada_type_name (value_type (callee)));
11210           break;
11211         }
11212     }
11213
11214   switch (type->code ())
11215     {
11216     case TYPE_CODE_FUNC:
11217       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11218         {
11219           if (TYPE_TARGET_TYPE (type) == NULL)
11220             error_call_unknown_return_type (NULL);
11221           return allocate_value (TYPE_TARGET_TYPE (type));
11222         }
11223       return call_function_by_hand (callee, NULL, argvec);
11224     case TYPE_CODE_INTERNAL_FUNCTION:
11225       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11226         /* We don't know anything about what the internal
11227            function might return, but we have to return
11228            something.  */
11229         return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11230                            not_lval);
11231       else
11232         return call_internal_function (exp->gdbarch, exp->language_defn,
11233                                        callee, nargs,
11234                                        argvec.data ());
11235
11236     case TYPE_CODE_STRUCT:
11237       {
11238         int arity;
11239
11240         arity = ada_array_arity (type);
11241         type = ada_array_element_type (type, nargs);
11242         if (type == NULL)
11243           error (_("cannot subscript or call a record"));
11244         if (arity != nargs)
11245           error (_("wrong number of subscripts; expecting %d"), arity);
11246         if (noside == EVAL_AVOID_SIDE_EFFECTS)
11247           return value_zero (ada_aligned_type (type), lval_memory);
11248         return
11249           unwrap_value (ada_value_subscript
11250                         (callee, nargs, argvec.data ()));
11251       }
11252     case TYPE_CODE_ARRAY:
11253       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11254         {
11255           type = ada_array_element_type (type, nargs);
11256           if (type == NULL)
11257             error (_("element type of array unknown"));
11258           else
11259             return value_zero (ada_aligned_type (type), lval_memory);
11260         }
11261       return
11262         unwrap_value (ada_value_subscript
11263                       (ada_coerce_to_simple_array (callee),
11264                        nargs, argvec.data ()));
11265     case TYPE_CODE_PTR:     /* Pointer to array */
11266       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11267         {
11268           type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
11269           type = ada_array_element_type (type, nargs);
11270           if (type == NULL)
11271             error (_("element type of array unknown"));
11272           else
11273             return value_zero (ada_aligned_type (type), lval_memory);
11274         }
11275       return
11276         unwrap_value (ada_value_ptr_subscript (callee, nargs,
11277                                                argvec.data ()));
11278
11279     default:
11280       error (_("Attempt to index or call something other than an "
11281                "array or function"));
11282     }
11283 }
11284
11285 bool
11286 ada_funcall_operation::resolve (struct expression *exp,
11287                                 bool deprocedure_p,
11288                                 bool parse_completion,
11289                                 innermost_block_tracker *tracker,
11290                                 struct type *context_type)
11291 {
11292   operation_up &callee_op = std::get<0> (m_storage);
11293
11294   ada_var_value_operation *avv
11295     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
11296   if (avv == nullptr)
11297     return false;
11298
11299   symbol *sym = avv->get_symbol ();
11300   if (sym->domain () != UNDEF_DOMAIN)
11301     return false;
11302
11303   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
11304   int nargs = args_up.size ();
11305   std::vector<value *> argvec (nargs);
11306
11307   for (int i = 0; i < args_up.size (); ++i)
11308     argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
11309
11310   const block *block = avv->get_block ();
11311   block_symbol resolved
11312     = ada_resolve_funcall (sym, block,
11313                            context_type, parse_completion,
11314                            nargs, argvec.data (),
11315                            tracker);
11316
11317   std::get<0> (m_storage)
11318     = make_operation<ada_var_value_operation> (resolved);
11319   return false;
11320 }
11321
11322 bool
11323 ada_ternop_slice_operation::resolve (struct expression *exp,
11324                                      bool deprocedure_p,
11325                                      bool parse_completion,
11326                                      innermost_block_tracker *tracker,
11327                                      struct type *context_type)
11328 {
11329   /* Historically this check was done during resolution, so we
11330      continue that here.  */
11331   value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
11332                                                 EVAL_AVOID_SIDE_EFFECTS);
11333   if (ada_is_any_packed_array_type (value_type (v)))
11334     error (_("cannot slice a packed array"));
11335   return false;
11336 }
11337
11338 }
11339
11340 \f
11341
11342 /* Return non-zero iff TYPE represents a System.Address type.  */
11343
11344 int
11345 ada_is_system_address_type (struct type *type)
11346 {
11347   return (type->name () && strcmp (type->name (), "system__address") == 0);
11348 }
11349
11350 \f
11351
11352                                 /* Range types */
11353
11354 /* Scan STR beginning at position K for a discriminant name, and
11355    return the value of that discriminant field of DVAL in *PX.  If
11356    PNEW_K is not null, put the position of the character beyond the
11357    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
11358    not alter *PX and *PNEW_K if unsuccessful.  */
11359
11360 static int
11361 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11362                     int *pnew_k)
11363 {
11364   static std::string storage;
11365   const char *pstart, *pend, *bound;
11366   struct value *bound_val;
11367
11368   if (dval == NULL || str == NULL || str[k] == '\0')
11369     return 0;
11370
11371   pstart = str + k;
11372   pend = strstr (pstart, "__");
11373   if (pend == NULL)
11374     {
11375       bound = pstart;
11376       k += strlen (bound);
11377     }
11378   else
11379     {
11380       int len = pend - pstart;
11381
11382       /* Strip __ and beyond.  */
11383       storage = std::string (pstart, len);
11384       bound = storage.c_str ();
11385       k = pend - str;
11386     }
11387
11388   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11389   if (bound_val == NULL)
11390     return 0;
11391
11392   *px = value_as_long (bound_val);
11393   if (pnew_k != NULL)
11394     *pnew_k = k;
11395   return 1;
11396 }
11397
11398 /* Value of variable named NAME.  Only exact matches are considered.
11399    If no such variable found, then if ERR_MSG is null, returns 0, and
11400    otherwise causes an error with message ERR_MSG.  */
11401
11402 static struct value *
11403 get_var_value (const char *name, const char *err_msg)
11404 {
11405   std::string quoted_name = add_angle_brackets (name);
11406
11407   lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
11408
11409   std::vector<struct block_symbol> syms
11410     = ada_lookup_symbol_list_worker (lookup_name,
11411                                      get_selected_block (0),
11412                                      VAR_DOMAIN, 1);
11413
11414   if (syms.size () != 1)
11415     {
11416       if (err_msg == NULL)
11417         return 0;
11418       else
11419         error (("%s"), err_msg);
11420     }
11421
11422   return value_of_variable (syms[0].symbol, syms[0].block);
11423 }
11424
11425 /* Value of integer variable named NAME in the current environment.
11426    If no such variable is found, returns false.  Otherwise, sets VALUE
11427    to the variable's value and returns true.  */
11428
11429 bool
11430 get_int_var_value (const char *name, LONGEST &value)
11431 {
11432   struct value *var_val = get_var_value (name, 0);
11433
11434   if (var_val == 0)
11435     return false;
11436
11437   value = value_as_long (var_val);
11438   return true;
11439 }
11440
11441
11442 /* Return a range type whose base type is that of the range type named
11443    NAME in the current environment, and whose bounds are calculated
11444    from NAME according to the GNAT range encoding conventions.
11445    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
11446    corresponding range type from debug information; fall back to using it
11447    if symbol lookup fails.  If a new type must be created, allocate it
11448    like ORIG_TYPE was.  The bounds information, in general, is encoded
11449    in NAME, the base type given in the named range type.  */
11450
11451 static struct type *
11452 to_fixed_range_type (struct type *raw_type, struct value *dval)
11453 {
11454   const char *name;
11455   struct type *base_type;
11456   const char *subtype_info;
11457
11458   gdb_assert (raw_type != NULL);
11459   gdb_assert (raw_type->name () != NULL);
11460
11461   if (raw_type->code () == TYPE_CODE_RANGE)
11462     base_type = TYPE_TARGET_TYPE (raw_type);
11463   else
11464     base_type = raw_type;
11465
11466   name = raw_type->name ();
11467   subtype_info = strstr (name, "___XD");
11468   if (subtype_info == NULL)
11469     {
11470       LONGEST L = ada_discrete_type_low_bound (raw_type);
11471       LONGEST U = ada_discrete_type_high_bound (raw_type);
11472
11473       if (L < INT_MIN || U > INT_MAX)
11474         return raw_type;
11475       else
11476         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11477                                          L, U);
11478     }
11479   else
11480     {
11481       int prefix_len = subtype_info - name;
11482       LONGEST L, U;
11483       struct type *type;
11484       const char *bounds_str;
11485       int n;
11486
11487       subtype_info += 5;
11488       bounds_str = strchr (subtype_info, '_');
11489       n = 1;
11490
11491       if (*subtype_info == 'L')
11492         {
11493           if (!ada_scan_number (bounds_str, n, &L, &n)
11494               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11495             return raw_type;
11496           if (bounds_str[n] == '_')
11497             n += 2;
11498           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
11499             n += 1;
11500           subtype_info += 1;
11501         }
11502       else
11503         {
11504           std::string name_buf = std::string (name, prefix_len) + "___L";
11505           if (!get_int_var_value (name_buf.c_str (), L))
11506             {
11507               lim_warning (_("Unknown lower bound, using 1."));
11508               L = 1;
11509             }
11510         }
11511
11512       if (*subtype_info == 'U')
11513         {
11514           if (!ada_scan_number (bounds_str, n, &U, &n)
11515               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11516             return raw_type;
11517         }
11518       else
11519         {
11520           std::string name_buf = std::string (name, prefix_len) + "___U";
11521           if (!get_int_var_value (name_buf.c_str (), U))
11522             {
11523               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11524               U = L;
11525             }
11526         }
11527
11528       type = create_static_range_type (alloc_type_copy (raw_type),
11529                                        base_type, L, U);
11530       /* create_static_range_type alters the resulting type's length
11531          to match the size of the base_type, which is not what we want.
11532          Set it back to the original range type's length.  */
11533       TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11534       type->set_name (name);
11535       return type;
11536     }
11537 }
11538
11539 /* True iff NAME is the name of a range type.  */
11540
11541 int
11542 ada_is_range_type_name (const char *name)
11543 {
11544   return (name != NULL && strstr (name, "___XD"));
11545 }
11546 \f
11547
11548                                 /* Modular types */
11549
11550 /* True iff TYPE is an Ada modular type.  */
11551
11552 int
11553 ada_is_modular_type (struct type *type)
11554 {
11555   struct type *subranged_type = get_base_type (type);
11556
11557   return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11558           && subranged_type->code () == TYPE_CODE_INT
11559           && subranged_type->is_unsigned ());
11560 }
11561
11562 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
11563
11564 ULONGEST
11565 ada_modulus (struct type *type)
11566 {
11567   const dynamic_prop &high = type->bounds ()->high;
11568
11569   if (high.kind () == PROP_CONST)
11570     return (ULONGEST) high.const_val () + 1;
11571
11572   /* If TYPE is unresolved, the high bound might be a location list.  Return
11573      0, for lack of a better value to return.  */
11574   return 0;
11575 }
11576 \f
11577
11578 /* Ada exception catchpoint support:
11579    ---------------------------------
11580
11581    We support 3 kinds of exception catchpoints:
11582      . catchpoints on Ada exceptions
11583      . catchpoints on unhandled Ada exceptions
11584      . catchpoints on failed assertions
11585
11586    Exceptions raised during failed assertions, or unhandled exceptions
11587    could perfectly be caught with the general catchpoint on Ada exceptions.
11588    However, we can easily differentiate these two special cases, and having
11589    the option to distinguish these two cases from the rest can be useful
11590    to zero-in on certain situations.
11591
11592    Exception catchpoints are a specialized form of breakpoint,
11593    since they rely on inserting breakpoints inside known routines
11594    of the GNAT runtime.  The implementation therefore uses a standard
11595    breakpoint structure of the BP_BREAKPOINT type, but with its own set
11596    of breakpoint_ops.
11597
11598    Support in the runtime for exception catchpoints have been changed
11599    a few times already, and these changes affect the implementation
11600    of these catchpoints.  In order to be able to support several
11601    variants of the runtime, we use a sniffer that will determine
11602    the runtime variant used by the program being debugged.  */
11603
11604 /* Ada's standard exceptions.
11605
11606    The Ada 83 standard also defined Numeric_Error.  But there so many
11607    situations where it was unclear from the Ada 83 Reference Manual
11608    (RM) whether Constraint_Error or Numeric_Error should be raised,
11609    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11610    Interpretation saying that anytime the RM says that Numeric_Error
11611    should be raised, the implementation may raise Constraint_Error.
11612    Ada 95 went one step further and pretty much removed Numeric_Error
11613    from the list of standard exceptions (it made it a renaming of
11614    Constraint_Error, to help preserve compatibility when compiling
11615    an Ada83 compiler). As such, we do not include Numeric_Error from
11616    this list of standard exceptions.  */
11617
11618 static const char * const standard_exc[] = {
11619   "constraint_error",
11620   "program_error",
11621   "storage_error",
11622   "tasking_error"
11623 };
11624
11625 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11626
11627 /* A structure that describes how to support exception catchpoints
11628    for a given executable.  */
11629
11630 struct exception_support_info
11631 {
11632    /* The name of the symbol to break on in order to insert
11633       a catchpoint on exceptions.  */
11634    const char *catch_exception_sym;
11635
11636    /* The name of the symbol to break on in order to insert
11637       a catchpoint on unhandled exceptions.  */
11638    const char *catch_exception_unhandled_sym;
11639
11640    /* The name of the symbol to break on in order to insert
11641       a catchpoint on failed assertions.  */
11642    const char *catch_assert_sym;
11643
11644    /* The name of the symbol to break on in order to insert
11645       a catchpoint on exception handling.  */
11646    const char *catch_handlers_sym;
11647
11648    /* Assuming that the inferior just triggered an unhandled exception
11649       catchpoint, this function is responsible for returning the address
11650       in inferior memory where the name of that exception is stored.
11651       Return zero if the address could not be computed.  */
11652    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11653 };
11654
11655 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11656 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11657
11658 /* The following exception support info structure describes how to
11659    implement exception catchpoints with the latest version of the
11660    Ada runtime (as of 2019-08-??).  */
11661
11662 static const struct exception_support_info default_exception_support_info =
11663 {
11664   "__gnat_debug_raise_exception", /* catch_exception_sym */
11665   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11666   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11667   "__gnat_begin_handler_v1", /* catch_handlers_sym */
11668   ada_unhandled_exception_name_addr
11669 };
11670
11671 /* The following exception support info structure describes how to
11672    implement exception catchpoints with an earlier version of the
11673    Ada runtime (as of 2007-03-06) using v0 of the EH ABI.  */
11674
11675 static const struct exception_support_info exception_support_info_v0 =
11676 {
11677   "__gnat_debug_raise_exception", /* catch_exception_sym */
11678   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11679   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11680   "__gnat_begin_handler", /* catch_handlers_sym */
11681   ada_unhandled_exception_name_addr
11682 };
11683
11684 /* The following exception support info structure describes how to
11685    implement exception catchpoints with a slightly older version
11686    of the Ada runtime.  */
11687
11688 static const struct exception_support_info exception_support_info_fallback =
11689 {
11690   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11691   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11692   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
11693   "__gnat_begin_handler", /* catch_handlers_sym */
11694   ada_unhandled_exception_name_addr_from_raise
11695 };
11696
11697 /* Return nonzero if we can detect the exception support routines
11698    described in EINFO.
11699
11700    This function errors out if an abnormal situation is detected
11701    (for instance, if we find the exception support routines, but
11702    that support is found to be incomplete).  */
11703
11704 static int
11705 ada_has_this_exception_support (const struct exception_support_info *einfo)
11706 {
11707   struct symbol *sym;
11708
11709   /* The symbol we're looking up is provided by a unit in the GNAT runtime
11710      that should be compiled with debugging information.  As a result, we
11711      expect to find that symbol in the symtabs.  */
11712
11713   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11714   if (sym == NULL)
11715     {
11716       /* Perhaps we did not find our symbol because the Ada runtime was
11717          compiled without debugging info, or simply stripped of it.
11718          It happens on some GNU/Linux distributions for instance, where
11719          users have to install a separate debug package in order to get
11720          the runtime's debugging info.  In that situation, let the user
11721          know why we cannot insert an Ada exception catchpoint.
11722
11723          Note: Just for the purpose of inserting our Ada exception
11724          catchpoint, we could rely purely on the associated minimal symbol.
11725          But we would be operating in degraded mode anyway, since we are
11726          still lacking the debugging info needed later on to extract
11727          the name of the exception being raised (this name is printed in
11728          the catchpoint message, and is also used when trying to catch
11729          a specific exception).  We do not handle this case for now.  */
11730       struct bound_minimal_symbol msym
11731         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11732
11733       if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11734         error (_("Your Ada runtime appears to be missing some debugging "
11735                  "information.\nCannot insert Ada exception catchpoint "
11736                  "in this configuration."));
11737
11738       return 0;
11739     }
11740
11741   /* Make sure that the symbol we found corresponds to a function.  */
11742
11743   if (sym->aclass () != LOC_BLOCK)
11744     {
11745       error (_("Symbol \"%s\" is not a function (class = %d)"),
11746              sym->linkage_name (), sym->aclass ());
11747       return 0;
11748     }
11749
11750   sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11751   if (sym == NULL)
11752     {
11753       struct bound_minimal_symbol msym
11754         = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11755
11756       if (msym.minsym && msym.minsym->type () != mst_solib_trampoline)
11757         error (_("Your Ada runtime appears to be missing some debugging "
11758                  "information.\nCannot insert Ada exception catchpoint "
11759                  "in this configuration."));
11760
11761       return 0;
11762     }
11763
11764   /* Make sure that the symbol we found corresponds to a function.  */
11765
11766   if (sym->aclass () != LOC_BLOCK)
11767     {
11768       error (_("Symbol \"%s\" is not a function (class = %d)"),
11769              sym->linkage_name (), sym->aclass ());
11770       return 0;
11771     }
11772
11773   return 1;
11774 }
11775
11776 /* Inspect the Ada runtime and determine which exception info structure
11777    should be used to provide support for exception catchpoints.
11778
11779    This function will always set the per-inferior exception_info,
11780    or raise an error.  */
11781
11782 static void
11783 ada_exception_support_info_sniffer (void)
11784 {
11785   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11786
11787   /* If the exception info is already known, then no need to recompute it.  */
11788   if (data->exception_info != NULL)
11789     return;
11790
11791   /* Check the latest (default) exception support info.  */
11792   if (ada_has_this_exception_support (&default_exception_support_info))
11793     {
11794       data->exception_info = &default_exception_support_info;
11795       return;
11796     }
11797
11798   /* Try the v0 exception suport info.  */
11799   if (ada_has_this_exception_support (&exception_support_info_v0))
11800     {
11801       data->exception_info = &exception_support_info_v0;
11802       return;
11803     }
11804
11805   /* Try our fallback exception suport info.  */
11806   if (ada_has_this_exception_support (&exception_support_info_fallback))
11807     {
11808       data->exception_info = &exception_support_info_fallback;
11809       return;
11810     }
11811
11812   /* Sometimes, it is normal for us to not be able to find the routine
11813      we are looking for.  This happens when the program is linked with
11814      the shared version of the GNAT runtime, and the program has not been
11815      started yet.  Inform the user of these two possible causes if
11816      applicable.  */
11817
11818   if (ada_update_initial_language (language_unknown) != language_ada)
11819     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
11820
11821   /* If the symbol does not exist, then check that the program is
11822      already started, to make sure that shared libraries have been
11823      loaded.  If it is not started, this may mean that the symbol is
11824      in a shared library.  */
11825
11826   if (inferior_ptid.pid () == 0)
11827     error (_("Unable to insert catchpoint. Try to start the program first."));
11828
11829   /* At this point, we know that we are debugging an Ada program and
11830      that the inferior has been started, but we still are not able to
11831      find the run-time symbols.  That can mean that we are in
11832      configurable run time mode, or that a-except as been optimized
11833      out by the linker...  In any case, at this point it is not worth
11834      supporting this feature.  */
11835
11836   error (_("Cannot insert Ada exception catchpoints in this configuration."));
11837 }
11838
11839 /* True iff FRAME is very likely to be that of a function that is
11840    part of the runtime system.  This is all very heuristic, but is
11841    intended to be used as advice as to what frames are uninteresting
11842    to most users.  */
11843
11844 static int
11845 is_known_support_routine (struct frame_info *frame)
11846 {
11847   enum language func_lang;
11848   int i;
11849   const char *fullname;
11850
11851   /* If this code does not have any debugging information (no symtab),
11852      This cannot be any user code.  */
11853
11854   symtab_and_line sal = find_frame_sal (frame);
11855   if (sal.symtab == NULL)
11856     return 1;
11857
11858   /* If there is a symtab, but the associated source file cannot be
11859      located, then assume this is not user code:  Selecting a frame
11860      for which we cannot display the code would not be very helpful
11861      for the user.  This should also take care of case such as VxWorks
11862      where the kernel has some debugging info provided for a few units.  */
11863
11864   fullname = symtab_to_fullname (sal.symtab);
11865   if (access (fullname, R_OK) != 0)
11866     return 1;
11867
11868   /* Check the unit filename against the Ada runtime file naming.
11869      We also check the name of the objfile against the name of some
11870      known system libraries that sometimes come with debugging info
11871      too.  */
11872
11873   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11874     {
11875       re_comp (known_runtime_file_name_patterns[i]);
11876       if (re_exec (lbasename (sal.symtab->filename)))
11877         return 1;
11878       if (sal.symtab->compunit ()->objfile () != NULL
11879           && re_exec (objfile_name (sal.symtab->compunit ()->objfile ())))
11880         return 1;
11881     }
11882
11883   /* Check whether the function is a GNAT-generated entity.  */
11884
11885   gdb::unique_xmalloc_ptr<char> func_name
11886     = find_frame_funname (frame, &func_lang, NULL);
11887   if (func_name == NULL)
11888     return 1;
11889
11890   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11891     {
11892       re_comp (known_auxiliary_function_name_patterns[i]);
11893       if (re_exec (func_name.get ()))
11894         return 1;
11895     }
11896
11897   return 0;
11898 }
11899
11900 /* Find the first frame that contains debugging information and that is not
11901    part of the Ada run-time, starting from FI and moving upward.  */
11902
11903 void
11904 ada_find_printable_frame (struct frame_info *fi)
11905 {
11906   for (; fi != NULL; fi = get_prev_frame (fi))
11907     {
11908       if (!is_known_support_routine (fi))
11909         {
11910           select_frame (fi);
11911           break;
11912         }
11913     }
11914
11915 }
11916
11917 /* Assuming that the inferior just triggered an unhandled exception
11918    catchpoint, return the address in inferior memory where the name
11919    of the exception is stored.
11920    
11921    Return zero if the address could not be computed.  */
11922
11923 static CORE_ADDR
11924 ada_unhandled_exception_name_addr (void)
11925 {
11926   return parse_and_eval_address ("e.full_name");
11927 }
11928
11929 /* Same as ada_unhandled_exception_name_addr, except that this function
11930    should be used when the inferior uses an older version of the runtime,
11931    where the exception name needs to be extracted from a specific frame
11932    several frames up in the callstack.  */
11933
11934 static CORE_ADDR
11935 ada_unhandled_exception_name_addr_from_raise (void)
11936 {
11937   int frame_level;
11938   struct frame_info *fi;
11939   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11940
11941   /* To determine the name of this exception, we need to select
11942      the frame corresponding to RAISE_SYM_NAME.  This frame is
11943      at least 3 levels up, so we simply skip the first 3 frames
11944      without checking the name of their associated function.  */
11945   fi = get_current_frame ();
11946   for (frame_level = 0; frame_level < 3; frame_level += 1)
11947     if (fi != NULL)
11948       fi = get_prev_frame (fi); 
11949
11950   while (fi != NULL)
11951     {
11952       enum language func_lang;
11953
11954       gdb::unique_xmalloc_ptr<char> func_name
11955         = find_frame_funname (fi, &func_lang, NULL);
11956       if (func_name != NULL)
11957         {
11958           if (strcmp (func_name.get (),
11959                       data->exception_info->catch_exception_sym) == 0)
11960             break; /* We found the frame we were looking for...  */
11961         }
11962       fi = get_prev_frame (fi);
11963     }
11964
11965   if (fi == NULL)
11966     return 0;
11967
11968   select_frame (fi);
11969   return parse_and_eval_address ("id.full_name");
11970 }
11971
11972 /* Assuming the inferior just triggered an Ada exception catchpoint
11973    (of any type), return the address in inferior memory where the name
11974    of the exception is stored, if applicable.
11975
11976    Assumes the selected frame is the current frame.
11977
11978    Return zero if the address could not be computed, or if not relevant.  */
11979
11980 static CORE_ADDR
11981 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex)
11982 {
11983   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11984
11985   switch (ex)
11986     {
11987       case ada_catch_exception:
11988         return (parse_and_eval_address ("e.full_name"));
11989         break;
11990
11991       case ada_catch_exception_unhandled:
11992         return data->exception_info->unhandled_exception_name_addr ();
11993         break;
11994
11995       case ada_catch_handlers:
11996         return 0;  /* The runtimes does not provide access to the exception
11997                       name.  */
11998         break;
11999
12000       case ada_catch_assert:
12001         return 0;  /* Exception name is not relevant in this case.  */
12002         break;
12003
12004       default:
12005         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12006         break;
12007     }
12008
12009   return 0; /* Should never be reached.  */
12010 }
12011
12012 /* Assuming the inferior is stopped at an exception catchpoint,
12013    return the message which was associated to the exception, if
12014    available.  Return NULL if the message could not be retrieved.
12015
12016    Note: The exception message can be associated to an exception
12017    either through the use of the Raise_Exception function, or
12018    more simply (Ada 2005 and later), via:
12019
12020        raise Exception_Name with "exception message";
12021
12022    */
12023
12024 static gdb::unique_xmalloc_ptr<char>
12025 ada_exception_message_1 (void)
12026 {
12027   struct value *e_msg_val;
12028   int e_msg_len;
12029
12030   /* For runtimes that support this feature, the exception message
12031      is passed as an unbounded string argument called "message".  */
12032   e_msg_val = parse_and_eval ("message");
12033   if (e_msg_val == NULL)
12034     return NULL; /* Exception message not supported.  */
12035
12036   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12037   gdb_assert (e_msg_val != NULL);
12038   e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12039
12040   /* If the message string is empty, then treat it as if there was
12041      no exception message.  */
12042   if (e_msg_len <= 0)
12043     return NULL;
12044
12045   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12046   read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
12047                e_msg_len);
12048   e_msg.get ()[e_msg_len] = '\0';
12049
12050   return e_msg;
12051 }
12052
12053 /* Same as ada_exception_message_1, except that all exceptions are
12054    contained here (returning NULL instead).  */
12055
12056 static gdb::unique_xmalloc_ptr<char>
12057 ada_exception_message (void)
12058 {
12059   gdb::unique_xmalloc_ptr<char> e_msg;
12060
12061   try
12062     {
12063       e_msg = ada_exception_message_1 ();
12064     }
12065   catch (const gdb_exception_error &e)
12066     {
12067       e_msg.reset (nullptr);
12068     }
12069
12070   return e_msg;
12071 }
12072
12073 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12074    any error that ada_exception_name_addr_1 might cause to be thrown.
12075    When an error is intercepted, a warning with the error message is printed,
12076    and zero is returned.  */
12077
12078 static CORE_ADDR
12079 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex)
12080 {
12081   CORE_ADDR result = 0;
12082
12083   try
12084     {
12085       result = ada_exception_name_addr_1 (ex);
12086     }
12087
12088   catch (const gdb_exception_error &e)
12089     {
12090       warning (_("failed to get exception name: %s"), e.what ());
12091       return 0;
12092     }
12093
12094   return result;
12095 }
12096
12097 static std::string ada_exception_catchpoint_cond_string
12098   (const char *excep_string,
12099    enum ada_exception_catchpoint_kind ex);
12100
12101 /* Ada catchpoints.
12102
12103    In the case of catchpoints on Ada exceptions, the catchpoint will
12104    stop the target on every exception the program throws.  When a user
12105    specifies the name of a specific exception, we translate this
12106    request into a condition expression (in text form), and then parse
12107    it into an expression stored in each of the catchpoint's locations.
12108    We then use this condition to check whether the exception that was
12109    raised is the one the user is interested in.  If not, then the
12110    target is resumed again.  We store the name of the requested
12111    exception, in order to be able to re-set the condition expression
12112    when symbols change.  */
12113
12114 /* An instance of this type is used to represent an Ada catchpoint.  */
12115
12116 struct ada_catchpoint : public code_breakpoint
12117 {
12118   ada_catchpoint (struct gdbarch *gdbarch_,
12119                   enum ada_exception_catchpoint_kind kind,
12120                   struct symtab_and_line sal,
12121                   const char *addr_string_,
12122                   bool tempflag,
12123                   bool enabled,
12124                   bool from_tty)
12125     : code_breakpoint (gdbarch_, bp_catchpoint),
12126       m_kind (kind)
12127   {
12128     add_location (sal);
12129
12130     /* Unlike most code_breakpoint types, Ada catchpoints are
12131        pspace-specific.  */
12132     gdb_assert (sal.pspace != nullptr);
12133     this->pspace = sal.pspace;
12134
12135     if (from_tty)
12136       {
12137         struct gdbarch *loc_gdbarch = get_sal_arch (sal);
12138         if (!loc_gdbarch)
12139           loc_gdbarch = gdbarch;
12140
12141         describe_other_breakpoints (loc_gdbarch,
12142                                     sal.pspace, sal.pc, sal.section, -1);
12143         /* FIXME: brobecker/2006-12-28: Actually, re-implement a special
12144            version for exception catchpoints, because two catchpoints
12145            used for different exception names will use the same address.
12146            In this case, a "breakpoint ... also set at..." warning is
12147            unproductive.  Besides, the warning phrasing is also a bit
12148            inappropriate, we should use the word catchpoint, and tell
12149            the user what type of catchpoint it is.  The above is good
12150            enough for now, though.  */
12151       }
12152
12153     enable_state = enabled ? bp_enabled : bp_disabled;
12154     disposition = tempflag ? disp_del : disp_donttouch;
12155     locspec = string_to_location_spec (&addr_string_,
12156                                        language_def (language_ada));
12157     language = language_ada;
12158   }
12159
12160   struct bp_location *allocate_location () override;
12161   void re_set () override;
12162   void check_status (struct bpstat *bs) override;
12163   enum print_stop_action print_it (const bpstat *bs) const override;
12164   bool print_one (bp_location **) const override;
12165   void print_mention () const override;
12166   void print_recreate (struct ui_file *fp) const override;
12167
12168   /* The name of the specific exception the user specified.  */
12169   std::string excep_string;
12170
12171   /* What kind of catchpoint this is.  */
12172   enum ada_exception_catchpoint_kind m_kind;
12173 };
12174
12175 /* An instance of this type is used to represent an Ada catchpoint
12176    breakpoint location.  */
12177
12178 class ada_catchpoint_location : public bp_location
12179 {
12180 public:
12181   explicit ada_catchpoint_location (ada_catchpoint *owner)
12182     : bp_location (owner, bp_loc_software_breakpoint)
12183   {}
12184
12185   /* The condition that checks whether the exception that was raised
12186      is the specific exception the user specified on catchpoint
12187      creation.  */
12188   expression_up excep_cond_expr;
12189 };
12190
12191 /* Parse the exception condition string in the context of each of the
12192    catchpoint's locations, and store them for later evaluation.  */
12193
12194 static void
12195 create_excep_cond_exprs (struct ada_catchpoint *c,
12196                          enum ada_exception_catchpoint_kind ex)
12197 {
12198   /* Nothing to do if there's no specific exception to catch.  */
12199   if (c->excep_string.empty ())
12200     return;
12201
12202   /* Same if there are no locations... */
12203   if (c->loc == NULL)
12204     return;
12205
12206   /* Compute the condition expression in text form, from the specific
12207      expection we want to catch.  */
12208   std::string cond_string
12209     = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
12210
12211   /* Iterate over all the catchpoint's locations, and parse an
12212      expression for each.  */
12213   for (bp_location *bl : c->locations ())
12214     {
12215       struct ada_catchpoint_location *ada_loc
12216         = (struct ada_catchpoint_location *) bl;
12217       expression_up exp;
12218
12219       if (!bl->shlib_disabled)
12220         {
12221           const char *s;
12222
12223           s = cond_string.c_str ();
12224           try
12225             {
12226               exp = parse_exp_1 (&s, bl->address,
12227                                  block_for_pc (bl->address),
12228                                  0);
12229             }
12230           catch (const gdb_exception_error &e)
12231             {
12232               warning (_("failed to reevaluate internal exception condition "
12233                          "for catchpoint %d: %s"),
12234                        c->number, e.what ());
12235             }
12236         }
12237
12238       ada_loc->excep_cond_expr = std::move (exp);
12239     }
12240 }
12241
12242 /* Implement the ALLOCATE_LOCATION method in the structure for all
12243    exception catchpoint kinds.  */
12244
12245 struct bp_location *
12246 ada_catchpoint::allocate_location ()
12247 {
12248   return new ada_catchpoint_location (this);
12249 }
12250
12251 /* Implement the RE_SET method in the structure for all exception
12252    catchpoint kinds.  */
12253
12254 void
12255 ada_catchpoint::re_set ()
12256 {
12257   /* Call the base class's method.  This updates the catchpoint's
12258      locations.  */
12259   this->code_breakpoint::re_set ();
12260
12261   /* Reparse the exception conditional expressions.  One for each
12262      location.  */
12263   create_excep_cond_exprs (this, m_kind);
12264 }
12265
12266 /* Returns true if we should stop for this breakpoint hit.  If the
12267    user specified a specific exception, we only want to cause a stop
12268    if the program thrown that exception.  */
12269
12270 static bool
12271 should_stop_exception (const struct bp_location *bl)
12272 {
12273   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12274   const struct ada_catchpoint_location *ada_loc
12275     = (const struct ada_catchpoint_location *) bl;
12276   bool stop;
12277
12278   struct internalvar *var = lookup_internalvar ("_ada_exception");
12279   if (c->m_kind == ada_catch_assert)
12280     clear_internalvar (var);
12281   else
12282     {
12283       try
12284         {
12285           const char *expr;
12286
12287           if (c->m_kind == ada_catch_handlers)
12288             expr = ("GNAT_GCC_exception_Access(gcc_exception)"
12289                     ".all.occurrence.id");
12290           else
12291             expr = "e";
12292
12293           struct value *exc = parse_and_eval (expr);
12294           set_internalvar (var, exc);
12295         }
12296       catch (const gdb_exception_error &ex)
12297         {
12298           clear_internalvar (var);
12299         }
12300     }
12301
12302   /* With no specific exception, should always stop.  */
12303   if (c->excep_string.empty ())
12304     return true;
12305
12306   if (ada_loc->excep_cond_expr == NULL)
12307     {
12308       /* We will have a NULL expression if back when we were creating
12309          the expressions, this location's had failed to parse.  */
12310       return true;
12311     }
12312
12313   stop = true;
12314   try
12315     {
12316       struct value *mark;
12317
12318       mark = value_mark ();
12319       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12320       value_free_to_mark (mark);
12321     }
12322   catch (const gdb_exception &ex)
12323     {
12324       exception_fprintf (gdb_stderr, ex,
12325                          _("Error in testing exception condition:\n"));
12326     }
12327
12328   return stop;
12329 }
12330
12331 /* Implement the CHECK_STATUS method in the structure for all
12332    exception catchpoint kinds.  */
12333
12334 void
12335 ada_catchpoint::check_status (bpstat *bs)
12336 {
12337   bs->stop = should_stop_exception (bs->bp_location_at.get ());
12338 }
12339
12340 /* Implement the PRINT_IT method in the structure for all exception
12341    catchpoint kinds.  */
12342
12343 enum print_stop_action
12344 ada_catchpoint::print_it (const bpstat *bs) const
12345 {
12346   struct ui_out *uiout = current_uiout;
12347
12348   annotate_catchpoint (number);
12349
12350   if (uiout->is_mi_like_p ())
12351     {
12352       uiout->field_string ("reason",
12353                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12354       uiout->field_string ("disp", bpdisp_text (disposition));
12355     }
12356
12357   uiout->text (disposition == disp_del
12358                ? "\nTemporary catchpoint " : "\nCatchpoint ");
12359   uiout->field_signed ("bkptno", number);
12360   uiout->text (", ");
12361
12362   /* ada_exception_name_addr relies on the selected frame being the
12363      current frame.  Need to do this here because this function may be
12364      called more than once when printing a stop, and below, we'll
12365      select the first frame past the Ada run-time (see
12366      ada_find_printable_frame).  */
12367   select_frame (get_current_frame ());
12368
12369   switch (m_kind)
12370     {
12371       case ada_catch_exception:
12372       case ada_catch_exception_unhandled:
12373       case ada_catch_handlers:
12374         {
12375           const CORE_ADDR addr = ada_exception_name_addr (m_kind);
12376           char exception_name[256];
12377
12378           if (addr != 0)
12379             {
12380               read_memory (addr, (gdb_byte *) exception_name,
12381                            sizeof (exception_name) - 1);
12382               exception_name [sizeof (exception_name) - 1] = '\0';
12383             }
12384           else
12385             {
12386               /* For some reason, we were unable to read the exception
12387                  name.  This could happen if the Runtime was compiled
12388                  without debugging info, for instance.  In that case,
12389                  just replace the exception name by the generic string
12390                  "exception" - it will read as "an exception" in the
12391                  notification we are about to print.  */
12392               memcpy (exception_name, "exception", sizeof ("exception"));
12393             }
12394           /* In the case of unhandled exception breakpoints, we print
12395              the exception name as "unhandled EXCEPTION_NAME", to make
12396              it clearer to the user which kind of catchpoint just got
12397              hit.  We used ui_out_text to make sure that this extra
12398              info does not pollute the exception name in the MI case.  */
12399           if (m_kind == ada_catch_exception_unhandled)
12400             uiout->text ("unhandled ");
12401           uiout->field_string ("exception-name", exception_name);
12402         }
12403         break;
12404       case ada_catch_assert:
12405         /* In this case, the name of the exception is not really
12406            important.  Just print "failed assertion" to make it clearer
12407            that his program just hit an assertion-failure catchpoint.
12408            We used ui_out_text because this info does not belong in
12409            the MI output.  */
12410         uiout->text ("failed assertion");
12411         break;
12412     }
12413
12414   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12415   if (exception_message != NULL)
12416     {
12417       uiout->text (" (");
12418       uiout->field_string ("exception-message", exception_message.get ());
12419       uiout->text (")");
12420     }
12421
12422   uiout->text (" at ");
12423   ada_find_printable_frame (get_current_frame ());
12424
12425   return PRINT_SRC_AND_LOC;
12426 }
12427
12428 /* Implement the PRINT_ONE method in the structure for all exception
12429    catchpoint kinds.  */
12430
12431 bool
12432 ada_catchpoint::print_one (bp_location **last_loc) const
12433
12434   struct ui_out *uiout = current_uiout;
12435   struct value_print_options opts;
12436
12437   get_user_print_options (&opts);
12438
12439   if (opts.addressprint)
12440     uiout->field_skip ("addr");
12441
12442   annotate_field (5);
12443   switch (m_kind)
12444     {
12445       case ada_catch_exception:
12446         if (!excep_string.empty ())
12447           {
12448             std::string msg = string_printf (_("`%s' Ada exception"),
12449                                              excep_string.c_str ());
12450
12451             uiout->field_string ("what", msg);
12452           }
12453         else
12454           uiout->field_string ("what", "all Ada exceptions");
12455         
12456         break;
12457
12458       case ada_catch_exception_unhandled:
12459         uiout->field_string ("what", "unhandled Ada exceptions");
12460         break;
12461       
12462       case ada_catch_handlers:
12463         if (!excep_string.empty ())
12464           {
12465             uiout->field_fmt ("what",
12466                               _("`%s' Ada exception handlers"),
12467                               excep_string.c_str ());
12468           }
12469         else
12470           uiout->field_string ("what", "all Ada exceptions handlers");
12471         break;
12472
12473       case ada_catch_assert:
12474         uiout->field_string ("what", "failed Ada assertions");
12475         break;
12476
12477       default:
12478         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12479         break;
12480     }
12481
12482   return true;
12483 }
12484
12485 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12486    for all exception catchpoint kinds.  */
12487
12488 void
12489 ada_catchpoint::print_mention () const
12490 {
12491   struct ui_out *uiout = current_uiout;
12492
12493   uiout->text (disposition == disp_del ? _("Temporary catchpoint ")
12494                                                  : _("Catchpoint "));
12495   uiout->field_signed ("bkptno", number);
12496   uiout->text (": ");
12497
12498   switch (m_kind)
12499     {
12500       case ada_catch_exception:
12501         if (!excep_string.empty ())
12502           {
12503             std::string info = string_printf (_("`%s' Ada exception"),
12504                                               excep_string.c_str ());
12505             uiout->text (info);
12506           }
12507         else
12508           uiout->text (_("all Ada exceptions"));
12509         break;
12510
12511       case ada_catch_exception_unhandled:
12512         uiout->text (_("unhandled Ada exceptions"));
12513         break;
12514
12515       case ada_catch_handlers:
12516         if (!excep_string.empty ())
12517           {
12518             std::string info
12519               = string_printf (_("`%s' Ada exception handlers"),
12520                                excep_string.c_str ());
12521             uiout->text (info);
12522           }
12523         else
12524           uiout->text (_("all Ada exceptions handlers"));
12525         break;
12526
12527       case ada_catch_assert:
12528         uiout->text (_("failed Ada assertions"));
12529         break;
12530
12531       default:
12532         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12533         break;
12534     }
12535 }
12536
12537 /* Implement the PRINT_RECREATE method in the structure for all
12538    exception catchpoint kinds.  */
12539
12540 void
12541 ada_catchpoint::print_recreate (struct ui_file *fp) const
12542 {
12543   switch (m_kind)
12544     {
12545       case ada_catch_exception:
12546         gdb_printf (fp, "catch exception");
12547         if (!excep_string.empty ())
12548           gdb_printf (fp, " %s", excep_string.c_str ());
12549         break;
12550
12551       case ada_catch_exception_unhandled:
12552         gdb_printf (fp, "catch exception unhandled");
12553         break;
12554
12555       case ada_catch_handlers:
12556         gdb_printf (fp, "catch handlers");
12557         break;
12558
12559       case ada_catch_assert:
12560         gdb_printf (fp, "catch assert");
12561         break;
12562
12563       default:
12564         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12565     }
12566   print_recreate_thread (fp);
12567 }
12568
12569 /* See ada-lang.h.  */
12570
12571 bool
12572 is_ada_exception_catchpoint (breakpoint *bp)
12573 {
12574   return dynamic_cast<ada_catchpoint *> (bp) != nullptr;
12575 }
12576
12577 /* Split the arguments specified in a "catch exception" command.  
12578    Set EX to the appropriate catchpoint type.
12579    Set EXCEP_STRING to the name of the specific exception if
12580    specified by the user.
12581    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12582    "catch handlers" command.  False otherwise.
12583    If a condition is found at the end of the arguments, the condition
12584    expression is stored in COND_STRING (memory must be deallocated
12585    after use).  Otherwise COND_STRING is set to NULL.  */
12586
12587 static void
12588 catch_ada_exception_command_split (const char *args,
12589                                    bool is_catch_handlers_cmd,
12590                                    enum ada_exception_catchpoint_kind *ex,
12591                                    std::string *excep_string,
12592                                    std::string *cond_string)
12593 {
12594   std::string exception_name;
12595
12596   exception_name = extract_arg (&args);
12597   if (exception_name == "if")
12598     {
12599       /* This is not an exception name; this is the start of a condition
12600          expression for a catchpoint on all exceptions.  So, "un-get"
12601          this token, and set exception_name to NULL.  */
12602       exception_name.clear ();
12603       args -= 2;
12604     }
12605
12606   /* Check to see if we have a condition.  */
12607
12608   args = skip_spaces (args);
12609   if (startswith (args, "if")
12610       && (isspace (args[2]) || args[2] == '\0'))
12611     {
12612       args += 2;
12613       args = skip_spaces (args);
12614
12615       if (args[0] == '\0')
12616         error (_("Condition missing after `if' keyword"));
12617       *cond_string = args;
12618
12619       args += strlen (args);
12620     }
12621
12622   /* Check that we do not have any more arguments.  Anything else
12623      is unexpected.  */
12624
12625   if (args[0] != '\0')
12626     error (_("Junk at end of expression"));
12627
12628   if (is_catch_handlers_cmd)
12629     {
12630       /* Catch handling of exceptions.  */
12631       *ex = ada_catch_handlers;
12632       *excep_string = exception_name;
12633     }
12634   else if (exception_name.empty ())
12635     {
12636       /* Catch all exceptions.  */
12637       *ex = ada_catch_exception;
12638       excep_string->clear ();
12639     }
12640   else if (exception_name == "unhandled")
12641     {
12642       /* Catch unhandled exceptions.  */
12643       *ex = ada_catch_exception_unhandled;
12644       excep_string->clear ();
12645     }
12646   else
12647     {
12648       /* Catch a specific exception.  */
12649       *ex = ada_catch_exception;
12650       *excep_string = exception_name;
12651     }
12652 }
12653
12654 /* Return the name of the symbol on which we should break in order to
12655    implement a catchpoint of the EX kind.  */
12656
12657 static const char *
12658 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12659 {
12660   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12661
12662   gdb_assert (data->exception_info != NULL);
12663
12664   switch (ex)
12665     {
12666       case ada_catch_exception:
12667         return (data->exception_info->catch_exception_sym);
12668         break;
12669       case ada_catch_exception_unhandled:
12670         return (data->exception_info->catch_exception_unhandled_sym);
12671         break;
12672       case ada_catch_assert:
12673         return (data->exception_info->catch_assert_sym);
12674         break;
12675       case ada_catch_handlers:
12676         return (data->exception_info->catch_handlers_sym);
12677         break;
12678       default:
12679         internal_error (__FILE__, __LINE__,
12680                         _("unexpected catchpoint kind (%d)"), ex);
12681     }
12682 }
12683
12684 /* Return the condition that will be used to match the current exception
12685    being raised with the exception that the user wants to catch.  This
12686    assumes that this condition is used when the inferior just triggered
12687    an exception catchpoint.
12688    EX: the type of catchpoints used for catching Ada exceptions.  */
12689
12690 static std::string
12691 ada_exception_catchpoint_cond_string (const char *excep_string,
12692                                       enum ada_exception_catchpoint_kind ex)
12693 {
12694   bool is_standard_exc = false;
12695   std::string result;
12696
12697   if (ex == ada_catch_handlers)
12698     {
12699       /* For exception handlers catchpoints, the condition string does
12700          not use the same parameter as for the other exceptions.  */
12701       result = ("long_integer (GNAT_GCC_exception_Access"
12702                 "(gcc_exception).all.occurrence.id)");
12703     }
12704   else
12705     result = "long_integer (e)";
12706
12707   /* The standard exceptions are a special case.  They are defined in
12708      runtime units that have been compiled without debugging info; if
12709      EXCEP_STRING is the not-fully-qualified name of a standard
12710      exception (e.g. "constraint_error") then, during the evaluation
12711      of the condition expression, the symbol lookup on this name would
12712      *not* return this standard exception.  The catchpoint condition
12713      may then be set only on user-defined exceptions which have the
12714      same not-fully-qualified name (e.g. my_package.constraint_error).
12715
12716      To avoid this unexcepted behavior, these standard exceptions are
12717      systematically prefixed by "standard".  This means that "catch
12718      exception constraint_error" is rewritten into "catch exception
12719      standard.constraint_error".
12720
12721      If an exception named constraint_error is defined in another package of
12722      the inferior program, then the only way to specify this exception as a
12723      breakpoint condition is to use its fully-qualified named:
12724      e.g. my_package.constraint_error.  */
12725
12726   for (const char *name : standard_exc)
12727     {
12728       if (strcmp (name, excep_string) == 0)
12729         {
12730           is_standard_exc = true;
12731           break;
12732         }
12733     }
12734
12735   result += " = ";
12736
12737   if (is_standard_exc)
12738     string_appendf (result, "long_integer (&standard.%s)", excep_string);
12739   else
12740     string_appendf (result, "long_integer (&%s)", excep_string);
12741
12742   return result;
12743 }
12744
12745 /* Return the symtab_and_line that should be used to insert an exception
12746    catchpoint of the TYPE kind.
12747
12748    ADDR_STRING returns the name of the function where the real
12749    breakpoint that implements the catchpoints is set, depending on the
12750    type of catchpoint we need to create.  */
12751
12752 static struct symtab_and_line
12753 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12754                    std::string *addr_string)
12755 {
12756   const char *sym_name;
12757   struct symbol *sym;
12758
12759   /* First, find out which exception support info to use.  */
12760   ada_exception_support_info_sniffer ();
12761
12762   /* Then lookup the function on which we will break in order to catch
12763      the Ada exceptions requested by the user.  */
12764   sym_name = ada_exception_sym_name (ex);
12765   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12766
12767   if (sym == NULL)
12768     error (_("Catchpoint symbol not found: %s"), sym_name);
12769
12770   if (sym->aclass () != LOC_BLOCK)
12771     error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12772
12773   /* Set ADDR_STRING.  */
12774   *addr_string = sym_name;
12775
12776   return find_function_start_sal (sym, 1);
12777 }
12778
12779 /* Create an Ada exception catchpoint.
12780
12781    EX_KIND is the kind of exception catchpoint to be created.
12782
12783    If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12784    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
12785    of the exception to which this catchpoint applies.
12786
12787    COND_STRING, if not empty, is the catchpoint condition.
12788
12789    TEMPFLAG, if nonzero, means that the underlying breakpoint
12790    should be temporary.
12791
12792    FROM_TTY is the usual argument passed to all commands implementations.  */
12793
12794 void
12795 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12796                                  enum ada_exception_catchpoint_kind ex_kind,
12797                                  const std::string &excep_string,
12798                                  const std::string &cond_string,
12799                                  int tempflag,
12800                                  int disabled,
12801                                  int from_tty)
12802 {
12803   std::string addr_string;
12804   struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string);
12805
12806   std::unique_ptr<ada_catchpoint> c
12807     (new ada_catchpoint (gdbarch, ex_kind, sal, addr_string.c_str (),
12808                          tempflag, disabled, from_tty));
12809   c->excep_string = excep_string;
12810   create_excep_cond_exprs (c.get (), ex_kind);
12811   if (!cond_string.empty ())
12812     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12813   install_breakpoint (0, std::move (c), 1);
12814 }
12815
12816 /* Implement the "catch exception" command.  */
12817
12818 static void
12819 catch_ada_exception_command (const char *arg_entry, int from_tty,
12820                              struct cmd_list_element *command)
12821 {
12822   const char *arg = arg_entry;
12823   struct gdbarch *gdbarch = get_current_arch ();
12824   int tempflag;
12825   enum ada_exception_catchpoint_kind ex_kind;
12826   std::string excep_string;
12827   std::string cond_string;
12828
12829   tempflag = command->context () == CATCH_TEMPORARY;
12830
12831   if (!arg)
12832     arg = "";
12833   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12834                                      &cond_string);
12835   create_ada_exception_catchpoint (gdbarch, ex_kind,
12836                                    excep_string, cond_string,
12837                                    tempflag, 1 /* enabled */,
12838                                    from_tty);
12839 }
12840
12841 /* Implement the "catch handlers" command.  */
12842
12843 static void
12844 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12845                             struct cmd_list_element *command)
12846 {
12847   const char *arg = arg_entry;
12848   struct gdbarch *gdbarch = get_current_arch ();
12849   int tempflag;
12850   enum ada_exception_catchpoint_kind ex_kind;
12851   std::string excep_string;
12852   std::string cond_string;
12853
12854   tempflag = command->context () == CATCH_TEMPORARY;
12855
12856   if (!arg)
12857     arg = "";
12858   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12859                                      &cond_string);
12860   create_ada_exception_catchpoint (gdbarch, ex_kind,
12861                                    excep_string, cond_string,
12862                                    tempflag, 1 /* enabled */,
12863                                    from_tty);
12864 }
12865
12866 /* Completion function for the Ada "catch" commands.  */
12867
12868 static void
12869 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12870                      const char *text, const char *word)
12871 {
12872   std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12873
12874   for (const ada_exc_info &info : exceptions)
12875     {
12876       if (startswith (info.name, word))
12877         tracker.add_completion (make_unique_xstrdup (info.name));
12878     }
12879 }
12880
12881 /* Split the arguments specified in a "catch assert" command.
12882
12883    ARGS contains the command's arguments (or the empty string if
12884    no arguments were passed).
12885
12886    If ARGS contains a condition, set COND_STRING to that condition
12887    (the memory needs to be deallocated after use).  */
12888
12889 static void
12890 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12891 {
12892   args = skip_spaces (args);
12893
12894   /* Check whether a condition was provided.  */
12895   if (startswith (args, "if")
12896       && (isspace (args[2]) || args[2] == '\0'))
12897     {
12898       args += 2;
12899       args = skip_spaces (args);
12900       if (args[0] == '\0')
12901         error (_("condition missing after `if' keyword"));
12902       cond_string.assign (args);
12903     }
12904
12905   /* Otherwise, there should be no other argument at the end of
12906      the command.  */
12907   else if (args[0] != '\0')
12908     error (_("Junk at end of arguments."));
12909 }
12910
12911 /* Implement the "catch assert" command.  */
12912
12913 static void
12914 catch_assert_command (const char *arg_entry, int from_tty,
12915                       struct cmd_list_element *command)
12916 {
12917   const char *arg = arg_entry;
12918   struct gdbarch *gdbarch = get_current_arch ();
12919   int tempflag;
12920   std::string cond_string;
12921
12922   tempflag = command->context () == CATCH_TEMPORARY;
12923
12924   if (!arg)
12925     arg = "";
12926   catch_ada_assert_command_split (arg, cond_string);
12927   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12928                                    "", cond_string,
12929                                    tempflag, 1 /* enabled */,
12930                                    from_tty);
12931 }
12932
12933 /* Return non-zero if the symbol SYM is an Ada exception object.  */
12934
12935 static int
12936 ada_is_exception_sym (struct symbol *sym)
12937 {
12938   const char *type_name = sym->type ()->name ();
12939
12940   return (sym->aclass () != LOC_TYPEDEF
12941           && sym->aclass () != LOC_BLOCK
12942           && sym->aclass () != LOC_CONST
12943           && sym->aclass () != LOC_UNRESOLVED
12944           && type_name != NULL && strcmp (type_name, "exception") == 0);
12945 }
12946
12947 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12948    Ada exception object.  This matches all exceptions except the ones
12949    defined by the Ada language.  */
12950
12951 static int
12952 ada_is_non_standard_exception_sym (struct symbol *sym)
12953 {
12954   if (!ada_is_exception_sym (sym))
12955     return 0;
12956
12957   for (const char *name : standard_exc)
12958     if (strcmp (sym->linkage_name (), name) == 0)
12959       return 0;  /* A standard exception.  */
12960
12961   /* Numeric_Error is also a standard exception, so exclude it.
12962      See the STANDARD_EXC description for more details as to why
12963      this exception is not listed in that array.  */
12964   if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12965     return 0;
12966
12967   return 1;
12968 }
12969
12970 /* A helper function for std::sort, comparing two struct ada_exc_info
12971    objects.
12972
12973    The comparison is determined first by exception name, and then
12974    by exception address.  */
12975
12976 bool
12977 ada_exc_info::operator< (const ada_exc_info &other) const
12978 {
12979   int result;
12980
12981   result = strcmp (name, other.name);
12982   if (result < 0)
12983     return true;
12984   if (result == 0 && addr < other.addr)
12985     return true;
12986   return false;
12987 }
12988
12989 bool
12990 ada_exc_info::operator== (const ada_exc_info &other) const
12991 {
12992   return addr == other.addr && strcmp (name, other.name) == 0;
12993 }
12994
12995 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12996    routine, but keeping the first SKIP elements untouched.
12997
12998    All duplicates are also removed.  */
12999
13000 static void
13001 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
13002                                       int skip)
13003 {
13004   std::sort (exceptions->begin () + skip, exceptions->end ());
13005   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13006                      exceptions->end ());
13007 }
13008
13009 /* Add all exceptions defined by the Ada standard whose name match
13010    a regular expression.
13011
13012    If PREG is not NULL, then this regexp_t object is used to
13013    perform the symbol name matching.  Otherwise, no name-based
13014    filtering is performed.
13015
13016    EXCEPTIONS is a vector of exceptions to which matching exceptions
13017    gets pushed.  */
13018
13019 static void
13020 ada_add_standard_exceptions (compiled_regex *preg,
13021                              std::vector<ada_exc_info> *exceptions)
13022 {
13023   for (const char *name : standard_exc)
13024     {
13025       if (preg == NULL || preg->exec (name, 0, NULL, 0) == 0)
13026         {
13027           struct bound_minimal_symbol msymbol
13028             = ada_lookup_simple_minsym (name);
13029
13030           if (msymbol.minsym != NULL)
13031             {
13032               struct ada_exc_info info
13033                 = {name, msymbol.value_address ()};
13034
13035               exceptions->push_back (info);
13036             }
13037         }
13038     }
13039 }
13040
13041 /* Add all Ada exceptions defined locally and accessible from the given
13042    FRAME.
13043
13044    If PREG is not NULL, then this regexp_t object is used to
13045    perform the symbol name matching.  Otherwise, no name-based
13046    filtering is performed.
13047
13048    EXCEPTIONS is a vector of exceptions to which matching exceptions
13049    gets pushed.  */
13050
13051 static void
13052 ada_add_exceptions_from_frame (compiled_regex *preg,
13053                                struct frame_info *frame,
13054                                std::vector<ada_exc_info> *exceptions)
13055 {
13056   const struct block *block = get_frame_block (frame, 0);
13057
13058   while (block != 0)
13059     {
13060       struct block_iterator iter;
13061       struct symbol *sym;
13062
13063       ALL_BLOCK_SYMBOLS (block, iter, sym)
13064         {
13065           switch (sym->aclass ())
13066             {
13067             case LOC_TYPEDEF:
13068             case LOC_BLOCK:
13069             case LOC_CONST:
13070               break;
13071             default:
13072               if (ada_is_exception_sym (sym))
13073                 {
13074                   struct ada_exc_info info = {sym->print_name (),
13075                                               sym->value_address ()};
13076
13077                   exceptions->push_back (info);
13078                 }
13079             }
13080         }
13081       if (block->function () != NULL)
13082         break;
13083       block = block->superblock ();
13084     }
13085 }
13086
13087 /* Return true if NAME matches PREG or if PREG is NULL.  */
13088
13089 static bool
13090 name_matches_regex (const char *name, compiled_regex *preg)
13091 {
13092   return (preg == NULL
13093           || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
13094 }
13095
13096 /* Add all exceptions defined globally whose name name match
13097    a regular expression, excluding standard exceptions.
13098
13099    The reason we exclude standard exceptions is that they need
13100    to be handled separately: Standard exceptions are defined inside
13101    a runtime unit which is normally not compiled with debugging info,
13102    and thus usually do not show up in our symbol search.  However,
13103    if the unit was in fact built with debugging info, we need to
13104    exclude them because they would duplicate the entry we found
13105    during the special loop that specifically searches for those
13106    standard exceptions.
13107
13108    If PREG is not NULL, then this regexp_t object is used to
13109    perform the symbol name matching.  Otherwise, no name-based
13110    filtering is performed.
13111
13112    EXCEPTIONS is a vector of exceptions to which matching exceptions
13113    gets pushed.  */
13114
13115 static void
13116 ada_add_global_exceptions (compiled_regex *preg,
13117                            std::vector<ada_exc_info> *exceptions)
13118 {
13119   /* In Ada, the symbol "search name" is a linkage name, whereas the
13120      regular expression used to do the matching refers to the natural
13121      name.  So match against the decoded name.  */
13122   expand_symtabs_matching (NULL,
13123                            lookup_name_info::match_any (),
13124                            [&] (const char *search_name)
13125                            {
13126                              std::string decoded = ada_decode (search_name);
13127                              return name_matches_regex (decoded.c_str (), preg);
13128                            },
13129                            NULL,
13130                            SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13131                            VARIABLES_DOMAIN);
13132
13133   for (objfile *objfile : current_program_space->objfiles ())
13134     {
13135       for (compunit_symtab *s : objfile->compunits ())
13136         {
13137           const struct blockvector *bv = s->blockvector ();
13138           int i;
13139
13140           for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13141             {
13142               const struct block *b = bv->block (i);
13143               struct block_iterator iter;
13144               struct symbol *sym;
13145
13146               ALL_BLOCK_SYMBOLS (b, iter, sym)
13147                 if (ada_is_non_standard_exception_sym (sym)
13148                     && name_matches_regex (sym->natural_name (), preg))
13149                   {
13150                     struct ada_exc_info info
13151                       = {sym->print_name (), sym->value_address ()};
13152
13153                     exceptions->push_back (info);
13154                   }
13155             }
13156         }
13157     }
13158 }
13159
13160 /* Implements ada_exceptions_list with the regular expression passed
13161    as a regex_t, rather than a string.
13162
13163    If not NULL, PREG is used to filter out exceptions whose names
13164    do not match.  Otherwise, all exceptions are listed.  */
13165
13166 static std::vector<ada_exc_info>
13167 ada_exceptions_list_1 (compiled_regex *preg)
13168 {
13169   std::vector<ada_exc_info> result;
13170   int prev_len;
13171
13172   /* First, list the known standard exceptions.  These exceptions
13173      need to be handled separately, as they are usually defined in
13174      runtime units that have been compiled without debugging info.  */
13175
13176   ada_add_standard_exceptions (preg, &result);
13177
13178   /* Next, find all exceptions whose scope is local and accessible
13179      from the currently selected frame.  */
13180
13181   if (has_stack_frames ())
13182     {
13183       prev_len = result.size ();
13184       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13185                                      &result);
13186       if (result.size () > prev_len)
13187         sort_remove_dups_ada_exceptions_list (&result, prev_len);
13188     }
13189
13190   /* Add all exceptions whose scope is global.  */
13191
13192   prev_len = result.size ();
13193   ada_add_global_exceptions (preg, &result);
13194   if (result.size () > prev_len)
13195     sort_remove_dups_ada_exceptions_list (&result, prev_len);
13196
13197   return result;
13198 }
13199
13200 /* Return a vector of ada_exc_info.
13201
13202    If REGEXP is NULL, all exceptions are included in the result.
13203    Otherwise, it should contain a valid regular expression,
13204    and only the exceptions whose names match that regular expression
13205    are included in the result.
13206
13207    The exceptions are sorted in the following order:
13208      - Standard exceptions (defined by the Ada language), in
13209        alphabetical order;
13210      - Exceptions only visible from the current frame, in
13211        alphabetical order;
13212      - Exceptions whose scope is global, in alphabetical order.  */
13213
13214 std::vector<ada_exc_info>
13215 ada_exceptions_list (const char *regexp)
13216 {
13217   if (regexp == NULL)
13218     return ada_exceptions_list_1 (NULL);
13219
13220   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13221   return ada_exceptions_list_1 (&reg);
13222 }
13223
13224 /* Implement the "info exceptions" command.  */
13225
13226 static void
13227 info_exceptions_command (const char *regexp, int from_tty)
13228 {
13229   struct gdbarch *gdbarch = get_current_arch ();
13230
13231   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13232
13233   if (regexp != NULL)
13234     gdb_printf
13235       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13236   else
13237     gdb_printf (_("All defined Ada exceptions:\n"));
13238
13239   for (const ada_exc_info &info : exceptions)
13240     gdb_printf ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13241 }
13242
13243 \f
13244                                 /* Language vector */
13245
13246 /* symbol_name_matcher_ftype adapter for wild_match.  */
13247
13248 static bool
13249 do_wild_match (const char *symbol_search_name,
13250                const lookup_name_info &lookup_name,
13251                completion_match_result *comp_match_res)
13252 {
13253   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
13254 }
13255
13256 /* symbol_name_matcher_ftype adapter for full_match.  */
13257
13258 static bool
13259 do_full_match (const char *symbol_search_name,
13260                const lookup_name_info &lookup_name,
13261                completion_match_result *comp_match_res)
13262 {
13263   const char *lname = lookup_name.ada ().lookup_name ().c_str ();
13264
13265   /* If both symbols start with "_ada_", just let the loop below
13266      handle the comparison.  However, if only the symbol name starts
13267      with "_ada_", skip the prefix and let the match proceed as
13268      usual.  */
13269   if (startswith (symbol_search_name, "_ada_")
13270       && !startswith (lname, "_ada"))
13271     symbol_search_name += 5;
13272   /* Likewise for ghost entities.  */
13273   if (startswith (symbol_search_name, "___ghost_")
13274       && !startswith (lname, "___ghost_"))
13275     symbol_search_name += 9;
13276
13277   int uscore_count = 0;
13278   while (*lname != '\0')
13279     {
13280       if (*symbol_search_name != *lname)
13281         {
13282           if (*symbol_search_name == 'B' && uscore_count == 2
13283               && symbol_search_name[1] == '_')
13284             {
13285               symbol_search_name += 2;
13286               while (isdigit (*symbol_search_name))
13287                 ++symbol_search_name;
13288               if (symbol_search_name[0] == '_'
13289                   && symbol_search_name[1] == '_')
13290                 {
13291                   symbol_search_name += 2;
13292                   continue;
13293                 }
13294             }
13295           return false;
13296         }
13297
13298       if (*symbol_search_name == '_')
13299         ++uscore_count;
13300       else
13301         uscore_count = 0;
13302
13303       ++symbol_search_name;
13304       ++lname;
13305     }
13306
13307   return is_name_suffix (symbol_search_name);
13308 }
13309
13310 /* symbol_name_matcher_ftype for exact (verbatim) matches.  */
13311
13312 static bool
13313 do_exact_match (const char *symbol_search_name,
13314                 const lookup_name_info &lookup_name,
13315                 completion_match_result *comp_match_res)
13316 {
13317   return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
13318 }
13319
13320 /* Build the Ada lookup name for LOOKUP_NAME.  */
13321
13322 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
13323 {
13324   gdb::string_view user_name = lookup_name.name ();
13325
13326   if (!user_name.empty () && user_name[0] == '<')
13327     {
13328       if (user_name.back () == '>')
13329         m_encoded_name
13330           = gdb::to_string (user_name.substr (1, user_name.size () - 2));
13331       else
13332         m_encoded_name
13333           = gdb::to_string (user_name.substr (1, user_name.size () - 1));
13334       m_encoded_p = true;
13335       m_verbatim_p = true;
13336       m_wild_match_p = false;
13337       m_standard_p = false;
13338     }
13339   else
13340     {
13341       m_verbatim_p = false;
13342
13343       m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
13344
13345       if (!m_encoded_p)
13346         {
13347           const char *folded = ada_fold_name (user_name);
13348           m_encoded_name = ada_encode_1 (folded, false);
13349           if (m_encoded_name.empty ())
13350             m_encoded_name = gdb::to_string (user_name);
13351         }
13352       else
13353         m_encoded_name = gdb::to_string (user_name);
13354
13355       /* Handle the 'package Standard' special case.  See description
13356          of m_standard_p.  */
13357       if (startswith (m_encoded_name.c_str (), "standard__"))
13358         {
13359           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
13360           m_standard_p = true;
13361         }
13362       else
13363         m_standard_p = false;
13364
13365       /* If the name contains a ".", then the user is entering a fully
13366          qualified entity name, and the match must not be done in wild
13367          mode.  Similarly, if the user wants to complete what looks
13368          like an encoded name, the match must not be done in wild
13369          mode.  Also, in the standard__ special case always do
13370          non-wild matching.  */
13371       m_wild_match_p
13372         = (lookup_name.match_type () != symbol_name_match_type::FULL
13373            && !m_encoded_p
13374            && !m_standard_p
13375            && user_name.find ('.') == std::string::npos);
13376     }
13377 }
13378
13379 /* symbol_name_matcher_ftype method for Ada.  This only handles
13380    completion mode.  */
13381
13382 static bool
13383 ada_symbol_name_matches (const char *symbol_search_name,
13384                          const lookup_name_info &lookup_name,
13385                          completion_match_result *comp_match_res)
13386 {
13387   return lookup_name.ada ().matches (symbol_search_name,
13388                                      lookup_name.match_type (),
13389                                      comp_match_res);
13390 }
13391
13392 /* A name matcher that matches the symbol name exactly, with
13393    strcmp.  */
13394
13395 static bool
13396 literal_symbol_name_matcher (const char *symbol_search_name,
13397                              const lookup_name_info &lookup_name,
13398                              completion_match_result *comp_match_res)
13399 {
13400   gdb::string_view name_view = lookup_name.name ();
13401
13402   if (lookup_name.completion_mode ()
13403       ? (strncmp (symbol_search_name, name_view.data (),
13404                   name_view.size ()) == 0)
13405       : symbol_search_name == name_view)
13406     {
13407       if (comp_match_res != NULL)
13408         comp_match_res->set_match (symbol_search_name);
13409       return true;
13410     }
13411   else
13412     return false;
13413 }
13414
13415 /* Implement the "get_symbol_name_matcher" language_defn method for
13416    Ada.  */
13417
13418 static symbol_name_matcher_ftype *
13419 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
13420 {
13421   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
13422     return literal_symbol_name_matcher;
13423
13424   if (lookup_name.completion_mode ())
13425     return ada_symbol_name_matches;
13426   else
13427     {
13428       if (lookup_name.ada ().wild_match_p ())
13429         return do_wild_match;
13430       else if (lookup_name.ada ().verbatim_p ())
13431         return do_exact_match;
13432       else
13433         return do_full_match;
13434     }
13435 }
13436
13437 /* Class representing the Ada language.  */
13438
13439 class ada_language : public language_defn
13440 {
13441 public:
13442   ada_language ()
13443     : language_defn (language_ada)
13444   { /* Nothing.  */ }
13445
13446   /* See language.h.  */
13447
13448   const char *name () const override
13449   { return "ada"; }
13450
13451   /* See language.h.  */
13452
13453   const char *natural_name () const override
13454   { return "Ada"; }
13455
13456   /* See language.h.  */
13457
13458   const std::vector<const char *> &filename_extensions () const override
13459   {
13460     static const std::vector<const char *> extensions
13461       = { ".adb", ".ads", ".a", ".ada", ".dg" };
13462     return extensions;
13463   }
13464
13465   /* Print an array element index using the Ada syntax.  */
13466
13467   void print_array_index (struct type *index_type,
13468                           LONGEST index,
13469                           struct ui_file *stream,
13470                           const value_print_options *options) const override
13471   {
13472     struct value *index_value = val_atr (index_type, index);
13473
13474     value_print (index_value, stream, options);
13475     gdb_printf (stream, " => ");
13476   }
13477
13478   /* Implement the "read_var_value" language_defn method for Ada.  */
13479
13480   struct value *read_var_value (struct symbol *var,
13481                                 const struct block *var_block,
13482                                 struct frame_info *frame) const override
13483   {
13484     /* The only case where default_read_var_value is not sufficient
13485        is when VAR is a renaming...  */
13486     if (frame != nullptr)
13487       {
13488         const struct block *frame_block = get_frame_block (frame, NULL);
13489         if (frame_block != nullptr && ada_is_renaming_symbol (var))
13490           return ada_read_renaming_var_value (var, frame_block);
13491       }
13492
13493     /* This is a typical case where we expect the default_read_var_value
13494        function to work.  */
13495     return language_defn::read_var_value (var, var_block, frame);
13496   }
13497
13498   /* See language.h.  */
13499   bool symbol_printing_suppressed (struct symbol *symbol) const override
13500   {
13501     return symbol->is_artificial ();
13502   }
13503
13504   /* See language.h.  */
13505   void language_arch_info (struct gdbarch *gdbarch,
13506                            struct language_arch_info *lai) const override
13507   {
13508     const struct builtin_type *builtin = builtin_type (gdbarch);
13509
13510     /* Helper function to allow shorter lines below.  */
13511     auto add = [&] (struct type *t)
13512     {
13513       lai->add_primitive_type (t);
13514     };
13515
13516     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13517                             0, "integer"));
13518     add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13519                             0, "long_integer"));
13520     add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13521                             0, "short_integer"));
13522     struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
13523                                                   1, "character");
13524     lai->set_string_char_type (char_type);
13525     add (char_type);
13526     add (arch_character_type (gdbarch, 16, 1, "wide_character"));
13527     add (arch_character_type (gdbarch, 32, 1, "wide_wide_character"));
13528     add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13529                           "float", gdbarch_float_format (gdbarch)));
13530     add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13531                           "long_float", gdbarch_double_format (gdbarch)));
13532     add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13533                             0, "long_long_integer"));
13534     add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13535                           "long_long_float",
13536                           gdbarch_long_double_format (gdbarch)));
13537     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13538                             0, "natural"));
13539     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13540                             0, "positive"));
13541     add (builtin->builtin_void);
13542
13543     struct type *system_addr_ptr
13544       = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13545                                         "void"));
13546     system_addr_ptr->set_name ("system__address");
13547     add (system_addr_ptr);
13548
13549     /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13550        type.  This is a signed integral type whose size is the same as
13551        the size of addresses.  */
13552     unsigned int addr_length = TYPE_LENGTH (system_addr_ptr);
13553     add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13554                             "storage_offset"));
13555
13556     lai->set_bool_type (builtin->builtin_bool);
13557   }
13558
13559   /* See language.h.  */
13560
13561   bool iterate_over_symbols
13562         (const struct block *block, const lookup_name_info &name,
13563          domain_enum domain,
13564          gdb::function_view<symbol_found_callback_ftype> callback) const override
13565   {
13566     std::vector<struct block_symbol> results
13567       = ada_lookup_symbol_list_worker (name, block, domain, 0);
13568     for (block_symbol &sym : results)
13569       {
13570         if (!callback (&sym))
13571           return false;
13572       }
13573
13574     return true;
13575   }
13576
13577   /* See language.h.  */
13578   bool sniff_from_mangled_name
13579        (const char *mangled,
13580         gdb::unique_xmalloc_ptr<char> *out) const override
13581   {
13582     std::string demangled = ada_decode (mangled);
13583
13584     *out = NULL;
13585
13586     if (demangled != mangled && demangled[0] != '<')
13587       {
13588         /* Set the gsymbol language to Ada, but still return 0.
13589            Two reasons for that:
13590
13591            1. For Ada, we prefer computing the symbol's decoded name
13592            on the fly rather than pre-compute it, in order to save
13593            memory (Ada projects are typically very large).
13594
13595            2. There are some areas in the definition of the GNAT
13596            encoding where, with a bit of bad luck, we might be able
13597            to decode a non-Ada symbol, generating an incorrect
13598            demangled name (Eg: names ending with "TB" for instance
13599            are identified as task bodies and so stripped from
13600            the decoded name returned).
13601
13602            Returning true, here, but not setting *DEMANGLED, helps us get
13603            a little bit of the best of both worlds.  Because we're last,
13604            we should not affect any of the other languages that were
13605            able to demangle the symbol before us; we get to correctly
13606            tag Ada symbols as such; and even if we incorrectly tagged a
13607            non-Ada symbol, which should be rare, any routing through the
13608            Ada language should be transparent (Ada tries to behave much
13609            like C/C++ with non-Ada symbols).  */
13610         return true;
13611       }
13612
13613     return false;
13614   }
13615
13616   /* See language.h.  */
13617
13618   gdb::unique_xmalloc_ptr<char> demangle_symbol (const char *mangled,
13619                                                  int options) const override
13620   {
13621     return make_unique_xstrdup (ada_decode (mangled).c_str ());
13622   }
13623
13624   /* See language.h.  */
13625
13626   void print_type (struct type *type, const char *varstring,
13627                    struct ui_file *stream, int show, int level,
13628                    const struct type_print_options *flags) const override
13629   {
13630     ada_print_type (type, varstring, stream, show, level, flags);
13631   }
13632
13633   /* See language.h.  */
13634
13635   const char *word_break_characters (void) const override
13636   {
13637     return ada_completer_word_break_characters;
13638   }
13639
13640   /* See language.h.  */
13641
13642   void collect_symbol_completion_matches (completion_tracker &tracker,
13643                                           complete_symbol_mode mode,
13644                                           symbol_name_match_type name_match_type,
13645                                           const char *text, const char *word,
13646                                           enum type_code code) const override
13647   {
13648     struct symbol *sym;
13649     const struct block *b, *surrounding_static_block = 0;
13650     struct block_iterator iter;
13651
13652     gdb_assert (code == TYPE_CODE_UNDEF);
13653
13654     lookup_name_info lookup_name (text, name_match_type, true);
13655
13656     /* First, look at the partial symtab symbols.  */
13657     expand_symtabs_matching (NULL,
13658                              lookup_name,
13659                              NULL,
13660                              NULL,
13661                              SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13662                              ALL_DOMAIN);
13663
13664     /* At this point scan through the misc symbol vectors and add each
13665        symbol you find to the list.  Eventually we want to ignore
13666        anything that isn't a text symbol (everything else will be
13667        handled by the psymtab code above).  */
13668
13669     for (objfile *objfile : current_program_space->objfiles ())
13670       {
13671         for (minimal_symbol *msymbol : objfile->msymbols ())
13672           {
13673             QUIT;
13674
13675             if (completion_skip_symbol (mode, msymbol))
13676               continue;
13677
13678             language symbol_language = msymbol->language ();
13679
13680             /* Ada minimal symbols won't have their language set to Ada.  If
13681                we let completion_list_add_name compare using the
13682                default/C-like matcher, then when completing e.g., symbols in a
13683                package named "pck", we'd match internal Ada symbols like
13684                "pckS", which are invalid in an Ada expression, unless you wrap
13685                them in '<' '>' to request a verbatim match.
13686
13687                Unfortunately, some Ada encoded names successfully demangle as
13688                C++ symbols (using an old mangling scheme), such as "name__2Xn"
13689                -> "Xn::name(void)" and thus some Ada minimal symbols end up
13690                with the wrong language set.  Paper over that issue here.  */
13691             if (symbol_language == language_auto
13692                 || symbol_language == language_cplus)
13693               symbol_language = language_ada;
13694
13695             completion_list_add_name (tracker,
13696                                       symbol_language,
13697                                       msymbol->linkage_name (),
13698                                       lookup_name, text, word);
13699           }
13700       }
13701
13702     /* Search upwards from currently selected frame (so that we can
13703        complete on local vars.  */
13704
13705     for (b = get_selected_block (0); b != NULL; b = b->superblock ())
13706       {
13707         if (!b->superblock ())
13708           surrounding_static_block = b;   /* For elmin of dups */
13709
13710         ALL_BLOCK_SYMBOLS (b, iter, sym)
13711           {
13712             if (completion_skip_symbol (mode, sym))
13713               continue;
13714
13715             completion_list_add_name (tracker,
13716                                       sym->language (),
13717                                       sym->linkage_name (),
13718                                       lookup_name, text, word);
13719           }
13720       }
13721
13722     /* Go through the symtabs and check the externs and statics for
13723        symbols which match.  */
13724
13725     for (objfile *objfile : current_program_space->objfiles ())
13726       {
13727         for (compunit_symtab *s : objfile->compunits ())
13728           {
13729             QUIT;
13730             b = s->blockvector ()->global_block ();
13731             ALL_BLOCK_SYMBOLS (b, iter, sym)
13732               {
13733                 if (completion_skip_symbol (mode, sym))
13734                   continue;
13735
13736                 completion_list_add_name (tracker,
13737                                           sym->language (),
13738                                           sym->linkage_name (),
13739                                           lookup_name, text, word);
13740               }
13741           }
13742       }
13743
13744     for (objfile *objfile : current_program_space->objfiles ())
13745       {
13746         for (compunit_symtab *s : objfile->compunits ())
13747           {
13748             QUIT;
13749             b = s->blockvector ()->static_block ();
13750             /* Don't do this block twice.  */
13751             if (b == surrounding_static_block)
13752               continue;
13753             ALL_BLOCK_SYMBOLS (b, iter, sym)
13754               {
13755                 if (completion_skip_symbol (mode, sym))
13756                   continue;
13757
13758                 completion_list_add_name (tracker,
13759                                           sym->language (),
13760                                           sym->linkage_name (),
13761                                           lookup_name, text, word);
13762               }
13763           }
13764       }
13765   }
13766
13767   /* See language.h.  */
13768
13769   gdb::unique_xmalloc_ptr<char> watch_location_expression
13770         (struct type *type, CORE_ADDR addr) const override
13771   {
13772     type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
13773     std::string name = type_to_string (type);
13774     return xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr));
13775   }
13776
13777   /* See language.h.  */
13778
13779   void value_print (struct value *val, struct ui_file *stream,
13780                     const struct value_print_options *options) const override
13781   {
13782     return ada_value_print (val, stream, options);
13783   }
13784
13785   /* See language.h.  */
13786
13787   void value_print_inner
13788         (struct value *val, struct ui_file *stream, int recurse,
13789          const struct value_print_options *options) const override
13790   {
13791     return ada_value_print_inner (val, stream, recurse, options);
13792   }
13793
13794   /* See language.h.  */
13795
13796   struct block_symbol lookup_symbol_nonlocal
13797         (const char *name, const struct block *block,
13798          const domain_enum domain) const override
13799   {
13800     struct block_symbol sym;
13801
13802     sym = ada_lookup_symbol (name, block_static_block (block), domain);
13803     if (sym.symbol != NULL)
13804       return sym;
13805
13806     /* If we haven't found a match at this point, try the primitive
13807        types.  In other languages, this search is performed before
13808        searching for global symbols in order to short-circuit that
13809        global-symbol search if it happens that the name corresponds
13810        to a primitive type.  But we cannot do the same in Ada, because
13811        it is perfectly legitimate for a program to declare a type which
13812        has the same name as a standard type.  If looking up a type in
13813        that situation, we have traditionally ignored the primitive type
13814        in favor of user-defined types.  This is why, unlike most other
13815        languages, we search the primitive types this late and only after
13816        having searched the global symbols without success.  */
13817
13818     if (domain == VAR_DOMAIN)
13819       {
13820         struct gdbarch *gdbarch;
13821
13822         if (block == NULL)
13823           gdbarch = target_gdbarch ();
13824         else
13825           gdbarch = block_gdbarch (block);
13826         sym.symbol
13827           = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13828         if (sym.symbol != NULL)
13829           return sym;
13830       }
13831
13832     return {};
13833   }
13834
13835   /* See language.h.  */
13836
13837   int parser (struct parser_state *ps) const override
13838   {
13839     warnings_issued = 0;
13840     return ada_parse (ps);
13841   }
13842
13843   /* See language.h.  */
13844
13845   void emitchar (int ch, struct type *chtype,
13846                  struct ui_file *stream, int quoter) const override
13847   {
13848     ada_emit_char (ch, chtype, stream, quoter, 1);
13849   }
13850
13851   /* See language.h.  */
13852
13853   void printchar (int ch, struct type *chtype,
13854                   struct ui_file *stream) const override
13855   {
13856     ada_printchar (ch, chtype, stream);
13857   }
13858
13859   /* See language.h.  */
13860
13861   void printstr (struct ui_file *stream, struct type *elttype,
13862                  const gdb_byte *string, unsigned int length,
13863                  const char *encoding, int force_ellipses,
13864                  const struct value_print_options *options) const override
13865   {
13866     ada_printstr (stream, elttype, string, length, encoding,
13867                   force_ellipses, options);
13868   }
13869
13870   /* See language.h.  */
13871
13872   void print_typedef (struct type *type, struct symbol *new_symbol,
13873                       struct ui_file *stream) const override
13874   {
13875     ada_print_typedef (type, new_symbol, stream);
13876   }
13877
13878   /* See language.h.  */
13879
13880   bool is_string_type_p (struct type *type) const override
13881   {
13882     return ada_is_string_type (type);
13883   }
13884
13885   /* See language.h.  */
13886
13887   const char *struct_too_deep_ellipsis () const override
13888   { return "(...)"; }
13889
13890   /* See language.h.  */
13891
13892   bool c_style_arrays_p () const override
13893   { return false; }
13894
13895   /* See language.h.  */
13896
13897   bool store_sym_names_in_linkage_form_p () const override
13898   { return true; }
13899
13900   /* See language.h.  */
13901
13902   const struct lang_varobj_ops *varobj_ops () const override
13903   { return &ada_varobj_ops; }
13904
13905 protected:
13906   /* See language.h.  */
13907
13908   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13909         (const lookup_name_info &lookup_name) const override
13910   {
13911     return ada_get_symbol_name_matcher (lookup_name);
13912   }
13913 };
13914
13915 /* Single instance of the Ada language class.  */
13916
13917 static ada_language ada_language_defn;
13918
13919 /* Command-list for the "set/show ada" prefix command.  */
13920 static struct cmd_list_element *set_ada_list;
13921 static struct cmd_list_element *show_ada_list;
13922
13923 /* This module's 'new_objfile' observer.  */
13924
13925 static void
13926 ada_new_objfile_observer (struct objfile *objfile)
13927 {
13928   ada_clear_symbol_cache ();
13929 }
13930
13931 /* This module's 'free_objfile' observer.  */
13932
13933 static void
13934 ada_free_objfile_observer (struct objfile *objfile)
13935 {
13936   ada_clear_symbol_cache ();
13937 }
13938
13939 /* Charsets known to GNAT.  */
13940 static const char * const gnat_source_charsets[] =
13941 {
13942   /* Note that code below assumes that the default comes first.
13943      Latin-1 is the default here, because that is also GNAT's
13944      default.  */
13945   "ISO-8859-1",
13946   "ISO-8859-2",
13947   "ISO-8859-3",
13948   "ISO-8859-4",
13949   "ISO-8859-5",
13950   "ISO-8859-15",
13951   "CP437",
13952   "CP850",
13953   /* Note that this value is special-cased in the encoder and
13954      decoder.  */
13955   ada_utf8,
13956   nullptr
13957 };
13958
13959 void _initialize_ada_language ();
13960 void
13961 _initialize_ada_language ()
13962 {
13963   add_setshow_prefix_cmd
13964     ("ada", no_class,
13965      _("Prefix command for changing Ada-specific settings."),
13966      _("Generic command for showing Ada-specific settings."),
13967      &set_ada_list, &show_ada_list,
13968      &setlist, &showlist);
13969
13970   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13971                            &trust_pad_over_xvs, _("\
13972 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13973 Show whether an optimization trusting PAD types over XVS types is activated."),
13974                            _("\
13975 This is related to the encoding used by the GNAT compiler.  The debugger\n\
13976 should normally trust the contents of PAD types, but certain older versions\n\
13977 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13978 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
13979 work around this bug.  It is always safe to turn this option \"off\", but\n\
13980 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13981 this option to \"off\" unless necessary."),
13982                             NULL, NULL, &set_ada_list, &show_ada_list);
13983
13984   add_setshow_boolean_cmd ("print-signatures", class_vars,
13985                            &print_signatures, _("\
13986 Enable or disable the output of formal and return types for functions in the \
13987 overloads selection menu."), _("\
13988 Show whether the output of formal and return types for functions in the \
13989 overloads selection menu is activated."),
13990                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
13991
13992   ada_source_charset = gnat_source_charsets[0];
13993   add_setshow_enum_cmd ("source-charset", class_files,
13994                         gnat_source_charsets,
13995                         &ada_source_charset,  _("\
13996 Set the Ada source character set."), _("\
13997 Show the Ada source character set."), _("\
13998 The character set used for Ada source files.\n\
13999 This must correspond to the '-gnati' or '-gnatW' option passed to GNAT."),
14000                         nullptr, nullptr,
14001                         &set_ada_list, &show_ada_list);
14002
14003   add_catch_command ("exception", _("\
14004 Catch Ada exceptions, when raised.\n\
14005 Usage: catch exception [ARG] [if CONDITION]\n\
14006 Without any argument, stop when any Ada exception is raised.\n\
14007 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14008 being raised does not have a handler (and will therefore lead to the task's\n\
14009 termination).\n\
14010 Otherwise, the catchpoint only stops when the name of the exception being\n\
14011 raised is the same as ARG.\n\
14012 CONDITION is a boolean expression that is evaluated to see whether the\n\
14013 exception should cause a stop."),
14014                      catch_ada_exception_command,
14015                      catch_ada_completer,
14016                      CATCH_PERMANENT,
14017                      CATCH_TEMPORARY);
14018
14019   add_catch_command ("handlers", _("\
14020 Catch Ada exceptions, when handled.\n\
14021 Usage: catch handlers [ARG] [if CONDITION]\n\
14022 Without any argument, stop when any Ada exception is handled.\n\
14023 With an argument, catch only exceptions with the given name.\n\
14024 CONDITION is a boolean expression that is evaluated to see whether the\n\
14025 exception should cause a stop."),
14026                      catch_ada_handlers_command,
14027                      catch_ada_completer,
14028                      CATCH_PERMANENT,
14029                      CATCH_TEMPORARY);
14030   add_catch_command ("assert", _("\
14031 Catch failed Ada assertions, when raised.\n\
14032 Usage: catch assert [if CONDITION]\n\
14033 CONDITION is a boolean expression that is evaluated to see whether the\n\
14034 exception should cause a stop."),
14035                      catch_assert_command,
14036                      NULL,
14037                      CATCH_PERMANENT,
14038                      CATCH_TEMPORARY);
14039
14040   add_info ("exceptions", info_exceptions_command,
14041             _("\
14042 List all Ada exception names.\n\
14043 Usage: info exceptions [REGEXP]\n\
14044 If a regular expression is passed as an argument, only those matching\n\
14045 the regular expression are listed."));
14046
14047   add_setshow_prefix_cmd ("ada", class_maintenance,
14048                           _("Set Ada maintenance-related variables."),
14049                           _("Show Ada maintenance-related variables."),
14050                           &maint_set_ada_cmdlist, &maint_show_ada_cmdlist,
14051                           &maintenance_set_cmdlist, &maintenance_show_cmdlist);
14052
14053   add_setshow_boolean_cmd
14054     ("ignore-descriptive-types", class_maintenance,
14055      &ada_ignore_descriptive_types_p,
14056      _("Set whether descriptive types generated by GNAT should be ignored."),
14057      _("Show whether descriptive types generated by GNAT should be ignored."),
14058      _("\
14059 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14060 DWARF attribute."),
14061      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14062
14063   decoded_names_store = htab_create_alloc (256, htab_hash_string,
14064                                            htab_eq_string,
14065                                            NULL, xcalloc, xfree);
14066
14067   /* The ada-lang observers.  */
14068   gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
14069   gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
14070   gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");
14071 }
This page took 0.82205 seconds and 4 git commands to generate.