]> Git Repo - binutils.git/blob - gdb/ada-lang.c
Remove 'varsize-limit'
[binutils.git] / gdb / ada-lang.c
1 /* Ada language support routines for GDB, the GNU debugger.
2
3    Copyright (C) 1992-2021 Free Software Foundation, Inc.
4
5    This file is part of GDB.
6
7    This program is free software; you can redistribute it and/or modify
8    it under the terms of the GNU General Public License as published by
9    the Free Software Foundation; either version 3 of the License, or
10    (at your option) any later version.
11
12    This program is distributed in the hope that it will be useful,
13    but WITHOUT ANY WARRANTY; without even the implied warranty of
14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15    GNU General Public License for more details.
16
17    You should have received a copy of the GNU General Public License
18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
19
20
21 #include "defs.h"
22 #include <ctype.h>
23 #include "gdb_regex.h"
24 #include "frame.h"
25 #include "symtab.h"
26 #include "gdbtypes.h"
27 #include "gdbcmd.h"
28 #include "expression.h"
29 #include "parser-defs.h"
30 #include "language.h"
31 #include "varobj.h"
32 #include "inferior.h"
33 #include "symfile.h"
34 #include "objfiles.h"
35 #include "breakpoint.h"
36 #include "gdbcore.h"
37 #include "hashtab.h"
38 #include "gdb_obstack.h"
39 #include "ada-lang.h"
40 #include "completer.h"
41 #include "ui-out.h"
42 #include "block.h"
43 #include "infcall.h"
44 #include "annotate.h"
45 #include "valprint.h"
46 #include "source.h"
47 #include "observable.h"
48 #include "stack.h"
49 #include "typeprint.h"
50 #include "namespace.h"
51 #include "cli/cli-style.h"
52 #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
63 /* Define whether or not the C operator '/' truncates towards zero for
64    differently signed operands (truncation direction is undefined in C).
65    Copied from valarith.c.  */
66
67 #ifndef TRUNCATION_TOWARDS_ZERO
68 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
69 #endif
70
71 static struct type *desc_base_type (struct type *);
72
73 static struct type *desc_bounds_type (struct type *);
74
75 static struct value *desc_bounds (struct value *);
76
77 static int fat_pntr_bounds_bitpos (struct type *);
78
79 static int fat_pntr_bounds_bitsize (struct type *);
80
81 static struct type *desc_data_target_type (struct type *);
82
83 static struct value *desc_data (struct value *);
84
85 static int fat_pntr_data_bitpos (struct type *);
86
87 static int fat_pntr_data_bitsize (struct type *);
88
89 static struct value *desc_one_bound (struct value *, int, int);
90
91 static int desc_bound_bitpos (struct type *, int, int);
92
93 static int desc_bound_bitsize (struct type *, int, int);
94
95 static struct type *desc_index_type (struct type *, int);
96
97 static int desc_arity (struct type *);
98
99 static int ada_args_match (struct symbol *, struct value **, int);
100
101 static struct value *make_array_descriptor (struct type *, struct value *);
102
103 static void ada_add_block_symbols (std::vector<struct block_symbol> &,
104                                    const struct block *,
105                                    const lookup_name_info &lookup_name,
106                                    domain_enum, struct objfile *);
107
108 static void ada_add_all_symbols (std::vector<struct block_symbol> &,
109                                  const struct block *,
110                                  const lookup_name_info &lookup_name,
111                                  domain_enum, int, int *);
112
113 static int is_nonfunction (const std::vector<struct block_symbol> &);
114
115 static void add_defn_to_vec (std::vector<struct block_symbol> &,
116                              struct symbol *,
117                              const struct block *);
118
119 static int possible_user_operator_p (enum exp_opcode, struct value **);
120
121 static const char *ada_decoded_op_name (enum exp_opcode);
122
123 static int numeric_type_p (struct type *);
124
125 static int integer_type_p (struct type *);
126
127 static int scalar_type_p (struct type *);
128
129 static int discrete_type_p (struct type *);
130
131 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
132                                                 int, int);
133
134 static struct type *ada_find_parallel_type_with_name (struct type *,
135                                                       const char *);
136
137 static int is_dynamic_field (struct type *, int);
138
139 static struct type *to_fixed_variant_branch_type (struct type *,
140                                                   const gdb_byte *,
141                                                   CORE_ADDR, struct value *);
142
143 static struct type *to_fixed_array_type (struct type *, struct value *, int);
144
145 static struct type *to_fixed_range_type (struct type *, struct value *);
146
147 static struct type *to_static_fixed_type (struct type *);
148 static struct type *static_unwrap_type (struct type *type);
149
150 static struct value *unwrap_value (struct value *);
151
152 static struct type *constrained_packed_array_type (struct type *, long *);
153
154 static struct type *decode_constrained_packed_array_type (struct type *);
155
156 static long decode_packed_array_bitsize (struct type *);
157
158 static struct value *decode_constrained_packed_array (struct value *);
159
160 static int ada_is_unconstrained_packed_array_type (struct type *);
161
162 static struct value *value_subscript_packed (struct value *, int,
163                                              struct value **);
164
165 static struct value *coerce_unspec_val_to_type (struct value *,
166                                                 struct type *);
167
168 static int lesseq_defined_than (struct symbol *, struct symbol *);
169
170 static int equiv_types (struct type *, struct type *);
171
172 static int is_name_suffix (const char *);
173
174 static int advance_wild_match (const char **, const char *, char);
175
176 static bool wild_match (const char *name, const char *patn);
177
178 static struct value *ada_coerce_ref (struct value *);
179
180 static LONGEST pos_atr (struct value *);
181
182 static struct value *val_atr (struct type *, LONGEST);
183
184 static struct symbol *standard_lookup (const char *, const struct block *,
185                                        domain_enum);
186
187 static struct value *ada_search_struct_field (const char *, struct value *, int,
188                                               struct type *);
189
190 static int find_struct_field (const char *, struct type *, int,
191                               struct type **, int *, int *, int *, int *);
192
193 static int ada_resolve_function (std::vector<struct block_symbol> &,
194                                  struct value **, int, const char *,
195                                  struct type *, bool);
196
197 static int ada_is_direct_array_type (struct type *);
198
199 static struct value *ada_index_struct_field (int, struct value *, int,
200                                              struct type *);
201
202 static void add_component_interval (LONGEST, LONGEST, std::vector<LONGEST> &);
203
204
205 static struct type *ada_find_any_type (const char *name);
206
207 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
208   (const lookup_name_info &lookup_name);
209
210 \f
211
212 /* The result of a symbol lookup to be stored in our symbol cache.  */
213
214 struct cache_entry
215 {
216   /* The name used to perform the lookup.  */
217   const char *name;
218   /* The namespace used during the lookup.  */
219   domain_enum domain;
220   /* The symbol returned by the lookup, or NULL if no matching symbol
221      was found.  */
222   struct symbol *sym;
223   /* The block where the symbol was found, or NULL if no matching
224      symbol was found.  */
225   const struct block *block;
226   /* A pointer to the next entry with the same hash.  */
227   struct cache_entry *next;
228 };
229
230 /* The Ada symbol cache, used to store the result of Ada-mode symbol
231    lookups in the course of executing the user's commands.
232
233    The cache is implemented using a simple, fixed-sized hash.
234    The size is fixed on the grounds that there are not likely to be
235    all that many symbols looked up during any given session, regardless
236    of the size of the symbol table.  If we decide to go to a resizable
237    table, let's just use the stuff from libiberty instead.  */
238
239 #define HASH_SIZE 1009
240
241 struct ada_symbol_cache
242 {
243   /* An obstack used to store the entries in our cache.  */
244   struct auto_obstack cache_space;
245
246   /* The root of the hash table used to implement our symbol cache.  */
247   struct cache_entry *root[HASH_SIZE] {};
248 };
249
250 static const char ada_completer_word_break_characters[] =
251 #ifdef VMS
252   " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
253 #else
254   " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
255 #endif
256
257 /* The name of the symbol to use to get the name of the main subprogram.  */
258 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
259   = "__gnat_ada_main_program_name";
260
261 /* Limit on the number of warnings to raise per expression evaluation.  */
262 static int warning_limit = 2;
263
264 /* Number of warning messages issued; reset to 0 by cleanups after
265    expression evaluation.  */
266 static int warnings_issued = 0;
267
268 static const char * const known_runtime_file_name_patterns[] = {
269   ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
270 };
271
272 static const char * const known_auxiliary_function_name_patterns[] = {
273   ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
274 };
275
276 /* Maintenance-related settings for this module.  */
277
278 static struct cmd_list_element *maint_set_ada_cmdlist;
279 static struct cmd_list_element *maint_show_ada_cmdlist;
280
281 /* The "maintenance ada set/show ignore-descriptive-type" value.  */
282
283 static bool ada_ignore_descriptive_types_p = false;
284
285                         /* Inferior-specific data.  */
286
287 /* Per-inferior data for this module.  */
288
289 struct ada_inferior_data
290 {
291   /* The ada__tags__type_specific_data type, which is used when decoding
292      tagged types.  With older versions of GNAT, this type was directly
293      accessible through a component ("tsd") in the object tag.  But this
294      is no longer the case, so we cache it for each inferior.  */
295   struct type *tsd_type = nullptr;
296
297   /* The exception_support_info data.  This data is used to determine
298      how to implement support for Ada exception catchpoints in a given
299      inferior.  */
300   const struct exception_support_info *exception_info = nullptr;
301 };
302
303 /* Our key to this module's inferior data.  */
304 static const struct inferior_key<ada_inferior_data> ada_inferior_data;
305
306 /* Return our inferior data for the given inferior (INF).
307
308    This function always returns a valid pointer to an allocated
309    ada_inferior_data structure.  If INF's inferior data has not
310    been previously set, this functions creates a new one with all
311    fields set to zero, sets INF's inferior to it, and then returns
312    a pointer to that newly allocated ada_inferior_data.  */
313
314 static struct ada_inferior_data *
315 get_ada_inferior_data (struct inferior *inf)
316 {
317   struct ada_inferior_data *data;
318
319   data = ada_inferior_data.get (inf);
320   if (data == NULL)
321     data = ada_inferior_data.emplace (inf);
322
323   return data;
324 }
325
326 /* Perform all necessary cleanups regarding our module's inferior data
327    that is required after the inferior INF just exited.  */
328
329 static void
330 ada_inferior_exit (struct inferior *inf)
331 {
332   ada_inferior_data.clear (inf);
333 }
334
335
336                         /* program-space-specific data.  */
337
338 /* This module's per-program-space data.  */
339 struct ada_pspace_data
340 {
341   /* The Ada symbol cache.  */
342   std::unique_ptr<ada_symbol_cache> sym_cache;
343 };
344
345 /* Key to our per-program-space data.  */
346 static const struct program_space_key<ada_pspace_data> ada_pspace_data_handle;
347
348 /* Return this module's data for the given program space (PSPACE).
349    If not is found, add a zero'ed one now.
350
351    This function always returns a valid object.  */
352
353 static struct ada_pspace_data *
354 get_ada_pspace_data (struct program_space *pspace)
355 {
356   struct ada_pspace_data *data;
357
358   data = ada_pspace_data_handle.get (pspace);
359   if (data == NULL)
360     data = ada_pspace_data_handle.emplace (pspace);
361
362   return data;
363 }
364
365                         /* Utilities */
366
367 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
368    all typedef layers have been peeled.  Otherwise, return TYPE.
369
370    Normally, we really expect a typedef type to only have 1 typedef layer.
371    In other words, we really expect the target type of a typedef type to be
372    a non-typedef type.  This is particularly true for Ada units, because
373    the language does not have a typedef vs not-typedef distinction.
374    In that respect, the Ada compiler has been trying to eliminate as many
375    typedef definitions in the debugging information, since they generally
376    do not bring any extra information (we still use typedef under certain
377    circumstances related mostly to the GNAT encoding).
378
379    Unfortunately, we have seen situations where the debugging information
380    generated by the compiler leads to such multiple typedef layers.  For
381    instance, consider the following example with stabs:
382
383      .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
384      .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
385
386    This is an error in the debugging information which causes type
387    pck__float_array___XUP to be defined twice, and the second time,
388    it is defined as a typedef of a typedef.
389
390    This is on the fringe of legality as far as debugging information is
391    concerned, and certainly unexpected.  But it is easy to handle these
392    situations correctly, so we can afford to be lenient in this case.  */
393
394 static struct type *
395 ada_typedef_target_type (struct type *type)
396 {
397   while (type->code () == TYPE_CODE_TYPEDEF)
398     type = TYPE_TARGET_TYPE (type);
399   return type;
400 }
401
402 /* Given DECODED_NAME a string holding a symbol name in its
403    decoded form (ie using the Ada dotted notation), returns
404    its unqualified name.  */
405
406 static const char *
407 ada_unqualified_name (const char *decoded_name)
408 {
409   const char *result;
410   
411   /* If the decoded name starts with '<', it means that the encoded
412      name does not follow standard naming conventions, and thus that
413      it is not your typical Ada symbol name.  Trying to unqualify it
414      is therefore pointless and possibly erroneous.  */
415   if (decoded_name[0] == '<')
416     return decoded_name;
417
418   result = strrchr (decoded_name, '.');
419   if (result != NULL)
420     result++;                   /* Skip the dot...  */
421   else
422     result = decoded_name;
423
424   return result;
425 }
426
427 /* Return a string starting with '<', followed by STR, and '>'.  */
428
429 static std::string
430 add_angle_brackets (const char *str)
431 {
432   return string_printf ("<%s>", str);
433 }
434
435 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
436    suffix of FIELD_NAME beginning "___".  */
437
438 static int
439 field_name_match (const char *field_name, const char *target)
440 {
441   int len = strlen (target);
442
443   return
444     (strncmp (field_name, target, len) == 0
445      && (field_name[len] == '\0'
446          || (startswith (field_name + len, "___")
447              && strcmp (field_name + strlen (field_name) - 6,
448                         "___XVN") != 0)));
449 }
450
451
452 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
453    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
454    and return its index.  This function also handles fields whose name
455    have ___ suffixes because the compiler sometimes alters their name
456    by adding such a suffix to represent fields with certain constraints.
457    If the field could not be found, return a negative number if
458    MAYBE_MISSING is set.  Otherwise raise an error.  */
459
460 int
461 ada_get_field_index (const struct type *type, const char *field_name,
462                      int maybe_missing)
463 {
464   int fieldno;
465   struct type *struct_type = check_typedef ((struct type *) type);
466
467   for (fieldno = 0; fieldno < struct_type->num_fields (); fieldno++)
468     if (field_name_match (struct_type->field (fieldno).name (), field_name))
469       return fieldno;
470
471   if (!maybe_missing)
472     error (_("Unable to find field %s in struct %s.  Aborting"),
473            field_name, struct_type->name ());
474
475   return -1;
476 }
477
478 /* The length of the prefix of NAME prior to any "___" suffix.  */
479
480 int
481 ada_name_prefix_len (const char *name)
482 {
483   if (name == NULL)
484     return 0;
485   else
486     {
487       const char *p = strstr (name, "___");
488
489       if (p == NULL)
490         return strlen (name);
491       else
492         return p - name;
493     }
494 }
495
496 /* Return non-zero if SUFFIX is a suffix of STR.
497    Return zero if STR is null.  */
498
499 static int
500 is_suffix (const char *str, const char *suffix)
501 {
502   int len1, len2;
503
504   if (str == NULL)
505     return 0;
506   len1 = strlen (str);
507   len2 = strlen (suffix);
508   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
509 }
510
511 /* The contents of value VAL, treated as a value of type TYPE.  The
512    result is an lval in memory if VAL is.  */
513
514 static struct value *
515 coerce_unspec_val_to_type (struct value *val, struct type *type)
516 {
517   type = ada_check_typedef (type);
518   if (value_type (val) == type)
519     return val;
520   else
521     {
522       struct value *result;
523
524       if (value_optimized_out (val))
525         result = allocate_optimized_out_value (type);
526       else if (value_lazy (val)
527                /* Be careful not to make a lazy not_lval value.  */
528                || (VALUE_LVAL (val) != not_lval
529                    && TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val))))
530         result = allocate_value_lazy (type);
531       else
532         {
533           result = allocate_value (type);
534           value_contents_copy (result, 0, val, 0, TYPE_LENGTH (type));
535         }
536       set_value_component_location (result, val);
537       set_value_bitsize (result, value_bitsize (val));
538       set_value_bitpos (result, value_bitpos (val));
539       if (VALUE_LVAL (result) == lval_memory)
540         set_value_address (result, value_address (val));
541       return result;
542     }
543 }
544
545 static const gdb_byte *
546 cond_offset_host (const gdb_byte *valaddr, long offset)
547 {
548   if (valaddr == NULL)
549     return NULL;
550   else
551     return valaddr + offset;
552 }
553
554 static CORE_ADDR
555 cond_offset_target (CORE_ADDR address, long offset)
556 {
557   if (address == 0)
558     return 0;
559   else
560     return address + offset;
561 }
562
563 /* Issue a warning (as for the definition of warning in utils.c, but
564    with exactly one argument rather than ...), unless the limit on the
565    number of warnings has passed during the evaluation of the current
566    expression.  */
567
568 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
569    provided by "complaint".  */
570 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
571
572 static void
573 lim_warning (const char *format, ...)
574 {
575   va_list args;
576
577   va_start (args, format);
578   warnings_issued += 1;
579   if (warnings_issued <= warning_limit)
580     vwarning (format, args);
581
582   va_end (args);
583 }
584
585 /* Maximum value of a SIZE-byte signed integer type.  */
586 static LONGEST
587 max_of_size (int size)
588 {
589   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
590
591   return top_bit | (top_bit - 1);
592 }
593
594 /* Minimum value of a SIZE-byte signed integer type.  */
595 static LONGEST
596 min_of_size (int size)
597 {
598   return -max_of_size (size) - 1;
599 }
600
601 /* Maximum value of a SIZE-byte unsigned integer type.  */
602 static ULONGEST
603 umax_of_size (int size)
604 {
605   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
606
607   return top_bit | (top_bit - 1);
608 }
609
610 /* Maximum value of integral type T, as a signed quantity.  */
611 static LONGEST
612 max_of_type (struct type *t)
613 {
614   if (t->is_unsigned ())
615     return (LONGEST) umax_of_size (TYPE_LENGTH (t));
616   else
617     return max_of_size (TYPE_LENGTH (t));
618 }
619
620 /* Minimum value of integral type T, as a signed quantity.  */
621 static LONGEST
622 min_of_type (struct type *t)
623 {
624   if (t->is_unsigned ())
625     return 0;
626   else
627     return min_of_size (TYPE_LENGTH (t));
628 }
629
630 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
631 LONGEST
632 ada_discrete_type_high_bound (struct type *type)
633 {
634   type = resolve_dynamic_type (type, {}, 0);
635   switch (type->code ())
636     {
637     case TYPE_CODE_RANGE:
638       {
639         const dynamic_prop &high = type->bounds ()->high;
640
641         if (high.kind () == PROP_CONST)
642           return high.const_val ();
643         else
644           {
645             gdb_assert (high.kind () == PROP_UNDEFINED);
646
647             /* This happens when trying to evaluate a type's dynamic bound
648                without a live target.  There is nothing relevant for us to
649                return here, so return 0.  */
650             return 0;
651           }
652       }
653     case TYPE_CODE_ENUM:
654       return TYPE_FIELD_ENUMVAL (type, type->num_fields () - 1);
655     case TYPE_CODE_BOOL:
656       return 1;
657     case TYPE_CODE_CHAR:
658     case TYPE_CODE_INT:
659       return max_of_type (type);
660     default:
661       error (_("Unexpected type in ada_discrete_type_high_bound."));
662     }
663 }
664
665 /* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
666 LONGEST
667 ada_discrete_type_low_bound (struct type *type)
668 {
669   type = resolve_dynamic_type (type, {}, 0);
670   switch (type->code ())
671     {
672     case TYPE_CODE_RANGE:
673       {
674         const dynamic_prop &low = type->bounds ()->low;
675
676         if (low.kind () == PROP_CONST)
677           return low.const_val ();
678         else
679           {
680             gdb_assert (low.kind () == PROP_UNDEFINED);
681
682             /* This happens when trying to evaluate a type's dynamic bound
683                without a live target.  There is nothing relevant for us to
684                return here, so return 0.  */
685             return 0;
686           }
687       }
688     case TYPE_CODE_ENUM:
689       return TYPE_FIELD_ENUMVAL (type, 0);
690     case TYPE_CODE_BOOL:
691       return 0;
692     case TYPE_CODE_CHAR:
693     case TYPE_CODE_INT:
694       return min_of_type (type);
695     default:
696       error (_("Unexpected type in ada_discrete_type_low_bound."));
697     }
698 }
699
700 /* The identity on non-range types.  For range types, the underlying
701    non-range scalar type.  */
702
703 static struct type *
704 get_base_type (struct type *type)
705 {
706   while (type != NULL && type->code () == TYPE_CODE_RANGE)
707     {
708       if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
709         return type;
710       type = TYPE_TARGET_TYPE (type);
711     }
712   return type;
713 }
714
715 /* Return a decoded version of the given VALUE.  This means returning
716    a value whose type is obtained by applying all the GNAT-specific
717    encodings, making the resulting type a static but standard description
718    of the initial type.  */
719
720 struct value *
721 ada_get_decoded_value (struct value *value)
722 {
723   struct type *type = ada_check_typedef (value_type (value));
724
725   if (ada_is_array_descriptor_type (type)
726       || (ada_is_constrained_packed_array_type (type)
727           && type->code () != TYPE_CODE_PTR))
728     {
729       if (type->code () == TYPE_CODE_TYPEDEF)  /* array access type.  */
730         value = ada_coerce_to_simple_array_ptr (value);
731       else
732         value = ada_coerce_to_simple_array (value);
733     }
734   else
735     value = ada_to_fixed_value (value);
736
737   return value;
738 }
739
740 /* Same as ada_get_decoded_value, but with the given TYPE.
741    Because there is no associated actual value for this type,
742    the resulting type might be a best-effort approximation in
743    the case of dynamic types.  */
744
745 struct type *
746 ada_get_decoded_type (struct type *type)
747 {
748   type = to_static_fixed_type (type);
749   if (ada_is_constrained_packed_array_type (type))
750     type = ada_coerce_to_simple_array_type (type);
751   return type;
752 }
753
754 \f
755
756                                 /* Language Selection */
757
758 /* If the main program is in Ada, return language_ada, otherwise return LANG
759    (the main program is in Ada iif the adainit symbol is found).  */
760
761 static enum language
762 ada_update_initial_language (enum language lang)
763 {
764   if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
765     return language_ada;
766
767   return lang;
768 }
769
770 /* If the main procedure is written in Ada, then return its name.
771    The result is good until the next call.  Return NULL if the main
772    procedure doesn't appear to be in Ada.  */
773
774 char *
775 ada_main_name (void)
776 {
777   struct bound_minimal_symbol msym;
778   static gdb::unique_xmalloc_ptr<char> main_program_name;
779
780   /* For Ada, the name of the main procedure is stored in a specific
781      string constant, generated by the binder.  Look for that symbol,
782      extract its address, and then read that string.  If we didn't find
783      that string, then most probably the main procedure is not written
784      in Ada.  */
785   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
786
787   if (msym.minsym != NULL)
788     {
789       CORE_ADDR main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
790       if (main_program_name_addr == 0)
791         error (_("Invalid address for Ada main program name."));
792
793       main_program_name = target_read_string (main_program_name_addr, 1024);
794       return main_program_name.get ();
795     }
796
797   /* The main procedure doesn't seem to be in Ada.  */
798   return NULL;
799 }
800 \f
801                                 /* Symbols */
802
803 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
804    of NULLs.  */
805
806 const struct ada_opname_map ada_opname_table[] = {
807   {"Oadd", "\"+\"", BINOP_ADD},
808   {"Osubtract", "\"-\"", BINOP_SUB},
809   {"Omultiply", "\"*\"", BINOP_MUL},
810   {"Odivide", "\"/\"", BINOP_DIV},
811   {"Omod", "\"mod\"", BINOP_MOD},
812   {"Orem", "\"rem\"", BINOP_REM},
813   {"Oexpon", "\"**\"", BINOP_EXP},
814   {"Olt", "\"<\"", BINOP_LESS},
815   {"Ole", "\"<=\"", BINOP_LEQ},
816   {"Ogt", "\">\"", BINOP_GTR},
817   {"Oge", "\">=\"", BINOP_GEQ},
818   {"Oeq", "\"=\"", BINOP_EQUAL},
819   {"One", "\"/=\"", BINOP_NOTEQUAL},
820   {"Oand", "\"and\"", BINOP_BITWISE_AND},
821   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
822   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
823   {"Oconcat", "\"&\"", BINOP_CONCAT},
824   {"Oabs", "\"abs\"", UNOP_ABS},
825   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
826   {"Oadd", "\"+\"", UNOP_PLUS},
827   {"Osubtract", "\"-\"", UNOP_NEG},
828   {NULL, NULL}
829 };
830
831 /* If STR is a decoded version of a compiler-provided suffix (like the
832    "[cold]" in "symbol[cold]"), return true.  Otherwise, return
833    false.  */
834
835 static bool
836 is_compiler_suffix (const char *str)
837 {
838   gdb_assert (*str == '[');
839   ++str;
840   while (*str != '\0' && isalpha (*str))
841     ++str;
842   /* We accept a missing "]" in order to support completion.  */
843   return *str == '\0' || (str[0] == ']' && str[1] == '\0');
844 }
845
846 /* The "encoded" form of DECODED, according to GNAT conventions.  If
847    THROW_ERRORS, throw an error if invalid operator name is found.
848    Otherwise, return the empty string in that case.  */
849
850 static std::string
851 ada_encode_1 (const char *decoded, bool throw_errors)
852 {
853   if (decoded == NULL)
854     return {};
855
856   std::string encoding_buffer;
857   for (const char *p = decoded; *p != '\0'; p += 1)
858     {
859       if (*p == '.')
860         encoding_buffer.append ("__");
861       else if (*p == '[' && is_compiler_suffix (p))
862         {
863           encoding_buffer = encoding_buffer + "." + (p + 1);
864           if (encoding_buffer.back () == ']')
865             encoding_buffer.pop_back ();
866           break;
867         }
868       else if (*p == '"')
869         {
870           const struct ada_opname_map *mapping;
871
872           for (mapping = ada_opname_table;
873                mapping->encoded != NULL
874                && !startswith (p, mapping->decoded); mapping += 1)
875             ;
876           if (mapping->encoded == NULL)
877             {
878               if (throw_errors)
879                 error (_("invalid Ada operator name: %s"), p);
880               else
881                 return {};
882             }
883           encoding_buffer.append (mapping->encoded);
884           break;
885         }
886       else
887         encoding_buffer.push_back (*p);
888     }
889
890   return encoding_buffer;
891 }
892
893 /* The "encoded" form of DECODED, according to GNAT conventions.  */
894
895 std::string
896 ada_encode (const char *decoded)
897 {
898   return ada_encode_1 (decoded, true);
899 }
900
901 /* Return NAME folded to lower case, or, if surrounded by single
902    quotes, unfolded, but with the quotes stripped away.  Result good
903    to next call.  */
904
905 static const char *
906 ada_fold_name (gdb::string_view name)
907 {
908   static std::string fold_storage;
909
910   if (!name.empty () && name[0] == '\'')
911     fold_storage = gdb::to_string (name.substr (1, name.size () - 2));
912   else
913     {
914       fold_storage = gdb::to_string (name);
915       for (int i = 0; i < name.size (); i += 1)
916         fold_storage[i] = tolower (fold_storage[i]);
917     }
918
919   return fold_storage.c_str ();
920 }
921
922 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
923
924 static int
925 is_lower_alphanum (const char c)
926 {
927   return (isdigit (c) || (isalpha (c) && islower (c)));
928 }
929
930 /* ENCODED is the linkage name of a symbol and LEN contains its length.
931    This function saves in LEN the length of that same symbol name but
932    without either of these suffixes:
933      . .{DIGIT}+
934      . ${DIGIT}+
935      . ___{DIGIT}+
936      . __{DIGIT}+.
937
938    These are suffixes introduced by the compiler for entities such as
939    nested subprogram for instance, in order to avoid name clashes.
940    They do not serve any purpose for the debugger.  */
941
942 static void
943 ada_remove_trailing_digits (const char *encoded, int *len)
944 {
945   if (*len > 1 && isdigit (encoded[*len - 1]))
946     {
947       int i = *len - 2;
948
949       while (i > 0 && isdigit (encoded[i]))
950         i--;
951       if (i >= 0 && encoded[i] == '.')
952         *len = i;
953       else if (i >= 0 && encoded[i] == '$')
954         *len = i;
955       else if (i >= 2 && startswith (encoded + i - 2, "___"))
956         *len = i - 2;
957       else if (i >= 1 && startswith (encoded + i - 1, "__"))
958         *len = i - 1;
959     }
960 }
961
962 /* Remove the suffix introduced by the compiler for protected object
963    subprograms.  */
964
965 static void
966 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
967 {
968   /* Remove trailing N.  */
969
970   /* Protected entry subprograms are broken into two
971      separate subprograms: The first one is unprotected, and has
972      a 'N' suffix; the second is the protected version, and has
973      the 'P' suffix.  The second calls the first one after handling
974      the protection.  Since the P subprograms are internally generated,
975      we leave these names undecoded, giving the user a clue that this
976      entity is internal.  */
977
978   if (*len > 1
979       && encoded[*len - 1] == 'N'
980       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
981     *len = *len - 1;
982 }
983
984 /* If ENCODED ends with a compiler-provided suffix (like ".cold"),
985    then update *LEN to remove the suffix and return the offset of the
986    character just past the ".".  Otherwise, return -1.  */
987
988 static int
989 remove_compiler_suffix (const char *encoded, int *len)
990 {
991   int offset = *len - 1;
992   while (offset > 0 && isalpha (encoded[offset]))
993     --offset;
994   if (offset > 0 && encoded[offset] == '.')
995     {
996       *len = offset;
997       return offset + 1;
998     }
999   return -1;
1000 }
1001
1002 /* See ada-lang.h.  */
1003
1004 std::string
1005 ada_decode (const char *encoded, bool wrap)
1006 {
1007   int i, j;
1008   int len0;
1009   const char *p;
1010   int at_start_name;
1011   std::string decoded;
1012   int suffix = -1;
1013
1014   /* With function descriptors on PPC64, the value of a symbol named
1015      ".FN", if it exists, is the entry point of the function "FN".  */
1016   if (encoded[0] == '.')
1017     encoded += 1;
1018
1019   /* The name of the Ada main procedure starts with "_ada_".
1020      This prefix is not part of the decoded name, so skip this part
1021      if we see this prefix.  */
1022   if (startswith (encoded, "_ada_"))
1023     encoded += 5;
1024
1025   /* If the name starts with '_', then it is not a properly encoded
1026      name, so do not attempt to decode it.  Similarly, if the name
1027      starts with '<', the name should not be decoded.  */
1028   if (encoded[0] == '_' || encoded[0] == '<')
1029     goto Suppress;
1030
1031   len0 = strlen (encoded);
1032
1033   suffix = remove_compiler_suffix (encoded, &len0);
1034
1035   ada_remove_trailing_digits (encoded, &len0);
1036   ada_remove_po_subprogram_suffix (encoded, &len0);
1037
1038   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1039      the suffix is located before the current "end" of ENCODED.  We want
1040      to avoid re-matching parts of ENCODED that have previously been
1041      marked as discarded (by decrementing LEN0).  */
1042   p = strstr (encoded, "___");
1043   if (p != NULL && p - encoded < len0 - 3)
1044     {
1045       if (p[3] == 'X')
1046         len0 = p - encoded;
1047       else
1048         goto Suppress;
1049     }
1050
1051   /* Remove any trailing TKB suffix.  It tells us that this symbol
1052      is for the body of a task, but that information does not actually
1053      appear in the decoded name.  */
1054
1055   if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1056     len0 -= 3;
1057
1058   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1059      from the TKB suffix because it is used for non-anonymous task
1060      bodies.  */
1061
1062   if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1063     len0 -= 2;
1064
1065   /* Remove trailing "B" suffixes.  */
1066   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1067
1068   if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1069     len0 -= 1;
1070
1071   /* Make decoded big enough for possible expansion by operator name.  */
1072
1073   decoded.resize (2 * len0 + 1, 'X');
1074
1075   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1076
1077   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1078     {
1079       i = len0 - 2;
1080       while ((i >= 0 && isdigit (encoded[i]))
1081              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1082         i -= 1;
1083       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1084         len0 = i - 1;
1085       else if (encoded[i] == '$')
1086         len0 = i;
1087     }
1088
1089   /* The first few characters that are not alphabetic are not part
1090      of any encoding we use, so we can copy them over verbatim.  */
1091
1092   for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1093     decoded[j] = encoded[i];
1094
1095   at_start_name = 1;
1096   while (i < len0)
1097     {
1098       /* Is this a symbol function?  */
1099       if (at_start_name && encoded[i] == 'O')
1100         {
1101           int k;
1102
1103           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1104             {
1105               int op_len = strlen (ada_opname_table[k].encoded);
1106               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1107                             op_len - 1) == 0)
1108                   && !isalnum (encoded[i + op_len]))
1109                 {
1110                   strcpy (&decoded.front() + j, ada_opname_table[k].decoded);
1111                   at_start_name = 0;
1112                   i += op_len;
1113                   j += strlen (ada_opname_table[k].decoded);
1114                   break;
1115                 }
1116             }
1117           if (ada_opname_table[k].encoded != NULL)
1118             continue;
1119         }
1120       at_start_name = 0;
1121
1122       /* Replace "TK__" with "__", which will eventually be translated
1123          into "." (just below).  */
1124
1125       if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1126         i += 2;
1127
1128       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1129          be translated into "." (just below).  These are internal names
1130          generated for anonymous blocks inside which our symbol is nested.  */
1131
1132       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1133           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1134           && isdigit (encoded [i+4]))
1135         {
1136           int k = i + 5;
1137           
1138           while (k < len0 && isdigit (encoded[k]))
1139             k++;  /* Skip any extra digit.  */
1140
1141           /* Double-check that the "__B_{DIGITS}+" sequence we found
1142              is indeed followed by "__".  */
1143           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1144             i = k;
1145         }
1146
1147       /* Remove _E{DIGITS}+[sb] */
1148
1149       /* Just as for protected object subprograms, there are 2 categories
1150          of subprograms created by the compiler for each entry.  The first
1151          one implements the actual entry code, and has a suffix following
1152          the convention above; the second one implements the barrier and
1153          uses the same convention as above, except that the 'E' is replaced
1154          by a 'B'.
1155
1156          Just as above, we do not decode the name of barrier functions
1157          to give the user a clue that the code he is debugging has been
1158          internally generated.  */
1159
1160       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1161           && isdigit (encoded[i+2]))
1162         {
1163           int k = i + 3;
1164
1165           while (k < len0 && isdigit (encoded[k]))
1166             k++;
1167
1168           if (k < len0
1169               && (encoded[k] == 'b' || encoded[k] == 's'))
1170             {
1171               k++;
1172               /* Just as an extra precaution, make sure that if this
1173                  suffix is followed by anything else, it is a '_'.
1174                  Otherwise, we matched this sequence by accident.  */
1175               if (k == len0
1176                   || (k < len0 && encoded[k] == '_'))
1177                 i = k;
1178             }
1179         }
1180
1181       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1182          the GNAT front-end in protected object subprograms.  */
1183
1184       if (i < len0 + 3
1185           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1186         {
1187           /* Backtrack a bit up until we reach either the begining of
1188              the encoded name, or "__".  Make sure that we only find
1189              digits or lowercase characters.  */
1190           const char *ptr = encoded + i - 1;
1191
1192           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1193             ptr--;
1194           if (ptr < encoded
1195               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1196             i++;
1197         }
1198
1199       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1200         {
1201           /* This is a X[bn]* sequence not separated from the previous
1202              part of the name with a non-alpha-numeric character (in other
1203              words, immediately following an alpha-numeric character), then
1204              verify that it is placed at the end of the encoded name.  If
1205              not, then the encoding is not valid and we should abort the
1206              decoding.  Otherwise, just skip it, it is used in body-nested
1207              package names.  */
1208           do
1209             i += 1;
1210           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1211           if (i < len0)
1212             goto Suppress;
1213         }
1214       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1215         {
1216          /* Replace '__' by '.'.  */
1217           decoded[j] = '.';
1218           at_start_name = 1;
1219           i += 2;
1220           j += 1;
1221         }
1222       else
1223         {
1224           /* It's a character part of the decoded name, so just copy it
1225              over.  */
1226           decoded[j] = encoded[i];
1227           i += 1;
1228           j += 1;
1229         }
1230     }
1231   decoded.resize (j);
1232
1233   /* Decoded names should never contain any uppercase character.
1234      Double-check this, and abort the decoding if we find one.  */
1235
1236   for (i = 0; i < decoded.length(); ++i)
1237     if (isupper (decoded[i]) || decoded[i] == ' ')
1238       goto Suppress;
1239
1240   /* If the compiler added a suffix, append it now.  */
1241   if (suffix >= 0)
1242     decoded = decoded + "[" + &encoded[suffix] + "]";
1243
1244   return decoded;
1245
1246 Suppress:
1247   if (!wrap)
1248     return {};
1249
1250   if (encoded[0] == '<')
1251     decoded = encoded;
1252   else
1253     decoded = '<' + std::string(encoded) + '>';
1254   return decoded;
1255 }
1256
1257 /* Table for keeping permanent unique copies of decoded names.  Once
1258    allocated, names in this table are never released.  While this is a
1259    storage leak, it should not be significant unless there are massive
1260    changes in the set of decoded names in successive versions of a 
1261    symbol table loaded during a single session.  */
1262 static struct htab *decoded_names_store;
1263
1264 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1265    in the language-specific part of GSYMBOL, if it has not been
1266    previously computed.  Tries to save the decoded name in the same
1267    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1268    in any case, the decoded symbol has a lifetime at least that of
1269    GSYMBOL).
1270    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1271    const, but nevertheless modified to a semantically equivalent form
1272    when a decoded name is cached in it.  */
1273
1274 const char *
1275 ada_decode_symbol (const struct general_symbol_info *arg)
1276 {
1277   struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1278   const char **resultp =
1279     &gsymbol->language_specific.demangled_name;
1280
1281   if (!gsymbol->ada_mangled)
1282     {
1283       std::string decoded = ada_decode (gsymbol->linkage_name ());
1284       struct obstack *obstack = gsymbol->language_specific.obstack;
1285
1286       gsymbol->ada_mangled = 1;
1287
1288       if (obstack != NULL)
1289         *resultp = obstack_strdup (obstack, decoded.c_str ());
1290       else
1291         {
1292           /* Sometimes, we can't find a corresponding objfile, in
1293              which case, we put the result on the heap.  Since we only
1294              decode when needed, we hope this usually does not cause a
1295              significant memory leak (FIXME).  */
1296
1297           char **slot = (char **) htab_find_slot (decoded_names_store,
1298                                                   decoded.c_str (), INSERT);
1299
1300           if (*slot == NULL)
1301             *slot = xstrdup (decoded.c_str ());
1302           *resultp = *slot;
1303         }
1304     }
1305
1306   return *resultp;
1307 }
1308
1309 \f
1310
1311                                 /* Arrays */
1312
1313 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1314    generated by the GNAT compiler to describe the index type used
1315    for each dimension of an array, check whether it follows the latest
1316    known encoding.  If not, fix it up to conform to the latest encoding.
1317    Otherwise, do nothing.  This function also does nothing if
1318    INDEX_DESC_TYPE is NULL.
1319
1320    The GNAT encoding used to describe the array index type evolved a bit.
1321    Initially, the information would be provided through the name of each
1322    field of the structure type only, while the type of these fields was
1323    described as unspecified and irrelevant.  The debugger was then expected
1324    to perform a global type lookup using the name of that field in order
1325    to get access to the full index type description.  Because these global
1326    lookups can be very expensive, the encoding was later enhanced to make
1327    the global lookup unnecessary by defining the field type as being
1328    the full index type description.
1329
1330    The purpose of this routine is to allow us to support older versions
1331    of the compiler by detecting the use of the older encoding, and by
1332    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1333    we essentially replace each field's meaningless type by the associated
1334    index subtype).  */
1335
1336 void
1337 ada_fixup_array_indexes_type (struct type *index_desc_type)
1338 {
1339   int i;
1340
1341   if (index_desc_type == NULL)
1342     return;
1343   gdb_assert (index_desc_type->num_fields () > 0);
1344
1345   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1346      to check one field only, no need to check them all).  If not, return
1347      now.
1348
1349      If our INDEX_DESC_TYPE was generated using the older encoding,
1350      the field type should be a meaningless integer type whose name
1351      is not equal to the field name.  */
1352   if (index_desc_type->field (0).type ()->name () != NULL
1353       && strcmp (index_desc_type->field (0).type ()->name (),
1354                  index_desc_type->field (0).name ()) == 0)
1355     return;
1356
1357   /* Fixup each field of INDEX_DESC_TYPE.  */
1358   for (i = 0; i < index_desc_type->num_fields (); i++)
1359    {
1360      const char *name = index_desc_type->field (i).name ();
1361      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1362
1363      if (raw_type)
1364        index_desc_type->field (i).set_type (raw_type);
1365    }
1366 }
1367
1368 /* The desc_* routines return primitive portions of array descriptors
1369    (fat pointers).  */
1370
1371 /* The descriptor or array type, if any, indicated by TYPE; removes
1372    level of indirection, if needed.  */
1373
1374 static struct type *
1375 desc_base_type (struct type *type)
1376 {
1377   if (type == NULL)
1378     return NULL;
1379   type = ada_check_typedef (type);
1380   if (type->code () == TYPE_CODE_TYPEDEF)
1381     type = ada_typedef_target_type (type);
1382
1383   if (type != NULL
1384       && (type->code () == TYPE_CODE_PTR
1385           || type->code () == TYPE_CODE_REF))
1386     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1387   else
1388     return type;
1389 }
1390
1391 /* True iff TYPE indicates a "thin" array pointer type.  */
1392
1393 static int
1394 is_thin_pntr (struct type *type)
1395 {
1396   return
1397     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1398     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1399 }
1400
1401 /* The descriptor type for thin pointer type TYPE.  */
1402
1403 static struct type *
1404 thin_descriptor_type (struct type *type)
1405 {
1406   struct type *base_type = desc_base_type (type);
1407
1408   if (base_type == NULL)
1409     return NULL;
1410   if (is_suffix (ada_type_name (base_type), "___XVE"))
1411     return base_type;
1412   else
1413     {
1414       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1415
1416       if (alt_type == NULL)
1417         return base_type;
1418       else
1419         return alt_type;
1420     }
1421 }
1422
1423 /* A pointer to the array data for thin-pointer value VAL.  */
1424
1425 static struct value *
1426 thin_data_pntr (struct value *val)
1427 {
1428   struct type *type = ada_check_typedef (value_type (val));
1429   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1430
1431   data_type = lookup_pointer_type (data_type);
1432
1433   if (type->code () == TYPE_CODE_PTR)
1434     return value_cast (data_type, value_copy (val));
1435   else
1436     return value_from_longest (data_type, value_address (val));
1437 }
1438
1439 /* True iff TYPE indicates a "thick" array pointer type.  */
1440
1441 static int
1442 is_thick_pntr (struct type *type)
1443 {
1444   type = desc_base_type (type);
1445   return (type != NULL && type->code () == TYPE_CODE_STRUCT
1446           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1447 }
1448
1449 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1450    pointer to one, the type of its bounds data; otherwise, NULL.  */
1451
1452 static struct type *
1453 desc_bounds_type (struct type *type)
1454 {
1455   struct type *r;
1456
1457   type = desc_base_type (type);
1458
1459   if (type == NULL)
1460     return NULL;
1461   else if (is_thin_pntr (type))
1462     {
1463       type = thin_descriptor_type (type);
1464       if (type == NULL)
1465         return NULL;
1466       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1467       if (r != NULL)
1468         return ada_check_typedef (r);
1469     }
1470   else if (type->code () == TYPE_CODE_STRUCT)
1471     {
1472       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1473       if (r != NULL)
1474         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1475     }
1476   return NULL;
1477 }
1478
1479 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1480    one, a pointer to its bounds data.   Otherwise NULL.  */
1481
1482 static struct value *
1483 desc_bounds (struct value *arr)
1484 {
1485   struct type *type = ada_check_typedef (value_type (arr));
1486
1487   if (is_thin_pntr (type))
1488     {
1489       struct type *bounds_type =
1490         desc_bounds_type (thin_descriptor_type (type));
1491       LONGEST addr;
1492
1493       if (bounds_type == NULL)
1494         error (_("Bad GNAT array descriptor"));
1495
1496       /* NOTE: The following calculation is not really kosher, but
1497          since desc_type is an XVE-encoded type (and shouldn't be),
1498          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1499       if (type->code () == TYPE_CODE_PTR)
1500         addr = value_as_long (arr);
1501       else
1502         addr = value_address (arr);
1503
1504       return
1505         value_from_longest (lookup_pointer_type (bounds_type),
1506                             addr - TYPE_LENGTH (bounds_type));
1507     }
1508
1509   else if (is_thick_pntr (type))
1510     {
1511       struct value *p_bounds = value_struct_elt (&arr, {}, "P_BOUNDS", NULL,
1512                                                _("Bad GNAT array descriptor"));
1513       struct type *p_bounds_type = value_type (p_bounds);
1514
1515       if (p_bounds_type
1516           && p_bounds_type->code () == TYPE_CODE_PTR)
1517         {
1518           struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1519
1520           if (target_type->is_stub ())
1521             p_bounds = value_cast (lookup_pointer_type
1522                                    (ada_check_typedef (target_type)),
1523                                    p_bounds);
1524         }
1525       else
1526         error (_("Bad GNAT array descriptor"));
1527
1528       return p_bounds;
1529     }
1530   else
1531     return NULL;
1532 }
1533
1534 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1535    position of the field containing the address of the bounds data.  */
1536
1537 static int
1538 fat_pntr_bounds_bitpos (struct type *type)
1539 {
1540   return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1541 }
1542
1543 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1544    size of the field containing the address of the bounds data.  */
1545
1546 static int
1547 fat_pntr_bounds_bitsize (struct type *type)
1548 {
1549   type = desc_base_type (type);
1550
1551   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1552     return TYPE_FIELD_BITSIZE (type, 1);
1553   else
1554     return 8 * TYPE_LENGTH (ada_check_typedef (type->field (1).type ()));
1555 }
1556
1557 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1558    pointer to one, the type of its array data (a array-with-no-bounds type);
1559    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1560    data.  */
1561
1562 static struct type *
1563 desc_data_target_type (struct type *type)
1564 {
1565   type = desc_base_type (type);
1566
1567   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1568   if (is_thin_pntr (type))
1569     return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1570   else if (is_thick_pntr (type))
1571     {
1572       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1573
1574       if (data_type
1575           && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1576         return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1577     }
1578
1579   return NULL;
1580 }
1581
1582 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1583    its array data.  */
1584
1585 static struct value *
1586 desc_data (struct value *arr)
1587 {
1588   struct type *type = value_type (arr);
1589
1590   if (is_thin_pntr (type))
1591     return thin_data_pntr (arr);
1592   else if (is_thick_pntr (type))
1593     return value_struct_elt (&arr, {}, "P_ARRAY", NULL,
1594                              _("Bad GNAT array descriptor"));
1595   else
1596     return NULL;
1597 }
1598
1599
1600 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1601    position of the field containing the address of the data.  */
1602
1603 static int
1604 fat_pntr_data_bitpos (struct type *type)
1605 {
1606   return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1607 }
1608
1609 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1610    size of the field containing the address of the data.  */
1611
1612 static int
1613 fat_pntr_data_bitsize (struct type *type)
1614 {
1615   type = desc_base_type (type);
1616
1617   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1618     return TYPE_FIELD_BITSIZE (type, 0);
1619   else
1620     return TARGET_CHAR_BIT * TYPE_LENGTH (type->field (0).type ());
1621 }
1622
1623 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1624    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1625    bound, if WHICH is 1.  The first bound is I=1.  */
1626
1627 static struct value *
1628 desc_one_bound (struct value *bounds, int i, int which)
1629 {
1630   char bound_name[20];
1631   xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1632              which ? 'U' : 'L', i - 1);
1633   return value_struct_elt (&bounds, {}, bound_name, NULL,
1634                            _("Bad GNAT array descriptor bounds"));
1635 }
1636
1637 /* If BOUNDS is an array-bounds structure type, return the bit position
1638    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1639    bound, if WHICH is 1.  The first bound is I=1.  */
1640
1641 static int
1642 desc_bound_bitpos (struct type *type, int i, int which)
1643 {
1644   return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1645 }
1646
1647 /* If BOUNDS is an array-bounds structure type, return the bit field size
1648    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1649    bound, if WHICH is 1.  The first bound is I=1.  */
1650
1651 static int
1652 desc_bound_bitsize (struct type *type, int i, int which)
1653 {
1654   type = desc_base_type (type);
1655
1656   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1657     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1658   else
1659     return 8 * TYPE_LENGTH (type->field (2 * i + which - 2).type ());
1660 }
1661
1662 /* If TYPE is the type of an array-bounds structure, the type of its
1663    Ith bound (numbering from 1).  Otherwise, NULL.  */
1664
1665 static struct type *
1666 desc_index_type (struct type *type, int i)
1667 {
1668   type = desc_base_type (type);
1669
1670   if (type->code () == TYPE_CODE_STRUCT)
1671     {
1672       char bound_name[20];
1673       xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
1674       return lookup_struct_elt_type (type, bound_name, 1);
1675     }
1676   else
1677     return NULL;
1678 }
1679
1680 /* The number of index positions in the array-bounds type TYPE.
1681    Return 0 if TYPE is NULL.  */
1682
1683 static int
1684 desc_arity (struct type *type)
1685 {
1686   type = desc_base_type (type);
1687
1688   if (type != NULL)
1689     return type->num_fields () / 2;
1690   return 0;
1691 }
1692
1693 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
1694    an array descriptor type (representing an unconstrained array
1695    type).  */
1696
1697 static int
1698 ada_is_direct_array_type (struct type *type)
1699 {
1700   if (type == NULL)
1701     return 0;
1702   type = ada_check_typedef (type);
1703   return (type->code () == TYPE_CODE_ARRAY
1704           || ada_is_array_descriptor_type (type));
1705 }
1706
1707 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1708  * to one.  */
1709
1710 static int
1711 ada_is_array_type (struct type *type)
1712 {
1713   while (type != NULL
1714          && (type->code () == TYPE_CODE_PTR
1715              || type->code () == TYPE_CODE_REF))
1716     type = TYPE_TARGET_TYPE (type);
1717   return ada_is_direct_array_type (type);
1718 }
1719
1720 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
1721
1722 int
1723 ada_is_simple_array_type (struct type *type)
1724 {
1725   if (type == NULL)
1726     return 0;
1727   type = ada_check_typedef (type);
1728   return (type->code () == TYPE_CODE_ARRAY
1729           || (type->code () == TYPE_CODE_PTR
1730               && (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ()
1731                   == TYPE_CODE_ARRAY)));
1732 }
1733
1734 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
1735
1736 int
1737 ada_is_array_descriptor_type (struct type *type)
1738 {
1739   struct type *data_type = desc_data_target_type (type);
1740
1741   if (type == NULL)
1742     return 0;
1743   type = ada_check_typedef (type);
1744   return (data_type != NULL
1745           && data_type->code () == TYPE_CODE_ARRAY
1746           && desc_arity (desc_bounds_type (type)) > 0);
1747 }
1748
1749 /* Non-zero iff type is a partially mal-formed GNAT array
1750    descriptor.  FIXME: This is to compensate for some problems with
1751    debugging output from GNAT.  Re-examine periodically to see if it
1752    is still needed.  */
1753
1754 int
1755 ada_is_bogus_array_descriptor (struct type *type)
1756 {
1757   return
1758     type != NULL
1759     && type->code () == TYPE_CODE_STRUCT
1760     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1761         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1762     && !ada_is_array_descriptor_type (type);
1763 }
1764
1765
1766 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1767    (fat pointer) returns the type of the array data described---specifically,
1768    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
1769    in from the descriptor; otherwise, they are left unspecified.  If
1770    the ARR denotes a null array descriptor and BOUNDS is non-zero,
1771    returns NULL.  The result is simply the type of ARR if ARR is not
1772    a descriptor.  */
1773
1774 static struct type *
1775 ada_type_of_array (struct value *arr, int bounds)
1776 {
1777   if (ada_is_constrained_packed_array_type (value_type (arr)))
1778     return decode_constrained_packed_array_type (value_type (arr));
1779
1780   if (!ada_is_array_descriptor_type (value_type (arr)))
1781     return value_type (arr);
1782
1783   if (!bounds)
1784     {
1785       struct type *array_type =
1786         ada_check_typedef (desc_data_target_type (value_type (arr)));
1787
1788       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1789         TYPE_FIELD_BITSIZE (array_type, 0) =
1790           decode_packed_array_bitsize (value_type (arr));
1791       
1792       return array_type;
1793     }
1794   else
1795     {
1796       struct type *elt_type;
1797       int arity;
1798       struct value *descriptor;
1799
1800       elt_type = ada_array_element_type (value_type (arr), -1);
1801       arity = ada_array_arity (value_type (arr));
1802
1803       if (elt_type == NULL || arity == 0)
1804         return ada_check_typedef (value_type (arr));
1805
1806       descriptor = desc_bounds (arr);
1807       if (value_as_long (descriptor) == 0)
1808         return NULL;
1809       while (arity > 0)
1810         {
1811           struct type *range_type = alloc_type_copy (value_type (arr));
1812           struct type *array_type = alloc_type_copy (value_type (arr));
1813           struct value *low = desc_one_bound (descriptor, arity, 0);
1814           struct value *high = desc_one_bound (descriptor, arity, 1);
1815
1816           arity -= 1;
1817           create_static_range_type (range_type, value_type (low),
1818                                     longest_to_int (value_as_long (low)),
1819                                     longest_to_int (value_as_long (high)));
1820           elt_type = create_array_type (array_type, elt_type, range_type);
1821
1822           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1823             {
1824               /* We need to store the element packed bitsize, as well as
1825                  recompute the array size, because it was previously
1826                  computed based on the unpacked element size.  */
1827               LONGEST lo = value_as_long (low);
1828               LONGEST hi = value_as_long (high);
1829
1830               TYPE_FIELD_BITSIZE (elt_type, 0) =
1831                 decode_packed_array_bitsize (value_type (arr));
1832               /* If the array has no element, then the size is already
1833                  zero, and does not need to be recomputed.  */
1834               if (lo < hi)
1835                 {
1836                   int array_bitsize =
1837                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1838
1839                   TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1840                 }
1841             }
1842         }
1843
1844       return lookup_pointer_type (elt_type);
1845     }
1846 }
1847
1848 /* If ARR does not represent an array, returns ARR unchanged.
1849    Otherwise, returns either a standard GDB array with bounds set
1850    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1851    GDB array.  Returns NULL if ARR is a null fat pointer.  */
1852
1853 struct value *
1854 ada_coerce_to_simple_array_ptr (struct value *arr)
1855 {
1856   if (ada_is_array_descriptor_type (value_type (arr)))
1857     {
1858       struct type *arrType = ada_type_of_array (arr, 1);
1859
1860       if (arrType == NULL)
1861         return NULL;
1862       return value_cast (arrType, value_copy (desc_data (arr)));
1863     }
1864   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1865     return decode_constrained_packed_array (arr);
1866   else
1867     return arr;
1868 }
1869
1870 /* If ARR does not represent an array, returns ARR unchanged.
1871    Otherwise, returns a standard GDB array describing ARR (which may
1872    be ARR itself if it already is in the proper form).  */
1873
1874 struct value *
1875 ada_coerce_to_simple_array (struct value *arr)
1876 {
1877   if (ada_is_array_descriptor_type (value_type (arr)))
1878     {
1879       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1880
1881       if (arrVal == NULL)
1882         error (_("Bounds unavailable for null array pointer."));
1883       return value_ind (arrVal);
1884     }
1885   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1886     return decode_constrained_packed_array (arr);
1887   else
1888     return arr;
1889 }
1890
1891 /* If TYPE represents a GNAT array type, return it translated to an
1892    ordinary GDB array type (possibly with BITSIZE fields indicating
1893    packing).  For other types, is the identity.  */
1894
1895 struct type *
1896 ada_coerce_to_simple_array_type (struct type *type)
1897 {
1898   if (ada_is_constrained_packed_array_type (type))
1899     return decode_constrained_packed_array_type (type);
1900
1901   if (ada_is_array_descriptor_type (type))
1902     return ada_check_typedef (desc_data_target_type (type));
1903
1904   return type;
1905 }
1906
1907 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
1908
1909 static int
1910 ada_is_gnat_encoded_packed_array_type  (struct type *type)
1911 {
1912   if (type == NULL)
1913     return 0;
1914   type = desc_base_type (type);
1915   type = ada_check_typedef (type);
1916   return
1917     ada_type_name (type) != NULL
1918     && strstr (ada_type_name (type), "___XP") != NULL;
1919 }
1920
1921 /* Non-zero iff TYPE represents a standard GNAT constrained
1922    packed-array type.  */
1923
1924 int
1925 ada_is_constrained_packed_array_type (struct type *type)
1926 {
1927   return ada_is_gnat_encoded_packed_array_type (type)
1928     && !ada_is_array_descriptor_type (type);
1929 }
1930
1931 /* Non-zero iff TYPE represents an array descriptor for a
1932    unconstrained packed-array type.  */
1933
1934 static int
1935 ada_is_unconstrained_packed_array_type (struct type *type)
1936 {
1937   if (!ada_is_array_descriptor_type (type))
1938     return 0;
1939
1940   if (ada_is_gnat_encoded_packed_array_type (type))
1941     return 1;
1942
1943   /* If we saw GNAT encodings, then the above code is sufficient.
1944      However, with minimal encodings, we will just have a thick
1945      pointer instead.  */
1946   if (is_thick_pntr (type))
1947     {
1948       type = desc_base_type (type);
1949       /* The structure's first field is a pointer to an array, so this
1950          fetches the array type.  */
1951       type = TYPE_TARGET_TYPE (type->field (0).type ());
1952       /* Now we can see if the array elements are packed.  */
1953       return TYPE_FIELD_BITSIZE (type, 0) > 0;
1954     }
1955
1956   return 0;
1957 }
1958
1959 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
1960    type, or if it is an ordinary (non-Gnat-encoded) packed array.  */
1961
1962 static bool
1963 ada_is_any_packed_array_type (struct type *type)
1964 {
1965   return (ada_is_constrained_packed_array_type (type)
1966           || (type->code () == TYPE_CODE_ARRAY
1967               && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
1968 }
1969
1970 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
1971    return the size of its elements in bits.  */
1972
1973 static long
1974 decode_packed_array_bitsize (struct type *type)
1975 {
1976   const char *raw_name;
1977   const char *tail;
1978   long bits;
1979
1980   /* Access to arrays implemented as fat pointers are encoded as a typedef
1981      of the fat pointer type.  We need the name of the fat pointer type
1982      to do the decoding, so strip the typedef layer.  */
1983   if (type->code () == TYPE_CODE_TYPEDEF)
1984     type = ada_typedef_target_type (type);
1985
1986   raw_name = ada_type_name (ada_check_typedef (type));
1987   if (!raw_name)
1988     raw_name = ada_type_name (desc_base_type (type));
1989
1990   if (!raw_name)
1991     return 0;
1992
1993   tail = strstr (raw_name, "___XP");
1994   if (tail == nullptr)
1995     {
1996       gdb_assert (is_thick_pntr (type));
1997       /* The structure's first field is a pointer to an array, so this
1998          fetches the array type.  */
1999       type = TYPE_TARGET_TYPE (type->field (0).type ());
2000       /* Now we can see if the array elements are packed.  */
2001       return TYPE_FIELD_BITSIZE (type, 0);
2002     }
2003
2004   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2005     {
2006       lim_warning
2007         (_("could not understand bit size information on packed array"));
2008       return 0;
2009     }
2010
2011   return bits;
2012 }
2013
2014 /* Given that TYPE is a standard GDB array type with all bounds filled
2015    in, and that the element size of its ultimate scalar constituents
2016    (that is, either its elements, or, if it is an array of arrays, its
2017    elements' elements, etc.) is *ELT_BITS, return an identical type,
2018    but with the bit sizes of its elements (and those of any
2019    constituent arrays) recorded in the BITSIZE components of its
2020    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2021    in bits.
2022
2023    Note that, for arrays whose index type has an XA encoding where
2024    a bound references a record discriminant, getting that discriminant,
2025    and therefore the actual value of that bound, is not possible
2026    because none of the given parameters gives us access to the record.
2027    This function assumes that it is OK in the context where it is being
2028    used to return an array whose bounds are still dynamic and where
2029    the length is arbitrary.  */
2030
2031 static struct type *
2032 constrained_packed_array_type (struct type *type, long *elt_bits)
2033 {
2034   struct type *new_elt_type;
2035   struct type *new_type;
2036   struct type *index_type_desc;
2037   struct type *index_type;
2038   LONGEST low_bound, high_bound;
2039
2040   type = ada_check_typedef (type);
2041   if (type->code () != TYPE_CODE_ARRAY)
2042     return type;
2043
2044   index_type_desc = ada_find_parallel_type (type, "___XA");
2045   if (index_type_desc)
2046     index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2047                                       NULL);
2048   else
2049     index_type = type->index_type ();
2050
2051   new_type = alloc_type_copy (type);
2052   new_elt_type =
2053     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2054                                    elt_bits);
2055   create_array_type (new_type, new_elt_type, index_type);
2056   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2057   new_type->set_name (ada_type_name (type));
2058
2059   if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2060        && is_dynamic_type (check_typedef (index_type)))
2061       || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2062     low_bound = high_bound = 0;
2063   if (high_bound < low_bound)
2064     *elt_bits = TYPE_LENGTH (new_type) = 0;
2065   else
2066     {
2067       *elt_bits *= (high_bound - low_bound + 1);
2068       TYPE_LENGTH (new_type) =
2069         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2070     }
2071
2072   new_type->set_is_fixed_instance (true);
2073   return new_type;
2074 }
2075
2076 /* The array type encoded by TYPE, where
2077    ada_is_constrained_packed_array_type (TYPE).  */
2078
2079 static struct type *
2080 decode_constrained_packed_array_type (struct type *type)
2081 {
2082   const char *raw_name = ada_type_name (ada_check_typedef (type));
2083   char *name;
2084   const char *tail;
2085   struct type *shadow_type;
2086   long bits;
2087
2088   if (!raw_name)
2089     raw_name = ada_type_name (desc_base_type (type));
2090
2091   if (!raw_name)
2092     return NULL;
2093
2094   name = (char *) alloca (strlen (raw_name) + 1);
2095   tail = strstr (raw_name, "___XP");
2096   type = desc_base_type (type);
2097
2098   memcpy (name, raw_name, tail - raw_name);
2099   name[tail - raw_name] = '\000';
2100
2101   shadow_type = ada_find_parallel_type_with_name (type, name);
2102
2103   if (shadow_type == NULL)
2104     {
2105       lim_warning (_("could not find bounds information on packed array"));
2106       return NULL;
2107     }
2108   shadow_type = check_typedef (shadow_type);
2109
2110   if (shadow_type->code () != TYPE_CODE_ARRAY)
2111     {
2112       lim_warning (_("could not understand bounds "
2113                      "information on packed array"));
2114       return NULL;
2115     }
2116
2117   bits = decode_packed_array_bitsize (type);
2118   return constrained_packed_array_type (shadow_type, &bits);
2119 }
2120
2121 /* Helper function for decode_constrained_packed_array.  Set the field
2122    bitsize on a series of packed arrays.  Returns the number of
2123    elements in TYPE.  */
2124
2125 static LONGEST
2126 recursively_update_array_bitsize (struct type *type)
2127 {
2128   gdb_assert (type->code () == TYPE_CODE_ARRAY);
2129
2130   LONGEST low, high;
2131   if (!get_discrete_bounds (type->index_type (), &low, &high)
2132       || low > high)
2133     return 0;
2134   LONGEST our_len = high - low + 1;
2135
2136   struct type *elt_type = TYPE_TARGET_TYPE (type);
2137   if (elt_type->code () == TYPE_CODE_ARRAY)
2138     {
2139       LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2140       LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2141       TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2142
2143       TYPE_LENGTH (type) = ((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2144                             / HOST_CHAR_BIT);
2145     }
2146
2147   return our_len;
2148 }
2149
2150 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2151    array, returns a simple array that denotes that array.  Its type is a
2152    standard GDB array type except that the BITSIZEs of the array
2153    target types are set to the number of bits in each element, and the
2154    type length is set appropriately.  */
2155
2156 static struct value *
2157 decode_constrained_packed_array (struct value *arr)
2158 {
2159   struct type *type;
2160
2161   /* If our value is a pointer, then dereference it. Likewise if
2162      the value is a reference.  Make sure that this operation does not
2163      cause the target type to be fixed, as this would indirectly cause
2164      this array to be decoded.  The rest of the routine assumes that
2165      the array hasn't been decoded yet, so we use the basic "coerce_ref"
2166      and "value_ind" routines to perform the dereferencing, as opposed
2167      to using "ada_coerce_ref" or "ada_value_ind".  */
2168   arr = coerce_ref (arr);
2169   if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2170     arr = value_ind (arr);
2171
2172   type = decode_constrained_packed_array_type (value_type (arr));
2173   if (type == NULL)
2174     {
2175       error (_("can't unpack array"));
2176       return NULL;
2177     }
2178
2179   /* Decoding the packed array type could not correctly set the field
2180      bitsizes for any dimension except the innermost, because the
2181      bounds may be variable and were not passed to that function.  So,
2182      we further resolve the array bounds here and then update the
2183      sizes.  */
2184   const gdb_byte *valaddr = value_contents_for_printing (arr);
2185   CORE_ADDR address = value_address (arr);
2186   gdb::array_view<const gdb_byte> view
2187     = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
2188   type = resolve_dynamic_type (type, view, address);
2189   recursively_update_array_bitsize (type);
2190
2191   if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2192       && ada_is_modular_type (value_type (arr)))
2193     {
2194        /* This is a (right-justified) modular type representing a packed
2195           array with no wrapper.  In order to interpret the value through
2196           the (left-justified) packed array type we just built, we must
2197           first left-justify it.  */
2198       int bit_size, bit_pos;
2199       ULONGEST mod;
2200
2201       mod = ada_modulus (value_type (arr)) - 1;
2202       bit_size = 0;
2203       while (mod > 0)
2204         {
2205           bit_size += 1;
2206           mod >>= 1;
2207         }
2208       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2209       arr = ada_value_primitive_packed_val (arr, NULL,
2210                                             bit_pos / HOST_CHAR_BIT,
2211                                             bit_pos % HOST_CHAR_BIT,
2212                                             bit_size,
2213                                             type);
2214     }
2215
2216   return coerce_unspec_val_to_type (arr, type);
2217 }
2218
2219
2220 /* The value of the element of packed array ARR at the ARITY indices
2221    given in IND.   ARR must be a simple array.  */
2222
2223 static struct value *
2224 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2225 {
2226   int i;
2227   int bits, elt_off, bit_off;
2228   long elt_total_bit_offset;
2229   struct type *elt_type;
2230   struct value *v;
2231
2232   bits = 0;
2233   elt_total_bit_offset = 0;
2234   elt_type = ada_check_typedef (value_type (arr));
2235   for (i = 0; i < arity; i += 1)
2236     {
2237       if (elt_type->code () != TYPE_CODE_ARRAY
2238           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2239         error
2240           (_("attempt to do packed indexing of "
2241              "something other than a packed array"));
2242       else
2243         {
2244           struct type *range_type = elt_type->index_type ();
2245           LONGEST lowerbound, upperbound;
2246           LONGEST idx;
2247
2248           if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2249             {
2250               lim_warning (_("don't know bounds of array"));
2251               lowerbound = upperbound = 0;
2252             }
2253
2254           idx = pos_atr (ind[i]);
2255           if (idx < lowerbound || idx > upperbound)
2256             lim_warning (_("packed array index %ld out of bounds"),
2257                          (long) idx);
2258           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2259           elt_total_bit_offset += (idx - lowerbound) * bits;
2260           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2261         }
2262     }
2263   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2264   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2265
2266   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2267                                       bits, elt_type);
2268   return v;
2269 }
2270
2271 /* Non-zero iff TYPE includes negative integer values.  */
2272
2273 static int
2274 has_negatives (struct type *type)
2275 {
2276   switch (type->code ())
2277     {
2278     default:
2279       return 0;
2280     case TYPE_CODE_INT:
2281       return !type->is_unsigned ();
2282     case TYPE_CODE_RANGE:
2283       return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2284     }
2285 }
2286
2287 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2288    unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
2289    the unpacked buffer.
2290
2291    The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2292    enough to contain at least BIT_OFFSET bits.  If not, an error is raised.
2293
2294    IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2295    zero otherwise.
2296
2297    IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2298
2299    IS_SCALAR is nonzero if the data corresponds to a signed type.  */
2300
2301 static void
2302 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2303                           gdb_byte *unpacked, int unpacked_len,
2304                           int is_big_endian, int is_signed_type,
2305                           int is_scalar)
2306 {
2307   int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2308   int src_idx;                  /* Index into the source area */
2309   int src_bytes_left;           /* Number of source bytes left to process.  */
2310   int srcBitsLeft;              /* Number of source bits left to move */
2311   int unusedLS;                 /* Number of bits in next significant
2312                                    byte of source that are unused */
2313
2314   int unpacked_idx;             /* Index into the unpacked buffer */
2315   int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */
2316
2317   unsigned long accum;          /* Staging area for bits being transferred */
2318   int accumSize;                /* Number of meaningful bits in accum */
2319   unsigned char sign;
2320
2321   /* Transmit bytes from least to most significant; delta is the direction
2322      the indices move.  */
2323   int delta = is_big_endian ? -1 : 1;
2324
2325   /* Make sure that unpacked is large enough to receive the BIT_SIZE
2326      bits from SRC.  .*/
2327   if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2328     error (_("Cannot unpack %d bits into buffer of %d bytes"),
2329            bit_size, unpacked_len);
2330
2331   srcBitsLeft = bit_size;
2332   src_bytes_left = src_len;
2333   unpacked_bytes_left = unpacked_len;
2334   sign = 0;
2335
2336   if (is_big_endian)
2337     {
2338       src_idx = src_len - 1;
2339       if (is_signed_type
2340           && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2341         sign = ~0;
2342
2343       unusedLS =
2344         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2345         % HOST_CHAR_BIT;
2346
2347       if (is_scalar)
2348         {
2349           accumSize = 0;
2350           unpacked_idx = unpacked_len - 1;
2351         }
2352       else
2353         {
2354           /* Non-scalar values must be aligned at a byte boundary...  */
2355           accumSize =
2356             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2357           /* ... And are placed at the beginning (most-significant) bytes
2358              of the target.  */
2359           unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2360           unpacked_bytes_left = unpacked_idx + 1;
2361         }
2362     }
2363   else
2364     {
2365       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2366
2367       src_idx = unpacked_idx = 0;
2368       unusedLS = bit_offset;
2369       accumSize = 0;
2370
2371       if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2372         sign = ~0;
2373     }
2374
2375   accum = 0;
2376   while (src_bytes_left > 0)
2377     {
2378       /* Mask for removing bits of the next source byte that are not
2379          part of the value.  */
2380       unsigned int unusedMSMask =
2381         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2382         1;
2383       /* Sign-extend bits for this byte.  */
2384       unsigned int signMask = sign & ~unusedMSMask;
2385
2386       accum |=
2387         (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2388       accumSize += HOST_CHAR_BIT - unusedLS;
2389       if (accumSize >= HOST_CHAR_BIT)
2390         {
2391           unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2392           accumSize -= HOST_CHAR_BIT;
2393           accum >>= HOST_CHAR_BIT;
2394           unpacked_bytes_left -= 1;
2395           unpacked_idx += delta;
2396         }
2397       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2398       unusedLS = 0;
2399       src_bytes_left -= 1;
2400       src_idx += delta;
2401     }
2402   while (unpacked_bytes_left > 0)
2403     {
2404       accum |= sign << accumSize;
2405       unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2406       accumSize -= HOST_CHAR_BIT;
2407       if (accumSize < 0)
2408         accumSize = 0;
2409       accum >>= HOST_CHAR_BIT;
2410       unpacked_bytes_left -= 1;
2411       unpacked_idx += delta;
2412     }
2413 }
2414
2415 /* Create a new value of type TYPE from the contents of OBJ starting
2416    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2417    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2418    assigning through the result will set the field fetched from.
2419    VALADDR is ignored unless OBJ is NULL, in which case,
2420    VALADDR+OFFSET must address the start of storage containing the 
2421    packed value.  The value returned  in this case is never an lval.
2422    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2423
2424 struct value *
2425 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2426                                 long offset, int bit_offset, int bit_size,
2427                                 struct type *type)
2428 {
2429   struct value *v;
2430   const gdb_byte *src;                /* First byte containing data to unpack */
2431   gdb_byte *unpacked;
2432   const int is_scalar = is_scalar_type (type);
2433   const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2434   gdb::byte_vector staging;
2435
2436   type = ada_check_typedef (type);
2437
2438   if (obj == NULL)
2439     src = valaddr + offset;
2440   else
2441     src = value_contents (obj) + offset;
2442
2443   if (is_dynamic_type (type))
2444     {
2445       /* The length of TYPE might by dynamic, so we need to resolve
2446          TYPE in order to know its actual size, which we then use
2447          to create the contents buffer of the value we return.
2448          The difficulty is that the data containing our object is
2449          packed, and therefore maybe not at a byte boundary.  So, what
2450          we do, is unpack the data into a byte-aligned buffer, and then
2451          use that buffer as our object's value for resolving the type.  */
2452       int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2453       staging.resize (staging_len);
2454
2455       ada_unpack_from_contents (src, bit_offset, bit_size,
2456                                 staging.data (), staging.size (),
2457                                 is_big_endian, has_negatives (type),
2458                                 is_scalar);
2459       type = resolve_dynamic_type (type, staging, 0);
2460       if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2461         {
2462           /* This happens when the length of the object is dynamic,
2463              and is actually smaller than the space reserved for it.
2464              For instance, in an array of variant records, the bit_size
2465              we're given is the array stride, which is constant and
2466              normally equal to the maximum size of its element.
2467              But, in reality, each element only actually spans a portion
2468              of that stride.  */
2469           bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2470         }
2471     }
2472
2473   if (obj == NULL)
2474     {
2475       v = allocate_value (type);
2476       src = valaddr + offset;
2477     }
2478   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2479     {
2480       int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2481       gdb_byte *buf;
2482
2483       v = value_at (type, value_address (obj) + offset);
2484       buf = (gdb_byte *) alloca (src_len);
2485       read_memory (value_address (v), buf, src_len);
2486       src = buf;
2487     }
2488   else
2489     {
2490       v = allocate_value (type);
2491       src = value_contents (obj) + offset;
2492     }
2493
2494   if (obj != NULL)
2495     {
2496       long new_offset = offset;
2497
2498       set_value_component_location (v, obj);
2499       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2500       set_value_bitsize (v, bit_size);
2501       if (value_bitpos (v) >= HOST_CHAR_BIT)
2502         {
2503           ++new_offset;
2504           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2505         }
2506       set_value_offset (v, new_offset);
2507
2508       /* Also set the parent value.  This is needed when trying to
2509          assign a new value (in inferior memory).  */
2510       set_value_parent (v, obj);
2511     }
2512   else
2513     set_value_bitsize (v, bit_size);
2514   unpacked = value_contents_writeable (v);
2515
2516   if (bit_size == 0)
2517     {
2518       memset (unpacked, 0, TYPE_LENGTH (type));
2519       return v;
2520     }
2521
2522   if (staging.size () == TYPE_LENGTH (type))
2523     {
2524       /* Small short-cut: If we've unpacked the data into a buffer
2525          of the same size as TYPE's length, then we can reuse that,
2526          instead of doing the unpacking again.  */
2527       memcpy (unpacked, staging.data (), staging.size ());
2528     }
2529   else
2530     ada_unpack_from_contents (src, bit_offset, bit_size,
2531                               unpacked, TYPE_LENGTH (type),
2532                               is_big_endian, has_negatives (type), is_scalar);
2533
2534   return v;
2535 }
2536
2537 /* Store the contents of FROMVAL into the location of TOVAL.
2538    Return a new value with the location of TOVAL and contents of
2539    FROMVAL.   Handles assignment into packed fields that have
2540    floating-point or non-scalar types.  */
2541
2542 static struct value *
2543 ada_value_assign (struct value *toval, struct value *fromval)
2544 {
2545   struct type *type = value_type (toval);
2546   int bits = value_bitsize (toval);
2547
2548   toval = ada_coerce_ref (toval);
2549   fromval = ada_coerce_ref (fromval);
2550
2551   if (ada_is_direct_array_type (value_type (toval)))
2552     toval = ada_coerce_to_simple_array (toval);
2553   if (ada_is_direct_array_type (value_type (fromval)))
2554     fromval = ada_coerce_to_simple_array (fromval);
2555
2556   if (!deprecated_value_modifiable (toval))
2557     error (_("Left operand of assignment is not a modifiable lvalue."));
2558
2559   if (VALUE_LVAL (toval) == lval_memory
2560       && bits > 0
2561       && (type->code () == TYPE_CODE_FLT
2562           || type->code () == TYPE_CODE_STRUCT))
2563     {
2564       int len = (value_bitpos (toval)
2565                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2566       int from_size;
2567       gdb_byte *buffer = (gdb_byte *) alloca (len);
2568       struct value *val;
2569       CORE_ADDR to_addr = value_address (toval);
2570
2571       if (type->code () == TYPE_CODE_FLT)
2572         fromval = value_cast (type, fromval);
2573
2574       read_memory (to_addr, buffer, len);
2575       from_size = value_bitsize (fromval);
2576       if (from_size == 0)
2577         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2578
2579       const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2580       ULONGEST from_offset = 0;
2581       if (is_big_endian && is_scalar_type (value_type (fromval)))
2582         from_offset = from_size - bits;
2583       copy_bitwise (buffer, value_bitpos (toval),
2584                     value_contents (fromval), from_offset,
2585                     bits, is_big_endian);
2586       write_memory_with_notification (to_addr, buffer, len);
2587
2588       val = value_copy (toval);
2589       memcpy (value_contents_raw (val), value_contents (fromval),
2590               TYPE_LENGTH (type));
2591       deprecated_set_value_type (val, type);
2592
2593       return val;
2594     }
2595
2596   return value_assign (toval, fromval);
2597 }
2598
2599
2600 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2601    CONTAINER, assign the contents of VAL to COMPONENTS's place in
2602    CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2603    COMPONENT, and not the inferior's memory.  The current contents
2604    of COMPONENT are ignored.
2605
2606    Although not part of the initial design, this function also works
2607    when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2608    had a null address, and COMPONENT had an address which is equal to
2609    its offset inside CONTAINER.  */
2610
2611 static void
2612 value_assign_to_component (struct value *container, struct value *component,
2613                            struct value *val)
2614 {
2615   LONGEST offset_in_container =
2616     (LONGEST)  (value_address (component) - value_address (container));
2617   int bit_offset_in_container =
2618     value_bitpos (component) - value_bitpos (container);
2619   int bits;
2620
2621   val = value_cast (value_type (component), val);
2622
2623   if (value_bitsize (component) == 0)
2624     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2625   else
2626     bits = value_bitsize (component);
2627
2628   if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2629     {
2630       int src_offset;
2631
2632       if (is_scalar_type (check_typedef (value_type (component))))
2633         src_offset
2634           = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2635       else
2636         src_offset = 0;
2637       copy_bitwise (value_contents_writeable (container) + offset_in_container,
2638                     value_bitpos (container) + bit_offset_in_container,
2639                     value_contents (val), src_offset, bits, 1);
2640     }
2641   else
2642     copy_bitwise (value_contents_writeable (container) + offset_in_container,
2643                   value_bitpos (container) + bit_offset_in_container,
2644                   value_contents (val), 0, bits, 0);
2645 }
2646
2647 /* Determine if TYPE is an access to an unconstrained array.  */
2648
2649 bool
2650 ada_is_access_to_unconstrained_array (struct type *type)
2651 {
2652   return (type->code () == TYPE_CODE_TYPEDEF
2653           && is_thick_pntr (ada_typedef_target_type (type)));
2654 }
2655
2656 /* The value of the element of array ARR at the ARITY indices given in IND.
2657    ARR may be either a simple array, GNAT array descriptor, or pointer
2658    thereto.  */
2659
2660 struct value *
2661 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2662 {
2663   int k;
2664   struct value *elt;
2665   struct type *elt_type;
2666
2667   elt = ada_coerce_to_simple_array (arr);
2668
2669   elt_type = ada_check_typedef (value_type (elt));
2670   if (elt_type->code () == TYPE_CODE_ARRAY
2671       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2672     return value_subscript_packed (elt, arity, ind);
2673
2674   for (k = 0; k < arity; k += 1)
2675     {
2676       struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
2677
2678       if (elt_type->code () != TYPE_CODE_ARRAY)
2679         error (_("too many subscripts (%d expected)"), k);
2680
2681       elt = value_subscript (elt, pos_atr (ind[k]));
2682
2683       if (ada_is_access_to_unconstrained_array (saved_elt_type)
2684           && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
2685         {
2686           /* The element is a typedef to an unconstrained array,
2687              except that the value_subscript call stripped the
2688              typedef layer.  The typedef layer is GNAT's way to
2689              specify that the element is, at the source level, an
2690              access to the unconstrained array, rather than the
2691              unconstrained array.  So, we need to restore that
2692              typedef layer, which we can do by forcing the element's
2693              type back to its original type. Otherwise, the returned
2694              value is going to be printed as the array, rather
2695              than as an access.  Another symptom of the same issue
2696              would be that an expression trying to dereference the
2697              element would also be improperly rejected.  */
2698           deprecated_set_value_type (elt, saved_elt_type);
2699         }
2700
2701       elt_type = ada_check_typedef (value_type (elt));
2702     }
2703
2704   return elt;
2705 }
2706
2707 /* Assuming ARR is a pointer to a GDB array, the value of the element
2708    of *ARR at the ARITY indices given in IND.
2709    Does not read the entire array into memory.
2710
2711    Note: Unlike what one would expect, this function is used instead of
2712    ada_value_subscript for basically all non-packed array types.  The reason
2713    for this is that a side effect of doing our own pointer arithmetics instead
2714    of relying on value_subscript is that there is no implicit typedef peeling.
2715    This is important for arrays of array accesses, where it allows us to
2716    preserve the fact that the array's element is an array access, where the
2717    access part os encoded in a typedef layer.  */
2718
2719 static struct value *
2720 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2721 {
2722   int k;
2723   struct value *array_ind = ada_value_ind (arr);
2724   struct type *type
2725     = check_typedef (value_enclosing_type (array_ind));
2726
2727   if (type->code () == TYPE_CODE_ARRAY
2728       && TYPE_FIELD_BITSIZE (type, 0) > 0)
2729     return value_subscript_packed (array_ind, arity, ind);
2730
2731   for (k = 0; k < arity; k += 1)
2732     {
2733       LONGEST lwb, upb;
2734
2735       if (type->code () != TYPE_CODE_ARRAY)
2736         error (_("too many subscripts (%d expected)"), k);
2737       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2738                         value_copy (arr));
2739       get_discrete_bounds (type->index_type (), &lwb, &upb);
2740       arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
2741       type = TYPE_TARGET_TYPE (type);
2742     }
2743
2744   return value_ind (arr);
2745 }
2746
2747 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2748    actual type of ARRAY_PTR is ignored), returns the Ada slice of
2749    HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
2750    this array is LOW, as per Ada rules.  */
2751 static struct value *
2752 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2753                           int low, int high)
2754 {
2755   struct type *type0 = ada_check_typedef (type);
2756   struct type *base_index_type = TYPE_TARGET_TYPE (type0->index_type ());
2757   struct type *index_type
2758     = create_static_range_type (NULL, base_index_type, low, high);
2759   struct type *slice_type = create_array_type_with_stride
2760                               (NULL, TYPE_TARGET_TYPE (type0), index_type,
2761                                type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
2762                                TYPE_FIELD_BITSIZE (type0, 0));
2763   int base_low =  ada_discrete_type_low_bound (type0->index_type ());
2764   gdb::optional<LONGEST> base_low_pos, low_pos;
2765   CORE_ADDR base;
2766
2767   low_pos = discrete_position (base_index_type, low);
2768   base_low_pos = discrete_position (base_index_type, base_low);
2769
2770   if (!low_pos.has_value () || !base_low_pos.has_value ())
2771     {
2772       warning (_("unable to get positions in slice, use bounds instead"));
2773       low_pos = low;
2774       base_low_pos = base_low;
2775     }
2776
2777   ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
2778   if (stride == 0)
2779     stride = TYPE_LENGTH (TYPE_TARGET_TYPE (type0));
2780
2781   base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
2782   return value_at_lazy (slice_type, base);
2783 }
2784
2785
2786 static struct value *
2787 ada_value_slice (struct value *array, int low, int high)
2788 {
2789   struct type *type = ada_check_typedef (value_type (array));
2790   struct type *base_index_type = TYPE_TARGET_TYPE (type->index_type ());
2791   struct type *index_type
2792     = create_static_range_type (NULL, type->index_type (), low, high);
2793   struct type *slice_type = create_array_type_with_stride
2794                               (NULL, TYPE_TARGET_TYPE (type), index_type,
2795                                type->dyn_prop (DYN_PROP_BYTE_STRIDE),
2796                                TYPE_FIELD_BITSIZE (type, 0));
2797   gdb::optional<LONGEST> low_pos, high_pos;
2798
2799
2800   low_pos = discrete_position (base_index_type, low);
2801   high_pos = discrete_position (base_index_type, high);
2802
2803   if (!low_pos.has_value () || !high_pos.has_value ())
2804     {
2805       warning (_("unable to get positions in slice, use bounds instead"));
2806       low_pos = low;
2807       high_pos = high;
2808     }
2809
2810   return value_cast (slice_type,
2811                      value_slice (array, low, *high_pos - *low_pos + 1));
2812 }
2813
2814 /* If type is a record type in the form of a standard GNAT array
2815    descriptor, returns the number of dimensions for type.  If arr is a
2816    simple array, returns the number of "array of"s that prefix its
2817    type designation.  Otherwise, returns 0.  */
2818
2819 int
2820 ada_array_arity (struct type *type)
2821 {
2822   int arity;
2823
2824   if (type == NULL)
2825     return 0;
2826
2827   type = desc_base_type (type);
2828
2829   arity = 0;
2830   if (type->code () == TYPE_CODE_STRUCT)
2831     return desc_arity (desc_bounds_type (type));
2832   else
2833     while (type->code () == TYPE_CODE_ARRAY)
2834       {
2835         arity += 1;
2836         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2837       }
2838
2839   return arity;
2840 }
2841
2842 /* If TYPE is a record type in the form of a standard GNAT array
2843    descriptor or a simple array type, returns the element type for
2844    TYPE after indexing by NINDICES indices, or by all indices if
2845    NINDICES is -1.  Otherwise, returns NULL.  */
2846
2847 struct type *
2848 ada_array_element_type (struct type *type, int nindices)
2849 {
2850   type = desc_base_type (type);
2851
2852   if (type->code () == TYPE_CODE_STRUCT)
2853     {
2854       int k;
2855       struct type *p_array_type;
2856
2857       p_array_type = desc_data_target_type (type);
2858
2859       k = ada_array_arity (type);
2860       if (k == 0)
2861         return NULL;
2862
2863       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
2864       if (nindices >= 0 && k > nindices)
2865         k = nindices;
2866       while (k > 0 && p_array_type != NULL)
2867         {
2868           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2869           k -= 1;
2870         }
2871       return p_array_type;
2872     }
2873   else if (type->code () == TYPE_CODE_ARRAY)
2874     {
2875       while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
2876         {
2877           type = TYPE_TARGET_TYPE (type);
2878           nindices -= 1;
2879         }
2880       return type;
2881     }
2882
2883   return NULL;
2884 }
2885
2886 /* See ada-lang.h.  */
2887
2888 struct type *
2889 ada_index_type (struct type *type, int n, const char *name)
2890 {
2891   struct type *result_type;
2892
2893   type = desc_base_type (type);
2894
2895   if (n < 0 || n > ada_array_arity (type))
2896     error (_("invalid dimension number to '%s"), name);
2897
2898   if (ada_is_simple_array_type (type))
2899     {
2900       int i;
2901
2902       for (i = 1; i < n; i += 1)
2903         {
2904           type = ada_check_typedef (type);
2905           type = TYPE_TARGET_TYPE (type);
2906         }
2907       result_type = TYPE_TARGET_TYPE (ada_check_typedef (type)->index_type ());
2908       /* FIXME: The stabs type r(0,0);bound;bound in an array type
2909          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
2910          perhaps stabsread.c would make more sense.  */
2911       if (result_type && result_type->code () == TYPE_CODE_UNDEF)
2912         result_type = NULL;
2913     }
2914   else
2915     {
2916       result_type = desc_index_type (desc_bounds_type (type), n);
2917       if (result_type == NULL)
2918         error (_("attempt to take bound of something that is not an array"));
2919     }
2920
2921   return result_type;
2922 }
2923
2924 /* Given that arr is an array type, returns the lower bound of the
2925    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2926    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
2927    array-descriptor type.  It works for other arrays with bounds supplied
2928    by run-time quantities other than discriminants.  */
2929
2930 static LONGEST
2931 ada_array_bound_from_type (struct type *arr_type, int n, int which)
2932 {
2933   struct type *type, *index_type_desc, *index_type;
2934   int i;
2935
2936   gdb_assert (which == 0 || which == 1);
2937
2938   if (ada_is_constrained_packed_array_type (arr_type))
2939     arr_type = decode_constrained_packed_array_type (arr_type);
2940
2941   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2942     return (LONGEST) - which;
2943
2944   if (arr_type->code () == TYPE_CODE_PTR)
2945     type = TYPE_TARGET_TYPE (arr_type);
2946   else
2947     type = arr_type;
2948
2949   if (type->is_fixed_instance ())
2950     {
2951       /* The array has already been fixed, so we do not need to
2952          check the parallel ___XA type again.  That encoding has
2953          already been applied, so ignore it now.  */
2954       index_type_desc = NULL;
2955     }
2956   else
2957     {
2958       index_type_desc = ada_find_parallel_type (type, "___XA");
2959       ada_fixup_array_indexes_type (index_type_desc);
2960     }
2961
2962   if (index_type_desc != NULL)
2963     index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
2964                                       NULL);
2965   else
2966     {
2967       struct type *elt_type = check_typedef (type);
2968
2969       for (i = 1; i < n; i++)
2970         elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
2971
2972       index_type = elt_type->index_type ();
2973     }
2974
2975   return
2976     (LONGEST) (which == 0
2977                ? ada_discrete_type_low_bound (index_type)
2978                : ada_discrete_type_high_bound (index_type));
2979 }
2980
2981 /* Given that arr is an array value, returns the lower bound of the
2982    nth index (numbering from 1) if WHICH is 0, and the upper bound if
2983    WHICH is 1.  This routine will also work for arrays with bounds
2984    supplied by run-time quantities other than discriminants.  */
2985
2986 static LONGEST
2987 ada_array_bound (struct value *arr, int n, int which)
2988 {
2989   struct type *arr_type;
2990
2991   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2992     arr = value_ind (arr);
2993   arr_type = value_enclosing_type (arr);
2994
2995   if (ada_is_constrained_packed_array_type (arr_type))
2996     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
2997   else if (ada_is_simple_array_type (arr_type))
2998     return ada_array_bound_from_type (arr_type, n, which);
2999   else
3000     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3001 }
3002
3003 /* Given that arr is an array value, returns the length of the
3004    nth index.  This routine will also work for arrays with bounds
3005    supplied by run-time quantities other than discriminants.
3006    Does not work for arrays indexed by enumeration types with representation
3007    clauses at the moment.  */
3008
3009 static LONGEST
3010 ada_array_length (struct value *arr, int n)
3011 {
3012   struct type *arr_type, *index_type;
3013   int low, high;
3014
3015   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3016     arr = value_ind (arr);
3017   arr_type = value_enclosing_type (arr);
3018
3019   if (ada_is_constrained_packed_array_type (arr_type))
3020     return ada_array_length (decode_constrained_packed_array (arr), n);
3021
3022   if (ada_is_simple_array_type (arr_type))
3023     {
3024       low = ada_array_bound_from_type (arr_type, n, 0);
3025       high = ada_array_bound_from_type (arr_type, n, 1);
3026     }
3027   else
3028     {
3029       low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3030       high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3031     }
3032
3033   arr_type = check_typedef (arr_type);
3034   index_type = ada_index_type (arr_type, n, "length");
3035   if (index_type != NULL)
3036     {
3037       struct type *base_type;
3038       if (index_type->code () == TYPE_CODE_RANGE)
3039         base_type = TYPE_TARGET_TYPE (index_type);
3040       else
3041         base_type = index_type;
3042
3043       low = pos_atr (value_from_longest (base_type, low));
3044       high = pos_atr (value_from_longest (base_type, high));
3045     }
3046   return high - low + 1;
3047 }
3048
3049 /* An array whose type is that of ARR_TYPE (an array type), with
3050    bounds LOW to HIGH, but whose contents are unimportant.  If HIGH is
3051    less than LOW, then LOW-1 is used.  */
3052
3053 static struct value *
3054 empty_array (struct type *arr_type, int low, int high)
3055 {
3056   struct type *arr_type0 = ada_check_typedef (arr_type);
3057   struct type *index_type
3058     = create_static_range_type
3059         (NULL, TYPE_TARGET_TYPE (arr_type0->index_type ()), low,
3060          high < low ? low - 1 : high);
3061   struct type *elt_type = ada_array_element_type (arr_type0, 1);
3062
3063   return allocate_value (create_array_type (NULL, elt_type, index_type));
3064 }
3065 \f
3066
3067                                 /* Name resolution */
3068
3069 /* The "decoded" name for the user-definable Ada operator corresponding
3070    to OP.  */
3071
3072 static const char *
3073 ada_decoded_op_name (enum exp_opcode op)
3074 {
3075   int i;
3076
3077   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3078     {
3079       if (ada_opname_table[i].op == op)
3080         return ada_opname_table[i].decoded;
3081     }
3082   error (_("Could not find operator name for opcode"));
3083 }
3084
3085 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3086    in a listing of choices during disambiguation (see sort_choices, below).
3087    The idea is that overloadings of a subprogram name from the
3088    same package should sort in their source order.  We settle for ordering
3089    such symbols by their trailing number (__N  or $N).  */
3090
3091 static int
3092 encoded_ordered_before (const char *N0, const char *N1)
3093 {
3094   if (N1 == NULL)
3095     return 0;
3096   else if (N0 == NULL)
3097     return 1;
3098   else
3099     {
3100       int k0, k1;
3101
3102       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3103         ;
3104       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3105         ;
3106       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3107           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3108         {
3109           int n0, n1;
3110
3111           n0 = k0;
3112           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3113             n0 -= 1;
3114           n1 = k1;
3115           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3116             n1 -= 1;
3117           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3118             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3119         }
3120       return (strcmp (N0, N1) < 0);
3121     }
3122 }
3123
3124 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3125    encoded names.  */
3126
3127 static void
3128 sort_choices (struct block_symbol syms[], int nsyms)
3129 {
3130   int i;
3131
3132   for (i = 1; i < nsyms; i += 1)
3133     {
3134       struct block_symbol sym = syms[i];
3135       int j;
3136
3137       for (j = i - 1; j >= 0; j -= 1)
3138         {
3139           if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3140                                       sym.symbol->linkage_name ()))
3141             break;
3142           syms[j + 1] = syms[j];
3143         }
3144       syms[j + 1] = sym;
3145     }
3146 }
3147
3148 /* Whether GDB should display formals and return types for functions in the
3149    overloads selection menu.  */
3150 static bool print_signatures = true;
3151
3152 /* Print the signature for SYM on STREAM according to the FLAGS options.  For
3153    all but functions, the signature is just the name of the symbol.  For
3154    functions, this is the name of the function, the list of types for formals
3155    and the return type (if any).  */
3156
3157 static void
3158 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3159                             const struct type_print_options *flags)
3160 {
3161   struct type *type = SYMBOL_TYPE (sym);
3162
3163   fprintf_filtered (stream, "%s", sym->print_name ());
3164   if (!print_signatures
3165       || type == NULL
3166       || type->code () != TYPE_CODE_FUNC)
3167     return;
3168
3169   if (type->num_fields () > 0)
3170     {
3171       int i;
3172
3173       fprintf_filtered (stream, " (");
3174       for (i = 0; i < type->num_fields (); ++i)
3175         {
3176           if (i > 0)
3177             fprintf_filtered (stream, "; ");
3178           ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3179                           flags);
3180         }
3181       fprintf_filtered (stream, ")");
3182     }
3183   if (TYPE_TARGET_TYPE (type) != NULL
3184       && TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_VOID)
3185     {
3186       fprintf_filtered (stream, " return ");
3187       ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3188     }
3189 }
3190
3191 /* Read and validate a set of numeric choices from the user in the
3192    range 0 .. N_CHOICES-1.  Place the results in increasing
3193    order in CHOICES[0 .. N-1], and return N.
3194
3195    The user types choices as a sequence of numbers on one line
3196    separated by blanks, encoding them as follows:
3197
3198      + A choice of 0 means to cancel the selection, throwing an error.
3199      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3200      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3201
3202    The user is not allowed to choose more than MAX_RESULTS values.
3203
3204    ANNOTATION_SUFFIX, if present, is used to annotate the input
3205    prompts (for use with the -f switch).  */
3206
3207 static int
3208 get_selections (int *choices, int n_choices, int max_results,
3209                 int is_all_choice, const char *annotation_suffix)
3210 {
3211   const char *args;
3212   const char *prompt;
3213   int n_chosen;
3214   int first_choice = is_all_choice ? 2 : 1;
3215
3216   prompt = getenv ("PS2");
3217   if (prompt == NULL)
3218     prompt = "> ";
3219
3220   args = command_line_input (prompt, annotation_suffix);
3221
3222   if (args == NULL)
3223     error_no_arg (_("one or more choice numbers"));
3224
3225   n_chosen = 0;
3226
3227   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3228      order, as given in args.  Choices are validated.  */
3229   while (1)
3230     {
3231       char *args2;
3232       int choice, j;
3233
3234       args = skip_spaces (args);
3235       if (*args == '\0' && n_chosen == 0)
3236         error_no_arg (_("one or more choice numbers"));
3237       else if (*args == '\0')
3238         break;
3239
3240       choice = strtol (args, &args2, 10);
3241       if (args == args2 || choice < 0
3242           || choice > n_choices + first_choice - 1)
3243         error (_("Argument must be choice number"));
3244       args = args2;
3245
3246       if (choice == 0)
3247         error (_("cancelled"));
3248
3249       if (choice < first_choice)
3250         {
3251           n_chosen = n_choices;
3252           for (j = 0; j < n_choices; j += 1)
3253             choices[j] = j;
3254           break;
3255         }
3256       choice -= first_choice;
3257
3258       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3259         {
3260         }
3261
3262       if (j < 0 || choice != choices[j])
3263         {
3264           int k;
3265
3266           for (k = n_chosen - 1; k > j; k -= 1)
3267             choices[k + 1] = choices[k];
3268           choices[j + 1] = choice;
3269           n_chosen += 1;
3270         }
3271     }
3272
3273   if (n_chosen > max_results)
3274     error (_("Select no more than %d of the above"), max_results);
3275
3276   return n_chosen;
3277 }
3278
3279 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3280    by asking the user (if necessary), returning the number selected,
3281    and setting the first elements of SYMS items.  Error if no symbols
3282    selected.  */
3283
3284 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3285    to be re-integrated one of these days.  */
3286
3287 static int
3288 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3289 {
3290   int i;
3291   int *chosen = XALLOCAVEC (int , nsyms);
3292   int n_chosen;
3293   int first_choice = (max_results == 1) ? 1 : 2;
3294   const char *select_mode = multiple_symbols_select_mode ();
3295
3296   if (max_results < 1)
3297     error (_("Request to select 0 symbols!"));
3298   if (nsyms <= 1)
3299     return nsyms;
3300
3301   if (select_mode == multiple_symbols_cancel)
3302     error (_("\
3303 canceled because the command is ambiguous\n\
3304 See set/show multiple-symbol."));
3305
3306   /* If select_mode is "all", then return all possible symbols.
3307      Only do that if more than one symbol can be selected, of course.
3308      Otherwise, display the menu as usual.  */
3309   if (select_mode == multiple_symbols_all && max_results > 1)
3310     return nsyms;
3311
3312   printf_filtered (_("[0] cancel\n"));
3313   if (max_results > 1)
3314     printf_filtered (_("[1] all\n"));
3315
3316   sort_choices (syms, nsyms);
3317
3318   for (i = 0; i < nsyms; i += 1)
3319     {
3320       if (syms[i].symbol == NULL)
3321         continue;
3322
3323       if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
3324         {
3325           struct symtab_and_line sal =
3326             find_function_start_sal (syms[i].symbol, 1);
3327
3328           printf_filtered ("[%d] ", i + first_choice);
3329           ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3330                                       &type_print_raw_options);
3331           if (sal.symtab == NULL)
3332             printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3333                              metadata_style.style ().ptr (), nullptr, sal.line);
3334           else
3335             printf_filtered
3336               (_(" at %ps:%d\n"),
3337                styled_string (file_name_style.style (),
3338                               symtab_to_filename_for_display (sal.symtab)),
3339                sal.line);
3340           continue;
3341         }
3342       else
3343         {
3344           int is_enumeral =
3345             (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3346              && SYMBOL_TYPE (syms[i].symbol) != NULL
3347              && SYMBOL_TYPE (syms[i].symbol)->code () == TYPE_CODE_ENUM);
3348           struct symtab *symtab = NULL;
3349
3350           if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3351             symtab = symbol_symtab (syms[i].symbol);
3352
3353           if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
3354             {
3355               printf_filtered ("[%d] ", i + first_choice);
3356               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3357                                           &type_print_raw_options);
3358               printf_filtered (_(" at %s:%d\n"),
3359                                symtab_to_filename_for_display (symtab),
3360                                SYMBOL_LINE (syms[i].symbol));
3361             }
3362           else if (is_enumeral
3363                    && SYMBOL_TYPE (syms[i].symbol)->name () != NULL)
3364             {
3365               printf_filtered (("[%d] "), i + first_choice);
3366               ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
3367                               gdb_stdout, -1, 0, &type_print_raw_options);
3368               printf_filtered (_("'(%s) (enumeral)\n"),
3369                                syms[i].symbol->print_name ());
3370             }
3371           else
3372             {
3373               printf_filtered ("[%d] ", i + first_choice);
3374               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3375                                           &type_print_raw_options);
3376
3377               if (symtab != NULL)
3378                 printf_filtered (is_enumeral
3379                                  ? _(" in %s (enumeral)\n")
3380                                  : _(" at %s:?\n"),
3381                                  symtab_to_filename_for_display (symtab));
3382               else
3383                 printf_filtered (is_enumeral
3384                                  ? _(" (enumeral)\n")
3385                                  : _(" at ?\n"));
3386             }
3387         }
3388     }
3389
3390   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3391                              "overload-choice");
3392
3393   for (i = 0; i < n_chosen; i += 1)
3394     syms[i] = syms[chosen[i]];
3395
3396   return n_chosen;
3397 }
3398
3399 /* See ada-lang.h.  */
3400
3401 block_symbol
3402 ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
3403                           int nargs, value *argvec[])
3404 {
3405   if (possible_user_operator_p (op, argvec))
3406     {
3407       std::vector<struct block_symbol> candidates
3408         = ada_lookup_symbol_list (ada_decoded_op_name (op),
3409                                   NULL, VAR_DOMAIN);
3410
3411       int i = ada_resolve_function (candidates, argvec,
3412                                     nargs, ada_decoded_op_name (op), NULL,
3413                                     parse_completion);
3414       if (i >= 0)
3415         return candidates[i];
3416     }
3417   return {};
3418 }
3419
3420 /* See ada-lang.h.  */
3421
3422 block_symbol
3423 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3424                      struct type *context_type,
3425                      bool parse_completion,
3426                      int nargs, value *argvec[],
3427                      innermost_block_tracker *tracker)
3428 {
3429   std::vector<struct block_symbol> candidates
3430     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3431
3432   int i;
3433   if (candidates.size () == 1)
3434     i = 0;
3435   else
3436     {
3437       i = ada_resolve_function
3438         (candidates,
3439          argvec, nargs,
3440          sym->linkage_name (),
3441          context_type, parse_completion);
3442       if (i < 0)
3443         error (_("Could not find a match for %s"), sym->print_name ());
3444     }
3445
3446   tracker->update (candidates[i]);
3447   return candidates[i];
3448 }
3449
3450 /* Resolve a mention of a name where the context type is an
3451    enumeration type.  */
3452
3453 static int
3454 ada_resolve_enum (std::vector<struct block_symbol> &syms,
3455                   const char *name, struct type *context_type,
3456                   bool parse_completion)
3457 {
3458   gdb_assert (context_type->code () == TYPE_CODE_ENUM);
3459   context_type = ada_check_typedef (context_type);
3460
3461   for (int i = 0; i < syms.size (); ++i)
3462     {
3463       /* We already know the name matches, so we're just looking for
3464          an element of the correct enum type.  */
3465       if (ada_check_typedef (SYMBOL_TYPE (syms[i].symbol)) == context_type)
3466         return i;
3467     }
3468
3469   error (_("No name '%s' in enumeration type '%s'"), name,
3470          ada_type_name (context_type));
3471 }
3472
3473 /* See ada-lang.h.  */
3474
3475 block_symbol
3476 ada_resolve_variable (struct symbol *sym, const struct block *block,
3477                       struct type *context_type,
3478                       bool parse_completion,
3479                       int deprocedure_p,
3480                       innermost_block_tracker *tracker)
3481 {
3482   std::vector<struct block_symbol> candidates
3483     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3484
3485   if (std::any_of (candidates.begin (),
3486                    candidates.end (),
3487                    [] (block_symbol &bsym)
3488                    {
3489                      switch (SYMBOL_CLASS (bsym.symbol))
3490                        {
3491                        case LOC_REGISTER:
3492                        case LOC_ARG:
3493                        case LOC_REF_ARG:
3494                        case LOC_REGPARM_ADDR:
3495                        case LOC_LOCAL:
3496                        case LOC_COMPUTED:
3497                          return true;
3498                        default:
3499                          return false;
3500                        }
3501                    }))
3502     {
3503       /* Types tend to get re-introduced locally, so if there
3504          are any local symbols that are not types, first filter
3505          out all types.  */
3506       candidates.erase
3507         (std::remove_if
3508          (candidates.begin (),
3509           candidates.end (),
3510           [] (block_symbol &bsym)
3511           {
3512             return SYMBOL_CLASS (bsym.symbol) == LOC_TYPEDEF;
3513           }),
3514          candidates.end ());
3515     }
3516
3517   /* Filter out artificial symbols.  */
3518   candidates.erase
3519     (std::remove_if
3520      (candidates.begin (),
3521       candidates.end (),
3522       [] (block_symbol &bsym)
3523       {
3524        return bsym.symbol->artificial;
3525       }),
3526      candidates.end ());
3527
3528   int i;
3529   if (candidates.empty ())
3530     error (_("No definition found for %s"), sym->print_name ());
3531   else if (candidates.size () == 1)
3532     i = 0;
3533   else if (context_type != nullptr
3534            && context_type->code () == TYPE_CODE_ENUM)
3535     i = ada_resolve_enum (candidates, sym->linkage_name (), context_type,
3536                           parse_completion);
3537   else if (deprocedure_p && !is_nonfunction (candidates))
3538     {
3539       i = ada_resolve_function
3540         (candidates, NULL, 0,
3541          sym->linkage_name (),
3542          context_type, parse_completion);
3543       if (i < 0)
3544         error (_("Could not find a match for %s"), sym->print_name ());
3545     }
3546   else
3547     {
3548       printf_filtered (_("Multiple matches for %s\n"), sym->print_name ());
3549       user_select_syms (candidates.data (), candidates.size (), 1);
3550       i = 0;
3551     }
3552
3553   tracker->update (candidates[i]);
3554   return candidates[i];
3555 }
3556
3557 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  */
3558 /* The term "match" here is rather loose.  The match is heuristic and
3559    liberal.  */
3560
3561 static int
3562 ada_type_match (struct type *ftype, struct type *atype)
3563 {
3564   ftype = ada_check_typedef (ftype);
3565   atype = ada_check_typedef (atype);
3566
3567   if (ftype->code () == TYPE_CODE_REF)
3568     ftype = TYPE_TARGET_TYPE (ftype);
3569   if (atype->code () == TYPE_CODE_REF)
3570     atype = TYPE_TARGET_TYPE (atype);
3571
3572   switch (ftype->code ())
3573     {
3574     default:
3575       return ftype->code () == atype->code ();
3576     case TYPE_CODE_PTR:
3577       if (atype->code () != TYPE_CODE_PTR)
3578         return 0;
3579       atype = TYPE_TARGET_TYPE (atype);
3580       /* This can only happen if the actual argument is 'null'.  */
3581       if (atype->code () == TYPE_CODE_INT && TYPE_LENGTH (atype) == 0)
3582         return 1;
3583       return ada_type_match (TYPE_TARGET_TYPE (ftype), atype);
3584     case TYPE_CODE_INT:
3585     case TYPE_CODE_ENUM:
3586     case TYPE_CODE_RANGE:
3587       switch (atype->code ())
3588         {
3589         case TYPE_CODE_INT:
3590         case TYPE_CODE_ENUM:
3591         case TYPE_CODE_RANGE:
3592           return 1;
3593         default:
3594           return 0;
3595         }
3596
3597     case TYPE_CODE_ARRAY:
3598       return (atype->code () == TYPE_CODE_ARRAY
3599               || ada_is_array_descriptor_type (atype));
3600
3601     case TYPE_CODE_STRUCT:
3602       if (ada_is_array_descriptor_type (ftype))
3603         return (atype->code () == TYPE_CODE_ARRAY
3604                 || ada_is_array_descriptor_type (atype));
3605       else
3606         return (atype->code () == TYPE_CODE_STRUCT
3607                 && !ada_is_array_descriptor_type (atype));
3608
3609     case TYPE_CODE_UNION:
3610     case TYPE_CODE_FLT:
3611       return (atype->code () == ftype->code ());
3612     }
3613 }
3614
3615 /* Return non-zero if the formals of FUNC "sufficiently match" the
3616    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3617    may also be an enumeral, in which case it is treated as a 0-
3618    argument function.  */
3619
3620 static int
3621 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3622 {
3623   int i;
3624   struct type *func_type = SYMBOL_TYPE (func);
3625
3626   if (SYMBOL_CLASS (func) == LOC_CONST
3627       && func_type->code () == TYPE_CODE_ENUM)
3628     return (n_actuals == 0);
3629   else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3630     return 0;
3631
3632   if (func_type->num_fields () != n_actuals)
3633     return 0;
3634
3635   for (i = 0; i < n_actuals; i += 1)
3636     {
3637       if (actuals[i] == NULL)
3638         return 0;
3639       else
3640         {
3641           struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3642           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3643
3644           if (!ada_type_match (ftype, atype))
3645             return 0;
3646         }
3647     }
3648   return 1;
3649 }
3650
3651 /* False iff function type FUNC_TYPE definitely does not produce a value
3652    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3653    FUNC_TYPE is not a valid function type with a non-null return type
3654    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3655
3656 static int
3657 return_match (struct type *func_type, struct type *context_type)
3658 {
3659   struct type *return_type;
3660
3661   if (func_type == NULL)
3662     return 1;
3663
3664   if (func_type->code () == TYPE_CODE_FUNC)
3665     return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3666   else
3667     return_type = get_base_type (func_type);
3668   if (return_type == NULL)
3669     return 1;
3670
3671   context_type = get_base_type (context_type);
3672
3673   if (return_type->code () == TYPE_CODE_ENUM)
3674     return context_type == NULL || return_type == context_type;
3675   else if (context_type == NULL)
3676     return return_type->code () != TYPE_CODE_VOID;
3677   else
3678     return return_type->code () == context_type->code ();
3679 }
3680
3681
3682 /* Returns the index in SYMS that contains the symbol for the
3683    function (if any) that matches the types of the NARGS arguments in
3684    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
3685    that returns that type, then eliminate matches that don't.  If
3686    CONTEXT_TYPE is void and there is at least one match that does not
3687    return void, eliminate all matches that do.
3688
3689    Asks the user if there is more than one match remaining.  Returns -1
3690    if there is no such symbol or none is selected.  NAME is used
3691    solely for messages.  May re-arrange and modify SYMS in
3692    the process; the index returned is for the modified vector.  */
3693
3694 static int
3695 ada_resolve_function (std::vector<struct block_symbol> &syms,
3696                       struct value **args, int nargs,
3697                       const char *name, struct type *context_type,
3698                       bool parse_completion)
3699 {
3700   int fallback;
3701   int k;
3702   int m;                        /* Number of hits */
3703
3704   m = 0;
3705   /* In the first pass of the loop, we only accept functions matching
3706      context_type.  If none are found, we add a second pass of the loop
3707      where every function is accepted.  */
3708   for (fallback = 0; m == 0 && fallback < 2; fallback++)
3709     {
3710       for (k = 0; k < syms.size (); k += 1)
3711         {
3712           struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
3713
3714           if (ada_args_match (syms[k].symbol, args, nargs)
3715               && (fallback || return_match (type, context_type)))
3716             {
3717               syms[m] = syms[k];
3718               m += 1;
3719             }
3720         }
3721     }
3722
3723   /* If we got multiple matches, ask the user which one to use.  Don't do this
3724      interactive thing during completion, though, as the purpose of the
3725      completion is providing a list of all possible matches.  Prompting the
3726      user to filter it down would be completely unexpected in this case.  */
3727   if (m == 0)
3728     return -1;
3729   else if (m > 1 && !parse_completion)
3730     {
3731       printf_filtered (_("Multiple matches for %s\n"), name);
3732       user_select_syms (syms.data (), m, 1);
3733       return 0;
3734     }
3735   return 0;
3736 }
3737
3738 /* Type-class predicates */
3739
3740 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3741    or FLOAT).  */
3742
3743 static int
3744 numeric_type_p (struct type *type)
3745 {
3746   if (type == NULL)
3747     return 0;
3748   else
3749     {
3750       switch (type->code ())
3751         {
3752         case TYPE_CODE_INT:
3753         case TYPE_CODE_FLT:
3754         case TYPE_CODE_FIXED_POINT:
3755           return 1;
3756         case TYPE_CODE_RANGE:
3757           return (type == TYPE_TARGET_TYPE (type)
3758                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
3759         default:
3760           return 0;
3761         }
3762     }
3763 }
3764
3765 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
3766
3767 static int
3768 integer_type_p (struct type *type)
3769 {
3770   if (type == NULL)
3771     return 0;
3772   else
3773     {
3774       switch (type->code ())
3775         {
3776         case TYPE_CODE_INT:
3777           return 1;
3778         case TYPE_CODE_RANGE:
3779           return (type == TYPE_TARGET_TYPE (type)
3780                   || integer_type_p (TYPE_TARGET_TYPE (type)));
3781         default:
3782           return 0;
3783         }
3784     }
3785 }
3786
3787 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
3788
3789 static int
3790 scalar_type_p (struct type *type)
3791 {
3792   if (type == NULL)
3793     return 0;
3794   else
3795     {
3796       switch (type->code ())
3797         {
3798         case TYPE_CODE_INT:
3799         case TYPE_CODE_RANGE:
3800         case TYPE_CODE_ENUM:
3801         case TYPE_CODE_FLT:
3802         case TYPE_CODE_FIXED_POINT:
3803           return 1;
3804         default:
3805           return 0;
3806         }
3807     }
3808 }
3809
3810 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
3811
3812 static int
3813 discrete_type_p (struct type *type)
3814 {
3815   if (type == NULL)
3816     return 0;
3817   else
3818     {
3819       switch (type->code ())
3820         {
3821         case TYPE_CODE_INT:
3822         case TYPE_CODE_RANGE:
3823         case TYPE_CODE_ENUM:
3824         case TYPE_CODE_BOOL:
3825           return 1;
3826         default:
3827           return 0;
3828         }
3829     }
3830 }
3831
3832 /* Returns non-zero if OP with operands in the vector ARGS could be
3833    a user-defined function.  Errs on the side of pre-defined operators
3834    (i.e., result 0).  */
3835
3836 static int
3837 possible_user_operator_p (enum exp_opcode op, struct value *args[])
3838 {
3839   struct type *type0 =
3840     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
3841   struct type *type1 =
3842     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
3843
3844   if (type0 == NULL)
3845     return 0;
3846
3847   switch (op)
3848     {
3849     default:
3850       return 0;
3851
3852     case BINOP_ADD:
3853     case BINOP_SUB:
3854     case BINOP_MUL:
3855     case BINOP_DIV:
3856       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
3857
3858     case BINOP_REM:
3859     case BINOP_MOD:
3860     case BINOP_BITWISE_AND:
3861     case BINOP_BITWISE_IOR:
3862     case BINOP_BITWISE_XOR:
3863       return (!(integer_type_p (type0) && integer_type_p (type1)));
3864
3865     case BINOP_EQUAL:
3866     case BINOP_NOTEQUAL:
3867     case BINOP_LESS:
3868     case BINOP_GTR:
3869     case BINOP_LEQ:
3870     case BINOP_GEQ:
3871       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
3872
3873     case BINOP_CONCAT:
3874       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
3875
3876     case BINOP_EXP:
3877       return (!(numeric_type_p (type0) && integer_type_p (type1)));
3878
3879     case UNOP_NEG:
3880     case UNOP_PLUS:
3881     case UNOP_LOGICAL_NOT:
3882     case UNOP_ABS:
3883       return (!numeric_type_p (type0));
3884
3885     }
3886 }
3887 \f
3888                                 /* Renaming */
3889
3890 /* NOTES: 
3891
3892    1. In the following, we assume that a renaming type's name may
3893       have an ___XD suffix.  It would be nice if this went away at some
3894       point.
3895    2. We handle both the (old) purely type-based representation of 
3896       renamings and the (new) variable-based encoding.  At some point,
3897       it is devoutly to be hoped that the former goes away 
3898       (FIXME: hilfinger-2007-07-09).
3899    3. Subprogram renamings are not implemented, although the XRS
3900       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
3901
3902 /* If SYM encodes a renaming, 
3903
3904        <renaming> renames <renamed entity>,
3905
3906    sets *LEN to the length of the renamed entity's name,
3907    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3908    the string describing the subcomponent selected from the renamed
3909    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3910    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3911    are undefined).  Otherwise, returns a value indicating the category
3912    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3913    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3914    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
3915    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3916    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3917    may be NULL, in which case they are not assigned.
3918
3919    [Currently, however, GCC does not generate subprogram renamings.]  */
3920
3921 enum ada_renaming_category
3922 ada_parse_renaming (struct symbol *sym,
3923                     const char **renamed_entity, int *len, 
3924                     const char **renaming_expr)
3925 {
3926   enum ada_renaming_category kind;
3927   const char *info;
3928   const char *suffix;
3929
3930   if (sym == NULL)
3931     return ADA_NOT_RENAMING;
3932   switch (SYMBOL_CLASS (sym)) 
3933     {
3934     default:
3935       return ADA_NOT_RENAMING;
3936     case LOC_LOCAL:
3937     case LOC_STATIC:
3938     case LOC_COMPUTED:
3939     case LOC_OPTIMIZED_OUT:
3940       info = strstr (sym->linkage_name (), "___XR");
3941       if (info == NULL)
3942         return ADA_NOT_RENAMING;
3943       switch (info[5])
3944         {
3945         case '_':
3946           kind = ADA_OBJECT_RENAMING;
3947           info += 6;
3948           break;
3949         case 'E':
3950           kind = ADA_EXCEPTION_RENAMING;
3951           info += 7;
3952           break;
3953         case 'P':
3954           kind = ADA_PACKAGE_RENAMING;
3955           info += 7;
3956           break;
3957         case 'S':
3958           kind = ADA_SUBPROGRAM_RENAMING;
3959           info += 7;
3960           break;
3961         default:
3962           return ADA_NOT_RENAMING;
3963         }
3964     }
3965
3966   if (renamed_entity != NULL)
3967     *renamed_entity = info;
3968   suffix = strstr (info, "___XE");
3969   if (suffix == NULL || suffix == info)
3970     return ADA_NOT_RENAMING;
3971   if (len != NULL)
3972     *len = strlen (info) - strlen (suffix);
3973   suffix += 5;
3974   if (renaming_expr != NULL)
3975     *renaming_expr = suffix;
3976   return kind;
3977 }
3978
3979 /* Compute the value of the given RENAMING_SYM, which is expected to
3980    be a symbol encoding a renaming expression.  BLOCK is the block
3981    used to evaluate the renaming.  */
3982
3983 static struct value *
3984 ada_read_renaming_var_value (struct symbol *renaming_sym,
3985                              const struct block *block)
3986 {
3987   const char *sym_name;
3988
3989   sym_name = renaming_sym->linkage_name ();
3990   expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
3991   return evaluate_expression (expr.get ());
3992 }
3993 \f
3994
3995                                 /* Evaluation: Function Calls */
3996
3997 /* Return an lvalue containing the value VAL.  This is the identity on
3998    lvalues, and otherwise has the side-effect of allocating memory
3999    in the inferior where a copy of the value contents is copied.  */
4000
4001 static struct value *
4002 ensure_lval (struct value *val)
4003 {
4004   if (VALUE_LVAL (val) == not_lval
4005       || VALUE_LVAL (val) == lval_internalvar)
4006     {
4007       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4008       const CORE_ADDR addr =
4009         value_as_long (value_allocate_space_in_inferior (len));
4010
4011       VALUE_LVAL (val) = lval_memory;
4012       set_value_address (val, addr);
4013       write_memory (addr, value_contents (val), len);
4014     }
4015
4016   return val;
4017 }
4018
4019 /* Given ARG, a value of type (pointer or reference to a)*
4020    structure/union, extract the component named NAME from the ultimate
4021    target structure/union and return it as a value with its
4022    appropriate type.
4023
4024    The routine searches for NAME among all members of the structure itself
4025    and (recursively) among all members of any wrapper members
4026    (e.g., '_parent').
4027
4028    If NO_ERR, then simply return NULL in case of error, rather than
4029    calling error.  */
4030
4031 static struct value *
4032 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
4033 {
4034   struct type *t, *t1;
4035   struct value *v;
4036   int check_tag;
4037
4038   v = NULL;
4039   t1 = t = ada_check_typedef (value_type (arg));
4040   if (t->code () == TYPE_CODE_REF)
4041     {
4042       t1 = TYPE_TARGET_TYPE (t);
4043       if (t1 == NULL)
4044         goto BadValue;
4045       t1 = ada_check_typedef (t1);
4046       if (t1->code () == TYPE_CODE_PTR)
4047         {
4048           arg = coerce_ref (arg);
4049           t = t1;
4050         }
4051     }
4052
4053   while (t->code () == TYPE_CODE_PTR)
4054     {
4055       t1 = TYPE_TARGET_TYPE (t);
4056       if (t1 == NULL)
4057         goto BadValue;
4058       t1 = ada_check_typedef (t1);
4059       if (t1->code () == TYPE_CODE_PTR)
4060         {
4061           arg = value_ind (arg);
4062           t = t1;
4063         }
4064       else
4065         break;
4066     }
4067
4068   if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4069     goto BadValue;
4070
4071   if (t1 == t)
4072     v = ada_search_struct_field (name, arg, 0, t);
4073   else
4074     {
4075       int bit_offset, bit_size, byte_offset;
4076       struct type *field_type;
4077       CORE_ADDR address;
4078
4079       if (t->code () == TYPE_CODE_PTR)
4080         address = value_address (ada_value_ind (arg));
4081       else
4082         address = value_address (ada_coerce_ref (arg));
4083
4084       /* Check to see if this is a tagged type.  We also need to handle
4085          the case where the type is a reference to a tagged type, but
4086          we have to be careful to exclude pointers to tagged types.
4087          The latter should be shown as usual (as a pointer), whereas
4088          a reference should mostly be transparent to the user.  */
4089
4090       if (ada_is_tagged_type (t1, 0)
4091           || (t1->code () == TYPE_CODE_REF
4092               && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
4093         {
4094           /* We first try to find the searched field in the current type.
4095              If not found then let's look in the fixed type.  */
4096
4097           if (!find_struct_field (name, t1, 0,
4098                                   &field_type, &byte_offset, &bit_offset,
4099                                   &bit_size, NULL))
4100             check_tag = 1;
4101           else
4102             check_tag = 0;
4103         }
4104       else
4105         check_tag = 0;
4106
4107       /* Convert to fixed type in all cases, so that we have proper
4108          offsets to each field in unconstrained record types.  */
4109       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4110                               address, NULL, check_tag);
4111
4112       /* Resolve the dynamic type as well.  */
4113       arg = value_from_contents_and_address (t1, nullptr, address);
4114       t1 = value_type (arg);
4115
4116       if (find_struct_field (name, t1, 0,
4117                              &field_type, &byte_offset, &bit_offset,
4118                              &bit_size, NULL))
4119         {
4120           if (bit_size != 0)
4121             {
4122               if (t->code () == TYPE_CODE_REF)
4123                 arg = ada_coerce_ref (arg);
4124               else
4125                 arg = ada_value_ind (arg);
4126               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4127                                                   bit_offset, bit_size,
4128                                                   field_type);
4129             }
4130           else
4131             v = value_at_lazy (field_type, address + byte_offset);
4132         }
4133     }
4134
4135   if (v != NULL || no_err)
4136     return v;
4137   else
4138     error (_("There is no member named %s."), name);
4139
4140  BadValue:
4141   if (no_err)
4142     return NULL;
4143   else
4144     error (_("Attempt to extract a component of "
4145              "a value that is not a record."));
4146 }
4147
4148 /* Return the value ACTUAL, converted to be an appropriate value for a
4149    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4150    allocating any necessary descriptors (fat pointers), or copies of
4151    values not residing in memory, updating it as needed.  */
4152
4153 struct value *
4154 ada_convert_actual (struct value *actual, struct type *formal_type0)
4155 {
4156   struct type *actual_type = ada_check_typedef (value_type (actual));
4157   struct type *formal_type = ada_check_typedef (formal_type0);
4158   struct type *formal_target =
4159     formal_type->code () == TYPE_CODE_PTR
4160     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4161   struct type *actual_target =
4162     actual_type->code () == TYPE_CODE_PTR
4163     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4164
4165   if (ada_is_array_descriptor_type (formal_target)
4166       && actual_target->code () == TYPE_CODE_ARRAY)
4167     return make_array_descriptor (formal_type, actual);
4168   else if (formal_type->code () == TYPE_CODE_PTR
4169            || formal_type->code () == TYPE_CODE_REF)
4170     {
4171       struct value *result;
4172
4173       if (formal_target->code () == TYPE_CODE_ARRAY
4174           && ada_is_array_descriptor_type (actual_target))
4175         result = desc_data (actual);
4176       else if (formal_type->code () != TYPE_CODE_PTR)
4177         {
4178           if (VALUE_LVAL (actual) != lval_memory)
4179             {
4180               struct value *val;
4181
4182               actual_type = ada_check_typedef (value_type (actual));
4183               val = allocate_value (actual_type);
4184               memcpy ((char *) value_contents_raw (val),
4185                       (char *) value_contents (actual),
4186                       TYPE_LENGTH (actual_type));
4187               actual = ensure_lval (val);
4188             }
4189           result = value_addr (actual);
4190         }
4191       else
4192         return actual;
4193       return value_cast_pointers (formal_type, result, 0);
4194     }
4195   else if (actual_type->code () == TYPE_CODE_PTR)
4196     return ada_value_ind (actual);
4197   else if (ada_is_aligner_type (formal_type))
4198     {
4199       /* We need to turn this parameter into an aligner type
4200          as well.  */
4201       struct value *aligner = allocate_value (formal_type);
4202       struct value *component = ada_value_struct_elt (aligner, "F", 0);
4203
4204       value_assign_to_component (aligner, component, actual);
4205       return aligner;
4206     }
4207
4208   return actual;
4209 }
4210
4211 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4212    type TYPE.  This is usually an inefficient no-op except on some targets
4213    (such as AVR) where the representation of a pointer and an address
4214    differs.  */
4215
4216 static CORE_ADDR
4217 value_pointer (struct value *value, struct type *type)
4218 {
4219   unsigned len = TYPE_LENGTH (type);
4220   gdb_byte *buf = (gdb_byte *) alloca (len);
4221   CORE_ADDR addr;
4222
4223   addr = value_address (value);
4224   gdbarch_address_to_pointer (type->arch (), type, buf, addr);
4225   addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4226   return addr;
4227 }
4228
4229
4230 /* Push a descriptor of type TYPE for array value ARR on the stack at
4231    *SP, updating *SP to reflect the new descriptor.  Return either
4232    an lvalue representing the new descriptor, or (if TYPE is a pointer-
4233    to-descriptor type rather than a descriptor type), a struct value *
4234    representing a pointer to this descriptor.  */
4235
4236 static struct value *
4237 make_array_descriptor (struct type *type, struct value *arr)
4238 {
4239   struct type *bounds_type = desc_bounds_type (type);
4240   struct type *desc_type = desc_base_type (type);
4241   struct value *descriptor = allocate_value (desc_type);
4242   struct value *bounds = allocate_value (bounds_type);
4243   int i;
4244
4245   for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4246        i > 0; i -= 1)
4247     {
4248       modify_field (value_type (bounds), value_contents_writeable (bounds),
4249                     ada_array_bound (arr, i, 0),
4250                     desc_bound_bitpos (bounds_type, i, 0),
4251                     desc_bound_bitsize (bounds_type, i, 0));
4252       modify_field (value_type (bounds), value_contents_writeable (bounds),
4253                     ada_array_bound (arr, i, 1),
4254                     desc_bound_bitpos (bounds_type, i, 1),
4255                     desc_bound_bitsize (bounds_type, i, 1));
4256     }
4257
4258   bounds = ensure_lval (bounds);
4259
4260   modify_field (value_type (descriptor),
4261                 value_contents_writeable (descriptor),
4262                 value_pointer (ensure_lval (arr),
4263                                desc_type->field (0).type ()),
4264                 fat_pntr_data_bitpos (desc_type),
4265                 fat_pntr_data_bitsize (desc_type));
4266
4267   modify_field (value_type (descriptor),
4268                 value_contents_writeable (descriptor),
4269                 value_pointer (bounds,
4270                                desc_type->field (1).type ()),
4271                 fat_pntr_bounds_bitpos (desc_type),
4272                 fat_pntr_bounds_bitsize (desc_type));
4273
4274   descriptor = ensure_lval (descriptor);
4275
4276   if (type->code () == TYPE_CODE_PTR)
4277     return value_addr (descriptor);
4278   else
4279     return descriptor;
4280 }
4281 \f
4282                                 /* Symbol Cache Module */
4283
4284 /* Performance measurements made as of 2010-01-15 indicate that
4285    this cache does bring some noticeable improvements.  Depending
4286    on the type of entity being printed, the cache can make it as much
4287    as an order of magnitude faster than without it.
4288
4289    The descriptive type DWARF extension has significantly reduced
4290    the need for this cache, at least when DWARF is being used.  However,
4291    even in this case, some expensive name-based symbol searches are still
4292    sometimes necessary - to find an XVZ variable, mostly.  */
4293
4294 /* Return the symbol cache associated to the given program space PSPACE.
4295    If not allocated for this PSPACE yet, allocate and initialize one.  */
4296
4297 static struct ada_symbol_cache *
4298 ada_get_symbol_cache (struct program_space *pspace)
4299 {
4300   struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4301
4302   if (pspace_data->sym_cache == nullptr)
4303     pspace_data->sym_cache.reset (new ada_symbol_cache);
4304
4305   return pspace_data->sym_cache.get ();
4306 }
4307
4308 /* Clear all entries from the symbol cache.  */
4309
4310 static void
4311 ada_clear_symbol_cache ()
4312 {
4313   struct ada_pspace_data *pspace_data
4314     = get_ada_pspace_data (current_program_space);
4315
4316   if (pspace_data->sym_cache != nullptr)
4317     pspace_data->sym_cache.reset ();
4318 }
4319
4320 /* Search our cache for an entry matching NAME and DOMAIN.
4321    Return it if found, or NULL otherwise.  */
4322
4323 static struct cache_entry **
4324 find_entry (const char *name, domain_enum domain)
4325 {
4326   struct ada_symbol_cache *sym_cache
4327     = ada_get_symbol_cache (current_program_space);
4328   int h = msymbol_hash (name) % HASH_SIZE;
4329   struct cache_entry **e;
4330
4331   for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4332     {
4333       if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4334         return e;
4335     }
4336   return NULL;
4337 }
4338
4339 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4340    Return 1 if found, 0 otherwise.
4341
4342    If an entry was found and SYM is not NULL, set *SYM to the entry's
4343    SYM.  Same principle for BLOCK if not NULL.  */
4344
4345 static int
4346 lookup_cached_symbol (const char *name, domain_enum domain,
4347                       struct symbol **sym, const struct block **block)
4348 {
4349   struct cache_entry **e = find_entry (name, domain);
4350
4351   if (e == NULL)
4352     return 0;
4353   if (sym != NULL)
4354     *sym = (*e)->sym;
4355   if (block != NULL)
4356     *block = (*e)->block;
4357   return 1;
4358 }
4359
4360 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4361    in domain DOMAIN, save this result in our symbol cache.  */
4362
4363 static void
4364 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4365               const struct block *block)
4366 {
4367   struct ada_symbol_cache *sym_cache
4368     = ada_get_symbol_cache (current_program_space);
4369   int h;
4370   struct cache_entry *e;
4371
4372   /* Symbols for builtin types don't have a block.
4373      For now don't cache such symbols.  */
4374   if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4375     return;
4376
4377   /* If the symbol is a local symbol, then do not cache it, as a search
4378      for that symbol depends on the context.  To determine whether
4379      the symbol is local or not, we check the block where we found it
4380      against the global and static blocks of its associated symtab.  */
4381   if (sym
4382       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4383                             GLOBAL_BLOCK) != block
4384       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4385                             STATIC_BLOCK) != block)
4386     return;
4387
4388   h = msymbol_hash (name) % HASH_SIZE;
4389   e = XOBNEW (&sym_cache->cache_space, cache_entry);
4390   e->next = sym_cache->root[h];
4391   sym_cache->root[h] = e;
4392   e->name = obstack_strdup (&sym_cache->cache_space, name);
4393   e->sym = sym;
4394   e->domain = domain;
4395   e->block = block;
4396 }
4397 \f
4398                                 /* Symbol Lookup */
4399
4400 /* Return the symbol name match type that should be used used when
4401    searching for all symbols matching LOOKUP_NAME.
4402
4403    LOOKUP_NAME is expected to be a symbol name after transformation
4404    for Ada lookups.  */
4405
4406 static symbol_name_match_type
4407 name_match_type_from_name (const char *lookup_name)
4408 {
4409   return (strstr (lookup_name, "__") == NULL
4410           ? symbol_name_match_type::WILD
4411           : symbol_name_match_type::FULL);
4412 }
4413
4414 /* Return the result of a standard (literal, C-like) lookup of NAME in
4415    given DOMAIN, visible from lexical block BLOCK.  */
4416
4417 static struct symbol *
4418 standard_lookup (const char *name, const struct block *block,
4419                  domain_enum domain)
4420 {
4421   /* Initialize it just to avoid a GCC false warning.  */
4422   struct block_symbol sym = {};
4423
4424   if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4425     return sym.symbol;
4426   ada_lookup_encoded_symbol (name, block, domain, &sym);
4427   cache_symbol (name, domain, sym.symbol, sym.block);
4428   return sym.symbol;
4429 }
4430
4431
4432 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4433    in the symbol fields of SYMS.  We treat enumerals as functions, 
4434    since they contend in overloading in the same way.  */
4435 static int
4436 is_nonfunction (const std::vector<struct block_symbol> &syms)
4437 {
4438   for (const block_symbol &sym : syms)
4439     if (SYMBOL_TYPE (sym.symbol)->code () != TYPE_CODE_FUNC
4440         && (SYMBOL_TYPE (sym.symbol)->code () != TYPE_CODE_ENUM
4441             || SYMBOL_CLASS (sym.symbol) != LOC_CONST))
4442       return 1;
4443
4444   return 0;
4445 }
4446
4447 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4448    struct types.  Otherwise, they may not.  */
4449
4450 static int
4451 equiv_types (struct type *type0, struct type *type1)
4452 {
4453   if (type0 == type1)
4454     return 1;
4455   if (type0 == NULL || type1 == NULL
4456       || type0->code () != type1->code ())
4457     return 0;
4458   if ((type0->code () == TYPE_CODE_STRUCT
4459        || type0->code () == TYPE_CODE_ENUM)
4460       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4461       && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4462     return 1;
4463
4464   return 0;
4465 }
4466
4467 /* True iff SYM0 represents the same entity as SYM1, or one that is
4468    no more defined than that of SYM1.  */
4469
4470 static int
4471 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4472 {
4473   if (sym0 == sym1)
4474     return 1;
4475   if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4476       || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4477     return 0;
4478
4479   switch (SYMBOL_CLASS (sym0))
4480     {
4481     case LOC_UNDEF:
4482       return 1;
4483     case LOC_TYPEDEF:
4484       {
4485         struct type *type0 = SYMBOL_TYPE (sym0);
4486         struct type *type1 = SYMBOL_TYPE (sym1);
4487         const char *name0 = sym0->linkage_name ();
4488         const char *name1 = sym1->linkage_name ();
4489         int len0 = strlen (name0);
4490
4491         return
4492           type0->code () == type1->code ()
4493           && (equiv_types (type0, type1)
4494               || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4495                   && startswith (name1 + len0, "___XV")));
4496       }
4497     case LOC_CONST:
4498       return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4499         && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4500
4501     case LOC_STATIC:
4502       {
4503         const char *name0 = sym0->linkage_name ();
4504         const char *name1 = sym1->linkage_name ();
4505         return (strcmp (name0, name1) == 0
4506                 && SYMBOL_VALUE_ADDRESS (sym0) == SYMBOL_VALUE_ADDRESS (sym1));
4507       }
4508
4509     default:
4510       return 0;
4511     }
4512 }
4513
4514 /* Append (SYM,BLOCK) to the end of the array of struct block_symbol
4515    records in RESULT.  Do nothing if SYM is a duplicate.  */
4516
4517 static void
4518 add_defn_to_vec (std::vector<struct block_symbol> &result,
4519                  struct symbol *sym,
4520                  const struct block *block)
4521 {
4522   /* Do not try to complete stub types, as the debugger is probably
4523      already scanning all symbols matching a certain name at the
4524      time when this function is called.  Trying to replace the stub
4525      type by its associated full type will cause us to restart a scan
4526      which may lead to an infinite recursion.  Instead, the client
4527      collecting the matching symbols will end up collecting several
4528      matches, with at least one of them complete.  It can then filter
4529      out the stub ones if needed.  */
4530
4531   for (int i = result.size () - 1; i >= 0; i -= 1)
4532     {
4533       if (lesseq_defined_than (sym, result[i].symbol))
4534         return;
4535       else if (lesseq_defined_than (result[i].symbol, sym))
4536         {
4537           result[i].symbol = sym;
4538           result[i].block = block;
4539           return;
4540         }
4541     }
4542
4543   struct block_symbol info;
4544   info.symbol = sym;
4545   info.block = block;
4546   result.push_back (info);
4547 }
4548
4549 /* Return a bound minimal symbol matching NAME according to Ada
4550    decoding rules.  Returns an invalid symbol if there is no such
4551    minimal symbol.  Names prefixed with "standard__" are handled
4552    specially: "standard__" is first stripped off, and only static and
4553    global symbols are searched.  */
4554
4555 struct bound_minimal_symbol
4556 ada_lookup_simple_minsym (const char *name)
4557 {
4558   struct bound_minimal_symbol result;
4559
4560   memset (&result, 0, sizeof (result));
4561
4562   symbol_name_match_type match_type = name_match_type_from_name (name);
4563   lookup_name_info lookup_name (name, match_type);
4564
4565   symbol_name_matcher_ftype *match_name
4566     = ada_get_symbol_name_matcher (lookup_name);
4567
4568   for (objfile *objfile : current_program_space->objfiles ())
4569     {
4570       for (minimal_symbol *msymbol : objfile->msymbols ())
4571         {
4572           if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4573               && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4574             {
4575               result.minsym = msymbol;
4576               result.objfile = objfile;
4577               break;
4578             }
4579         }
4580     }
4581
4582   return result;
4583 }
4584
4585 /* True if TYPE is definitely an artificial type supplied to a symbol
4586    for which no debugging information was given in the symbol file.  */
4587
4588 static int
4589 is_nondebugging_type (struct type *type)
4590 {
4591   const char *name = ada_type_name (type);
4592
4593   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4594 }
4595
4596 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4597    that are deemed "identical" for practical purposes.
4598
4599    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4600    types and that their number of enumerals is identical (in other
4601    words, type1->num_fields () == type2->num_fields ()).  */
4602
4603 static int
4604 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4605 {
4606   int i;
4607
4608   /* The heuristic we use here is fairly conservative.  We consider
4609      that 2 enumerate types are identical if they have the same
4610      number of enumerals and that all enumerals have the same
4611      underlying value and name.  */
4612
4613   /* All enums in the type should have an identical underlying value.  */
4614   for (i = 0; i < type1->num_fields (); i++)
4615     if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
4616       return 0;
4617
4618   /* All enumerals should also have the same name (modulo any numerical
4619      suffix).  */
4620   for (i = 0; i < type1->num_fields (); i++)
4621     {
4622       const char *name_1 = type1->field (i).name ();
4623       const char *name_2 = type2->field (i).name ();
4624       int len_1 = strlen (name_1);
4625       int len_2 = strlen (name_2);
4626
4627       ada_remove_trailing_digits (type1->field (i).name (), &len_1);
4628       ada_remove_trailing_digits (type2->field (i).name (), &len_2);
4629       if (len_1 != len_2
4630           || strncmp (type1->field (i).name (),
4631                       type2->field (i).name (),
4632                       len_1) != 0)
4633         return 0;
4634     }
4635
4636   return 1;
4637 }
4638
4639 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4640    that are deemed "identical" for practical purposes.  Sometimes,
4641    enumerals are not strictly identical, but their types are so similar
4642    that they can be considered identical.
4643
4644    For instance, consider the following code:
4645
4646       type Color is (Black, Red, Green, Blue, White);
4647       type RGB_Color is new Color range Red .. Blue;
4648
4649    Type RGB_Color is a subrange of an implicit type which is a copy
4650    of type Color. If we call that implicit type RGB_ColorB ("B" is
4651    for "Base Type"), then type RGB_ColorB is a copy of type Color.
4652    As a result, when an expression references any of the enumeral
4653    by name (Eg. "print green"), the expression is technically
4654    ambiguous and the user should be asked to disambiguate. But
4655    doing so would only hinder the user, since it wouldn't matter
4656    what choice he makes, the outcome would always be the same.
4657    So, for practical purposes, we consider them as the same.  */
4658
4659 static int
4660 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
4661 {
4662   int i;
4663
4664   /* Before performing a thorough comparison check of each type,
4665      we perform a series of inexpensive checks.  We expect that these
4666      checks will quickly fail in the vast majority of cases, and thus
4667      help prevent the unnecessary use of a more expensive comparison.
4668      Said comparison also expects us to make some of these checks
4669      (see ada_identical_enum_types_p).  */
4670
4671   /* Quick check: All symbols should have an enum type.  */
4672   for (i = 0; i < syms.size (); i++)
4673     if (SYMBOL_TYPE (syms[i].symbol)->code () != TYPE_CODE_ENUM)
4674       return 0;
4675
4676   /* Quick check: They should all have the same value.  */
4677   for (i = 1; i < syms.size (); i++)
4678     if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
4679       return 0;
4680
4681   /* Quick check: They should all have the same number of enumerals.  */
4682   for (i = 1; i < syms.size (); i++)
4683     if (SYMBOL_TYPE (syms[i].symbol)->num_fields ()
4684         != SYMBOL_TYPE (syms[0].symbol)->num_fields ())
4685       return 0;
4686
4687   /* All the sanity checks passed, so we might have a set of
4688      identical enumeration types.  Perform a more complete
4689      comparison of the type of each symbol.  */
4690   for (i = 1; i < syms.size (); i++)
4691     if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
4692                                      SYMBOL_TYPE (syms[0].symbol)))
4693       return 0;
4694
4695   return 1;
4696 }
4697
4698 /* Remove any non-debugging symbols in SYMS that definitely
4699    duplicate other symbols in the list (The only case I know of where
4700    this happens is when object files containing stabs-in-ecoff are
4701    linked with files containing ordinary ecoff debugging symbols (or no
4702    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.  */
4703
4704 static void
4705 remove_extra_symbols (std::vector<struct block_symbol> *syms)
4706 {
4707   int i, j;
4708
4709   /* We should never be called with less than 2 symbols, as there
4710      cannot be any extra symbol in that case.  But it's easy to
4711      handle, since we have nothing to do in that case.  */
4712   if (syms->size () < 2)
4713     return;
4714
4715   i = 0;
4716   while (i < syms->size ())
4717     {
4718       int remove_p = 0;
4719
4720       /* If two symbols have the same name and one of them is a stub type,
4721          the get rid of the stub.  */
4722
4723       if (SYMBOL_TYPE ((*syms)[i].symbol)->is_stub ()
4724           && (*syms)[i].symbol->linkage_name () != NULL)
4725         {
4726           for (j = 0; j < syms->size (); j++)
4727             {
4728               if (j != i
4729                   && !SYMBOL_TYPE ((*syms)[j].symbol)->is_stub ()
4730                   && (*syms)[j].symbol->linkage_name () != NULL
4731                   && strcmp ((*syms)[i].symbol->linkage_name (),
4732                              (*syms)[j].symbol->linkage_name ()) == 0)
4733                 remove_p = 1;
4734             }
4735         }
4736
4737       /* Two symbols with the same name, same class and same address
4738          should be identical.  */
4739
4740       else if ((*syms)[i].symbol->linkage_name () != NULL
4741           && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
4742           && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
4743         {
4744           for (j = 0; j < syms->size (); j += 1)
4745             {
4746               if (i != j
4747                   && (*syms)[j].symbol->linkage_name () != NULL
4748                   && strcmp ((*syms)[i].symbol->linkage_name (),
4749                              (*syms)[j].symbol->linkage_name ()) == 0
4750                   && SYMBOL_CLASS ((*syms)[i].symbol)
4751                        == SYMBOL_CLASS ((*syms)[j].symbol)
4752                   && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
4753                   == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
4754                 remove_p = 1;
4755             }
4756         }
4757       
4758       if (remove_p)
4759         syms->erase (syms->begin () + i);
4760       else
4761         i += 1;
4762     }
4763
4764   /* If all the remaining symbols are identical enumerals, then
4765      just keep the first one and discard the rest.
4766
4767      Unlike what we did previously, we do not discard any entry
4768      unless they are ALL identical.  This is because the symbol
4769      comparison is not a strict comparison, but rather a practical
4770      comparison.  If all symbols are considered identical, then
4771      we can just go ahead and use the first one and discard the rest.
4772      But if we cannot reduce the list to a single element, we have
4773      to ask the user to disambiguate anyways.  And if we have to
4774      present a multiple-choice menu, it's less confusing if the list
4775      isn't missing some choices that were identical and yet distinct.  */
4776   if (symbols_are_identical_enums (*syms))
4777     syms->resize (1);
4778 }
4779
4780 /* Given a type that corresponds to a renaming entity, use the type name
4781    to extract the scope (package name or function name, fully qualified,
4782    and following the GNAT encoding convention) where this renaming has been
4783    defined.  */
4784
4785 static std::string
4786 xget_renaming_scope (struct type *renaming_type)
4787 {
4788   /* The renaming types adhere to the following convention:
4789      <scope>__<rename>___<XR extension>.
4790      So, to extract the scope, we search for the "___XR" extension,
4791      and then backtrack until we find the first "__".  */
4792
4793   const char *name = renaming_type->name ();
4794   const char *suffix = strstr (name, "___XR");
4795   const char *last;
4796
4797   /* Now, backtrack a bit until we find the first "__".  Start looking
4798      at suffix - 3, as the <rename> part is at least one character long.  */
4799
4800   for (last = suffix - 3; last > name; last--)
4801     if (last[0] == '_' && last[1] == '_')
4802       break;
4803
4804   /* Make a copy of scope and return it.  */
4805   return std::string (name, last);
4806 }
4807
4808 /* Return nonzero if NAME corresponds to a package name.  */
4809
4810 static int
4811 is_package_name (const char *name)
4812 {
4813   /* Here, We take advantage of the fact that no symbols are generated
4814      for packages, while symbols are generated for each function.
4815      So the condition for NAME represent a package becomes equivalent
4816      to NAME not existing in our list of symbols.  There is only one
4817      small complication with library-level functions (see below).  */
4818
4819   /* If it is a function that has not been defined at library level,
4820      then we should be able to look it up in the symbols.  */
4821   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4822     return 0;
4823
4824   /* Library-level function names start with "_ada_".  See if function
4825      "_ada_" followed by NAME can be found.  */
4826
4827   /* Do a quick check that NAME does not contain "__", since library-level
4828      functions names cannot contain "__" in them.  */
4829   if (strstr (name, "__") != NULL)
4830     return 0;
4831
4832   std::string fun_name = string_printf ("_ada_%s", name);
4833
4834   return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
4835 }
4836
4837 /* Return nonzero if SYM corresponds to a renaming entity that is
4838    not visible from FUNCTION_NAME.  */
4839
4840 static int
4841 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
4842 {
4843   if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4844     return 0;
4845
4846   std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
4847
4848   /* If the rename has been defined in a package, then it is visible.  */
4849   if (is_package_name (scope.c_str ()))
4850     return 0;
4851
4852   /* Check that the rename is in the current function scope by checking
4853      that its name starts with SCOPE.  */
4854
4855   /* If the function name starts with "_ada_", it means that it is
4856      a library-level function.  Strip this prefix before doing the
4857      comparison, as the encoding for the renaming does not contain
4858      this prefix.  */
4859   if (startswith (function_name, "_ada_"))
4860     function_name += 5;
4861
4862   return !startswith (function_name, scope.c_str ());
4863 }
4864
4865 /* Remove entries from SYMS that corresponds to a renaming entity that
4866    is not visible from the function associated with CURRENT_BLOCK or
4867    that is superfluous due to the presence of more specific renaming
4868    information.  Places surviving symbols in the initial entries of
4869    SYMS.
4870
4871    Rationale:
4872    First, in cases where an object renaming is implemented as a
4873    reference variable, GNAT may produce both the actual reference
4874    variable and the renaming encoding.  In this case, we discard the
4875    latter.
4876
4877    Second, GNAT emits a type following a specified encoding for each renaming
4878    entity.  Unfortunately, STABS currently does not support the definition
4879    of types that are local to a given lexical block, so all renamings types
4880    are emitted at library level.  As a consequence, if an application
4881    contains two renaming entities using the same name, and a user tries to
4882    print the value of one of these entities, the result of the ada symbol
4883    lookup will also contain the wrong renaming type.
4884
4885    This function partially covers for this limitation by attempting to
4886    remove from the SYMS list renaming symbols that should be visible
4887    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
4888    method with the current information available.  The implementation
4889    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
4890    
4891       - When the user tries to print a rename in a function while there
4892         is another rename entity defined in a package:  Normally, the
4893         rename in the function has precedence over the rename in the
4894         package, so the latter should be removed from the list.  This is
4895         currently not the case.
4896         
4897       - This function will incorrectly remove valid renames if
4898         the CURRENT_BLOCK corresponds to a function which symbol name
4899         has been changed by an "Export" pragma.  As a consequence,
4900         the user will be unable to print such rename entities.  */
4901
4902 static void
4903 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
4904                              const struct block *current_block)
4905 {
4906   struct symbol *current_function;
4907   const char *current_function_name;
4908   int i;
4909   int is_new_style_renaming;
4910
4911   /* If there is both a renaming foo___XR... encoded as a variable and
4912      a simple variable foo in the same block, discard the latter.
4913      First, zero out such symbols, then compress.  */
4914   is_new_style_renaming = 0;
4915   for (i = 0; i < syms->size (); i += 1)
4916     {
4917       struct symbol *sym = (*syms)[i].symbol;
4918       const struct block *block = (*syms)[i].block;
4919       const char *name;
4920       const char *suffix;
4921
4922       if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4923         continue;
4924       name = sym->linkage_name ();
4925       suffix = strstr (name, "___XR");
4926
4927       if (suffix != NULL)
4928         {
4929           int name_len = suffix - name;
4930           int j;
4931
4932           is_new_style_renaming = 1;
4933           for (j = 0; j < syms->size (); j += 1)
4934             if (i != j && (*syms)[j].symbol != NULL
4935                 && strncmp (name, (*syms)[j].symbol->linkage_name (),
4936                             name_len) == 0
4937                 && block == (*syms)[j].block)
4938               (*syms)[j].symbol = NULL;
4939         }
4940     }
4941   if (is_new_style_renaming)
4942     {
4943       int j, k;
4944
4945       for (j = k = 0; j < syms->size (); j += 1)
4946         if ((*syms)[j].symbol != NULL)
4947             {
4948               (*syms)[k] = (*syms)[j];
4949               k += 1;
4950             }
4951       syms->resize (k);
4952       return;
4953     }
4954
4955   /* Extract the function name associated to CURRENT_BLOCK.
4956      Abort if unable to do so.  */
4957
4958   if (current_block == NULL)
4959     return;
4960
4961   current_function = block_linkage_function (current_block);
4962   if (current_function == NULL)
4963     return;
4964
4965   current_function_name = current_function->linkage_name ();
4966   if (current_function_name == NULL)
4967     return;
4968
4969   /* Check each of the symbols, and remove it from the list if it is
4970      a type corresponding to a renaming that is out of the scope of
4971      the current block.  */
4972
4973   i = 0;
4974   while (i < syms->size ())
4975     {
4976       if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
4977           == ADA_OBJECT_RENAMING
4978           && old_renaming_is_invisible ((*syms)[i].symbol,
4979                                         current_function_name))
4980         syms->erase (syms->begin () + i);
4981       else
4982         i += 1;
4983     }
4984 }
4985
4986 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
4987    whose name and domain match LOOKUP_NAME and DOMAIN respectively.
4988
4989    Note: This function assumes that RESULT is empty.  */
4990
4991 static void
4992 ada_add_local_symbols (std::vector<struct block_symbol> &result,
4993                        const lookup_name_info &lookup_name,
4994                        const struct block *block, domain_enum domain)
4995 {
4996   while (block != NULL)
4997     {
4998       ada_add_block_symbols (result, block, lookup_name, domain, NULL);
4999
5000       /* If we found a non-function match, assume that's the one.  We
5001          only check this when finding a function boundary, so that we
5002          can accumulate all results from intervening blocks first.  */
5003       if (BLOCK_FUNCTION (block) != nullptr && is_nonfunction (result))
5004         return;
5005
5006       block = BLOCK_SUPERBLOCK (block);
5007     }
5008 }
5009
5010 /* An object of this type is used as the callback argument when
5011    calling the map_matching_symbols method.  */
5012
5013 struct match_data
5014 {
5015   explicit match_data (std::vector<struct block_symbol> *rp)
5016     : resultp (rp)
5017   {
5018   }
5019   DISABLE_COPY_AND_ASSIGN (match_data);
5020
5021   bool operator() (struct block_symbol *bsym);
5022
5023   struct objfile *objfile = nullptr;
5024   std::vector<struct block_symbol> *resultp;
5025   struct symbol *arg_sym = nullptr;
5026   bool found_sym = false;
5027 };
5028
5029 /* A callback for add_nonlocal_symbols that adds symbol, found in
5030    BSYM, to a list of symbols.  */
5031
5032 bool
5033 match_data::operator() (struct block_symbol *bsym)
5034 {
5035   const struct block *block = bsym->block;
5036   struct symbol *sym = bsym->symbol;
5037
5038   if (sym == NULL)
5039     {
5040       if (!found_sym && arg_sym != NULL)
5041         add_defn_to_vec (*resultp,
5042                          fixup_symbol_section (arg_sym, objfile),
5043                          block);
5044       found_sym = false;
5045       arg_sym = NULL;
5046     }
5047   else 
5048     {
5049       if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5050         return true;
5051       else if (SYMBOL_IS_ARGUMENT (sym))
5052         arg_sym = sym;
5053       else
5054         {
5055           found_sym = true;
5056           add_defn_to_vec (*resultp,
5057                            fixup_symbol_section (sym, objfile),
5058                            block);
5059         }
5060     }
5061   return true;
5062 }
5063
5064 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5065    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5066    symbols to RESULT.  Return whether we found such symbols.  */
5067
5068 static int
5069 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5070                          const struct block *block,
5071                          const lookup_name_info &lookup_name,
5072                          domain_enum domain)
5073 {
5074   struct using_direct *renaming;
5075   int defns_mark = result.size ();
5076
5077   symbol_name_matcher_ftype *name_match
5078     = ada_get_symbol_name_matcher (lookup_name);
5079
5080   for (renaming = block_using (block);
5081        renaming != NULL;
5082        renaming = renaming->next)
5083     {
5084       const char *r_name;
5085
5086       /* Avoid infinite recursions: skip this renaming if we are actually
5087          already traversing it.
5088
5089          Currently, symbol lookup in Ada don't use the namespace machinery from
5090          C++/Fortran support: skip namespace imports that use them.  */
5091       if (renaming->searched
5092           || (renaming->import_src != NULL
5093               && renaming->import_src[0] != '\0')
5094           || (renaming->import_dest != NULL
5095               && renaming->import_dest[0] != '\0'))
5096         continue;
5097       renaming->searched = 1;
5098
5099       /* TODO: here, we perform another name-based symbol lookup, which can
5100          pull its own multiple overloads.  In theory, we should be able to do
5101          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5102          not a simple name.  But in order to do this, we would need to enhance
5103          the DWARF reader to associate a symbol to this renaming, instead of a
5104          name.  So, for now, we do something simpler: re-use the C++/Fortran
5105          namespace machinery.  */
5106       r_name = (renaming->alias != NULL
5107                 ? renaming->alias
5108                 : renaming->declaration);
5109       if (name_match (r_name, lookup_name, NULL))
5110         {
5111           lookup_name_info decl_lookup_name (renaming->declaration,
5112                                              lookup_name.match_type ());
5113           ada_add_all_symbols (result, block, decl_lookup_name, domain,
5114                                1, NULL);
5115         }
5116       renaming->searched = 0;
5117     }
5118   return result.size () != defns_mark;
5119 }
5120
5121 /* Implements compare_names, but only applying the comparision using
5122    the given CASING.  */
5123
5124 static int
5125 compare_names_with_case (const char *string1, const char *string2,
5126                          enum case_sensitivity casing)
5127 {
5128   while (*string1 != '\0' && *string2 != '\0')
5129     {
5130       char c1, c2;
5131
5132       if (isspace (*string1) || isspace (*string2))
5133         return strcmp_iw_ordered (string1, string2);
5134
5135       if (casing == case_sensitive_off)
5136         {
5137           c1 = tolower (*string1);
5138           c2 = tolower (*string2);
5139         }
5140       else
5141         {
5142           c1 = *string1;
5143           c2 = *string2;
5144         }
5145       if (c1 != c2)
5146         break;
5147
5148       string1 += 1;
5149       string2 += 1;
5150     }
5151
5152   switch (*string1)
5153     {
5154     case '(':
5155       return strcmp_iw_ordered (string1, string2);
5156     case '_':
5157       if (*string2 == '\0')
5158         {
5159           if (is_name_suffix (string1))
5160             return 0;
5161           else
5162             return 1;
5163         }
5164       /* FALLTHROUGH */
5165     default:
5166       if (*string2 == '(')
5167         return strcmp_iw_ordered (string1, string2);
5168       else
5169         {
5170           if (casing == case_sensitive_off)
5171             return tolower (*string1) - tolower (*string2);
5172           else
5173             return *string1 - *string2;
5174         }
5175     }
5176 }
5177
5178 /* Compare STRING1 to STRING2, with results as for strcmp.
5179    Compatible with strcmp_iw_ordered in that...
5180
5181        strcmp_iw_ordered (STRING1, STRING2) <= 0
5182
5183    ... implies...
5184
5185        compare_names (STRING1, STRING2) <= 0
5186
5187    (they may differ as to what symbols compare equal).  */
5188
5189 static int
5190 compare_names (const char *string1, const char *string2)
5191 {
5192   int result;
5193
5194   /* Similar to what strcmp_iw_ordered does, we need to perform
5195      a case-insensitive comparison first, and only resort to
5196      a second, case-sensitive, comparison if the first one was
5197      not sufficient to differentiate the two strings.  */
5198
5199   result = compare_names_with_case (string1, string2, case_sensitive_off);
5200   if (result == 0)
5201     result = compare_names_with_case (string1, string2, case_sensitive_on);
5202
5203   return result;
5204 }
5205
5206 /* Convenience function to get at the Ada encoded lookup name for
5207    LOOKUP_NAME, as a C string.  */
5208
5209 static const char *
5210 ada_lookup_name (const lookup_name_info &lookup_name)
5211 {
5212   return lookup_name.ada ().lookup_name ().c_str ();
5213 }
5214
5215 /* A helper for add_nonlocal_symbols.  Call expand_matching_symbols
5216    for OBJFILE, then walk the objfile's symtabs and update the
5217    results.  */
5218
5219 static void
5220 map_matching_symbols (struct objfile *objfile,
5221                       const lookup_name_info &lookup_name,
5222                       bool is_wild_match,
5223                       domain_enum domain,
5224                       int global,
5225                       match_data &data)
5226 {
5227   data.objfile = objfile;
5228   objfile->expand_matching_symbols (lookup_name, domain, global,
5229                                     is_wild_match ? nullptr : compare_names);
5230
5231   const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5232   for (compunit_symtab *symtab : objfile->compunits ())
5233     {
5234       const struct block *block
5235         = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (symtab), block_kind);
5236       if (!iterate_over_symbols_terminated (block, lookup_name,
5237                                             domain, data))
5238         break;
5239     }
5240 }
5241
5242 /* Add to RESULT all non-local symbols whose name and domain match
5243    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5244    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5245    symbols otherwise.  */
5246
5247 static void
5248 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5249                       const lookup_name_info &lookup_name,
5250                       domain_enum domain, int global)
5251 {
5252   struct match_data data (&result);
5253
5254   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5255
5256   for (objfile *objfile : current_program_space->objfiles ())
5257     {
5258       map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5259                             global, data);
5260
5261       for (compunit_symtab *cu : objfile->compunits ())
5262         {
5263           const struct block *global_block
5264             = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5265
5266           if (ada_add_block_renamings (result, global_block, lookup_name,
5267                                        domain))
5268             data.found_sym = true;
5269         }
5270     }
5271
5272   if (result.empty () && global && !is_wild_match)
5273     {
5274       const char *name = ada_lookup_name (lookup_name);
5275       std::string bracket_name = std::string ("<_ada_") + name + '>';
5276       lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5277
5278       for (objfile *objfile : current_program_space->objfiles ())
5279         map_matching_symbols (objfile, name1, false, domain, global, data);
5280     }
5281 }
5282
5283 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5284    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5285    returning the number of matches.  Add these to RESULT.
5286
5287    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5288    symbol match within the nest of blocks whose innermost member is BLOCK,
5289    is the one match returned (no other matches in that or
5290    enclosing blocks is returned).  If there are any matches in or
5291    surrounding BLOCK, then these alone are returned.
5292
5293    Names prefixed with "standard__" are handled specially:
5294    "standard__" is first stripped off (by the lookup_name
5295    constructor), and only static and global symbols are searched.
5296
5297    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5298    to lookup global symbols.  */
5299
5300 static void
5301 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5302                      const struct block *block,
5303                      const lookup_name_info &lookup_name,
5304                      domain_enum domain,
5305                      int full_search,
5306                      int *made_global_lookup_p)
5307 {
5308   struct symbol *sym;
5309
5310   if (made_global_lookup_p)
5311     *made_global_lookup_p = 0;
5312
5313   /* Special case: If the user specifies a symbol name inside package
5314      Standard, do a non-wild matching of the symbol name without
5315      the "standard__" prefix.  This was primarily introduced in order
5316      to allow the user to specifically access the standard exceptions
5317      using, for instance, Standard.Constraint_Error when Constraint_Error
5318      is ambiguous (due to the user defining its own Constraint_Error
5319      entity inside its program).  */
5320   if (lookup_name.ada ().standard_p ())
5321     block = NULL;
5322
5323   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5324
5325   if (block != NULL)
5326     {
5327       if (full_search)
5328         ada_add_local_symbols (result, lookup_name, block, domain);
5329       else
5330         {
5331           /* In the !full_search case we're are being called by
5332              iterate_over_symbols, and we don't want to search
5333              superblocks.  */
5334           ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5335         }
5336       if (!result.empty () || !full_search)
5337         return;
5338     }
5339
5340   /* No non-global symbols found.  Check our cache to see if we have
5341      already performed this search before.  If we have, then return
5342      the same result.  */
5343
5344   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5345                             domain, &sym, &block))
5346     {
5347       if (sym != NULL)
5348         add_defn_to_vec (result, sym, block);
5349       return;
5350     }
5351
5352   if (made_global_lookup_p)
5353     *made_global_lookup_p = 1;
5354
5355   /* Search symbols from all global blocks.  */
5356  
5357   add_nonlocal_symbols (result, lookup_name, domain, 1);
5358
5359   /* Now add symbols from all per-file blocks if we've gotten no hits
5360      (not strictly correct, but perhaps better than an error).  */
5361
5362   if (result.empty ())
5363     add_nonlocal_symbols (result, lookup_name, domain, 0);
5364 }
5365
5366 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5367    is non-zero, enclosing scope and in global scopes.
5368
5369    Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5370    blocks and symbol tables (if any) in which they were found.
5371
5372    When full_search is non-zero, any non-function/non-enumeral
5373    symbol match within the nest of blocks whose innermost member is BLOCK,
5374    is the one match returned (no other matches in that or
5375    enclosing blocks is returned).  If there are any matches in or
5376    surrounding BLOCK, then these alone are returned.
5377
5378    Names prefixed with "standard__" are handled specially: "standard__"
5379    is first stripped off, and only static and global symbols are searched.  */
5380
5381 static std::vector<struct block_symbol>
5382 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5383                                const struct block *block,
5384                                domain_enum domain,
5385                                int full_search)
5386 {
5387   int syms_from_global_search;
5388   std::vector<struct block_symbol> results;
5389
5390   ada_add_all_symbols (results, block, lookup_name,
5391                        domain, full_search, &syms_from_global_search);
5392
5393   remove_extra_symbols (&results);
5394
5395   if (results.empty () && full_search && syms_from_global_search)
5396     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5397
5398   if (results.size () == 1 && full_search && syms_from_global_search)
5399     cache_symbol (ada_lookup_name (lookup_name), domain,
5400                   results[0].symbol, results[0].block);
5401
5402   remove_irrelevant_renamings (&results, block);
5403   return results;
5404 }
5405
5406 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5407    in global scopes, returning (SYM,BLOCK) tuples.
5408
5409    See ada_lookup_symbol_list_worker for further details.  */
5410
5411 std::vector<struct block_symbol>
5412 ada_lookup_symbol_list (const char *name, const struct block *block,
5413                         domain_enum domain)
5414 {
5415   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5416   lookup_name_info lookup_name (name, name_match_type);
5417
5418   return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5419 }
5420
5421 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5422    to 1, but choosing the first symbol found if there are multiple
5423    choices.
5424
5425    The result is stored in *INFO, which must be non-NULL.
5426    If no match is found, INFO->SYM is set to NULL.  */
5427
5428 void
5429 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5430                            domain_enum domain,
5431                            struct block_symbol *info)
5432 {
5433   /* Since we already have an encoded name, wrap it in '<>' to force a
5434      verbatim match.  Otherwise, if the name happens to not look like
5435      an encoded name (because it doesn't include a "__"),
5436      ada_lookup_name_info would re-encode/fold it again, and that
5437      would e.g., incorrectly lowercase object renaming names like
5438      "R28b" -> "r28b".  */
5439   std::string verbatim = add_angle_brackets (name);
5440
5441   gdb_assert (info != NULL);
5442   *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5443 }
5444
5445 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5446    scope and in global scopes, or NULL if none.  NAME is folded and
5447    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5448    choosing the first symbol if there are multiple choices.  */
5449
5450 struct block_symbol
5451 ada_lookup_symbol (const char *name, const struct block *block0,
5452                    domain_enum domain)
5453 {
5454   std::vector<struct block_symbol> candidates
5455     = ada_lookup_symbol_list (name, block0, domain);
5456
5457   if (candidates.empty ())
5458     return {};
5459
5460   block_symbol info = candidates[0];
5461   info.symbol = fixup_symbol_section (info.symbol, NULL);
5462   return info;
5463 }
5464
5465
5466 /* True iff STR is a possible encoded suffix of a normal Ada name
5467    that is to be ignored for matching purposes.  Suffixes of parallel
5468    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5469    are given by any of the regular expressions:
5470
5471    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5472    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5473    TKB              [subprogram suffix for task bodies]
5474    _E[0-9]+[bs]$    [protected object entry suffixes]
5475    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5476
5477    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5478    match is performed.  This sequence is used to differentiate homonyms,
5479    is an optional part of a valid name suffix.  */
5480
5481 static int
5482 is_name_suffix (const char *str)
5483 {
5484   int k;
5485   const char *matching;
5486   const int len = strlen (str);
5487
5488   /* Skip optional leading __[0-9]+.  */
5489
5490   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5491     {
5492       str += 3;
5493       while (isdigit (str[0]))
5494         str += 1;
5495     }
5496   
5497   /* [.$][0-9]+ */
5498
5499   if (str[0] == '.' || str[0] == '$')
5500     {
5501       matching = str + 1;
5502       while (isdigit (matching[0]))
5503         matching += 1;
5504       if (matching[0] == '\0')
5505         return 1;
5506     }
5507
5508   /* ___[0-9]+ */
5509
5510   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5511     {
5512       matching = str + 3;
5513       while (isdigit (matching[0]))
5514         matching += 1;
5515       if (matching[0] == '\0')
5516         return 1;
5517     }
5518
5519   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
5520
5521   if (strcmp (str, "TKB") == 0)
5522     return 1;
5523
5524 #if 0
5525   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5526      with a N at the end.  Unfortunately, the compiler uses the same
5527      convention for other internal types it creates.  So treating
5528      all entity names that end with an "N" as a name suffix causes
5529      some regressions.  For instance, consider the case of an enumerated
5530      type.  To support the 'Image attribute, it creates an array whose
5531      name ends with N.
5532      Having a single character like this as a suffix carrying some
5533      information is a bit risky.  Perhaps we should change the encoding
5534      to be something like "_N" instead.  In the meantime, do not do
5535      the following check.  */
5536   /* Protected Object Subprograms */
5537   if (len == 1 && str [0] == 'N')
5538     return 1;
5539 #endif
5540
5541   /* _E[0-9]+[bs]$ */
5542   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5543     {
5544       matching = str + 3;
5545       while (isdigit (matching[0]))
5546         matching += 1;
5547       if ((matching[0] == 'b' || matching[0] == 's')
5548           && matching [1] == '\0')
5549         return 1;
5550     }
5551
5552   /* ??? We should not modify STR directly, as we are doing below.  This
5553      is fine in this case, but may become problematic later if we find
5554      that this alternative did not work, and want to try matching
5555      another one from the begining of STR.  Since we modified it, we
5556      won't be able to find the begining of the string anymore!  */
5557   if (str[0] == 'X')
5558     {
5559       str += 1;
5560       while (str[0] != '_' && str[0] != '\0')
5561         {
5562           if (str[0] != 'n' && str[0] != 'b')
5563             return 0;
5564           str += 1;
5565         }
5566     }
5567
5568   if (str[0] == '\000')
5569     return 1;
5570
5571   if (str[0] == '_')
5572     {
5573       if (str[1] != '_' || str[2] == '\000')
5574         return 0;
5575       if (str[2] == '_')
5576         {
5577           if (strcmp (str + 3, "JM") == 0)
5578             return 1;
5579           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5580              the LJM suffix in favor of the JM one.  But we will
5581              still accept LJM as a valid suffix for a reasonable
5582              amount of time, just to allow ourselves to debug programs
5583              compiled using an older version of GNAT.  */
5584           if (strcmp (str + 3, "LJM") == 0)
5585             return 1;
5586           if (str[3] != 'X')
5587             return 0;
5588           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5589               || str[4] == 'U' || str[4] == 'P')
5590             return 1;
5591           if (str[4] == 'R' && str[5] != 'T')
5592             return 1;
5593           return 0;
5594         }
5595       if (!isdigit (str[2]))
5596         return 0;
5597       for (k = 3; str[k] != '\0'; k += 1)
5598         if (!isdigit (str[k]) && str[k] != '_')
5599           return 0;
5600       return 1;
5601     }
5602   if (str[0] == '$' && isdigit (str[1]))
5603     {
5604       for (k = 2; str[k] != '\0'; k += 1)
5605         if (!isdigit (str[k]) && str[k] != '_')
5606           return 0;
5607       return 1;
5608     }
5609   return 0;
5610 }
5611
5612 /* Return non-zero if the string starting at NAME and ending before
5613    NAME_END contains no capital letters.  */
5614
5615 static int
5616 is_valid_name_for_wild_match (const char *name0)
5617 {
5618   std::string decoded_name = ada_decode (name0);
5619   int i;
5620
5621   /* If the decoded name starts with an angle bracket, it means that
5622      NAME0 does not follow the GNAT encoding format.  It should then
5623      not be allowed as a possible wild match.  */
5624   if (decoded_name[0] == '<')
5625     return 0;
5626
5627   for (i=0; decoded_name[i] != '\0'; i++)
5628     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5629       return 0;
5630
5631   return 1;
5632 }
5633
5634 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5635    character which could start a simple name.  Assumes that *NAMEP points
5636    somewhere inside the string beginning at NAME0.  */
5637
5638 static int
5639 advance_wild_match (const char **namep, const char *name0, char target0)
5640 {
5641   const char *name = *namep;
5642
5643   while (1)
5644     {
5645       char t0, t1;
5646
5647       t0 = *name;
5648       if (t0 == '_')
5649         {
5650           t1 = name[1];
5651           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5652             {
5653               name += 1;
5654               if (name == name0 + 5 && startswith (name0, "_ada"))
5655                 break;
5656               else
5657                 name += 1;
5658             }
5659           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5660                                  || name[2] == target0))
5661             {
5662               name += 2;
5663               break;
5664             }
5665           else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
5666             {
5667               /* Names like "pkg__B_N__name", where N is a number, are
5668                  block-local.  We can handle these by simply skipping
5669                  the "B_" here.  */
5670               name += 4;
5671             }
5672           else
5673             return 0;
5674         }
5675       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5676         name += 1;
5677       else
5678         return 0;
5679     }
5680
5681   *namep = name;
5682   return 1;
5683 }
5684
5685 /* Return true iff NAME encodes a name of the form prefix.PATN.
5686    Ignores any informational suffixes of NAME (i.e., for which
5687    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
5688    simple name.  */
5689
5690 static bool
5691 wild_match (const char *name, const char *patn)
5692 {
5693   const char *p;
5694   const char *name0 = name;
5695
5696   while (1)
5697     {
5698       const char *match = name;
5699
5700       if (*name == *patn)
5701         {
5702           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5703             if (*p != *name)
5704               break;
5705           if (*p == '\0' && is_name_suffix (name))
5706             return match == name0 || is_valid_name_for_wild_match (name0);
5707
5708           if (name[-1] == '_')
5709             name -= 1;
5710         }
5711       if (!advance_wild_match (&name, name0, *patn))
5712         return false;
5713     }
5714 }
5715
5716 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
5717    necessary).  OBJFILE is the section containing BLOCK.  */
5718
5719 static void
5720 ada_add_block_symbols (std::vector<struct block_symbol> &result,
5721                        const struct block *block,
5722                        const lookup_name_info &lookup_name,
5723                        domain_enum domain, struct objfile *objfile)
5724 {
5725   struct block_iterator iter;
5726   /* A matching argument symbol, if any.  */
5727   struct symbol *arg_sym;
5728   /* Set true when we find a matching non-argument symbol.  */
5729   bool found_sym;
5730   struct symbol *sym;
5731
5732   arg_sym = NULL;
5733   found_sym = false;
5734   for (sym = block_iter_match_first (block, lookup_name, &iter);
5735        sym != NULL;
5736        sym = block_iter_match_next (lookup_name, &iter))
5737     {
5738       if (symbol_matches_domain (sym->language (), SYMBOL_DOMAIN (sym), domain))
5739         {
5740           if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5741             {
5742               if (SYMBOL_IS_ARGUMENT (sym))
5743                 arg_sym = sym;
5744               else
5745                 {
5746                   found_sym = true;
5747                   add_defn_to_vec (result,
5748                                    fixup_symbol_section (sym, objfile),
5749                                    block);
5750                 }
5751             }
5752         }
5753     }
5754
5755   /* Handle renamings.  */
5756
5757   if (ada_add_block_renamings (result, block, lookup_name, domain))
5758     found_sym = true;
5759
5760   if (!found_sym && arg_sym != NULL)
5761     {
5762       add_defn_to_vec (result,
5763                        fixup_symbol_section (arg_sym, objfile),
5764                        block);
5765     }
5766
5767   if (!lookup_name.ada ().wild_match_p ())
5768     {
5769       arg_sym = NULL;
5770       found_sym = false;
5771       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
5772       const char *name = ada_lookup_name.c_str ();
5773       size_t name_len = ada_lookup_name.size ();
5774
5775       ALL_BLOCK_SYMBOLS (block, iter, sym)
5776       {
5777         if (symbol_matches_domain (sym->language (),
5778                                    SYMBOL_DOMAIN (sym), domain))
5779           {
5780             int cmp;
5781
5782             cmp = (int) '_' - (int) sym->linkage_name ()[0];
5783             if (cmp == 0)
5784               {
5785                 cmp = !startswith (sym->linkage_name (), "_ada_");
5786                 if (cmp == 0)
5787                   cmp = strncmp (name, sym->linkage_name () + 5,
5788                                  name_len);
5789               }
5790
5791             if (cmp == 0
5792                 && is_name_suffix (sym->linkage_name () + name_len + 5))
5793               {
5794                 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5795                   {
5796                     if (SYMBOL_IS_ARGUMENT (sym))
5797                       arg_sym = sym;
5798                     else
5799                       {
5800                         found_sym = true;
5801                         add_defn_to_vec (result,
5802                                          fixup_symbol_section (sym, objfile),
5803                                          block);
5804                       }
5805                   }
5806               }
5807           }
5808       }
5809
5810       /* NOTE: This really shouldn't be needed for _ada_ symbols.
5811          They aren't parameters, right?  */
5812       if (!found_sym && arg_sym != NULL)
5813         {
5814           add_defn_to_vec (result,
5815                            fixup_symbol_section (arg_sym, objfile),
5816                            block);
5817         }
5818     }
5819 }
5820 \f
5821
5822                                 /* Symbol Completion */
5823
5824 /* See symtab.h.  */
5825
5826 bool
5827 ada_lookup_name_info::matches
5828   (const char *sym_name,
5829    symbol_name_match_type match_type,
5830    completion_match_result *comp_match_res) const
5831 {
5832   bool match = false;
5833   const char *text = m_encoded_name.c_str ();
5834   size_t text_len = m_encoded_name.size ();
5835
5836   /* First, test against the fully qualified name of the symbol.  */
5837
5838   if (strncmp (sym_name, text, text_len) == 0)
5839     match = true;
5840
5841   std::string decoded_name = ada_decode (sym_name);
5842   if (match && !m_encoded_p)
5843     {
5844       /* One needed check before declaring a positive match is to verify
5845          that iff we are doing a verbatim match, the decoded version
5846          of the symbol name starts with '<'.  Otherwise, this symbol name
5847          is not a suitable completion.  */
5848
5849       bool has_angle_bracket = (decoded_name[0] == '<');
5850       match = (has_angle_bracket == m_verbatim_p);
5851     }
5852
5853   if (match && !m_verbatim_p)
5854     {
5855       /* When doing non-verbatim match, another check that needs to
5856          be done is to verify that the potentially matching symbol name
5857          does not include capital letters, because the ada-mode would
5858          not be able to understand these symbol names without the
5859          angle bracket notation.  */
5860       const char *tmp;
5861
5862       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5863       if (*tmp != '\0')
5864         match = false;
5865     }
5866
5867   /* Second: Try wild matching...  */
5868
5869   if (!match && m_wild_match_p)
5870     {
5871       /* Since we are doing wild matching, this means that TEXT
5872          may represent an unqualified symbol name.  We therefore must
5873          also compare TEXT against the unqualified name of the symbol.  */
5874       sym_name = ada_unqualified_name (decoded_name.c_str ());
5875
5876       if (strncmp (sym_name, text, text_len) == 0)
5877         match = true;
5878     }
5879
5880   /* Finally: If we found a match, prepare the result to return.  */
5881
5882   if (!match)
5883     return false;
5884
5885   if (comp_match_res != NULL)
5886     {
5887       std::string &match_str = comp_match_res->match.storage ();
5888
5889       if (!m_encoded_p)
5890         match_str = ada_decode (sym_name);
5891       else
5892         {
5893           if (m_verbatim_p)
5894             match_str = add_angle_brackets (sym_name);
5895           else
5896             match_str = sym_name;
5897
5898         }
5899
5900       comp_match_res->set_match (match_str.c_str ());
5901     }
5902
5903   return true;
5904 }
5905
5906                                 /* Field Access */
5907
5908 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5909    for tagged types.  */
5910
5911 static int
5912 ada_is_dispatch_table_ptr_type (struct type *type)
5913 {
5914   const char *name;
5915
5916   if (type->code () != TYPE_CODE_PTR)
5917     return 0;
5918
5919   name = TYPE_TARGET_TYPE (type)->name ();
5920   if (name == NULL)
5921     return 0;
5922
5923   return (strcmp (name, "ada__tags__dispatch_table") == 0);
5924 }
5925
5926 /* Return non-zero if TYPE is an interface tag.  */
5927
5928 static int
5929 ada_is_interface_tag (struct type *type)
5930 {
5931   const char *name = type->name ();
5932
5933   if (name == NULL)
5934     return 0;
5935
5936   return (strcmp (name, "ada__tags__interface_tag") == 0);
5937 }
5938
5939 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5940    to be invisible to users.  */
5941
5942 int
5943 ada_is_ignored_field (struct type *type, int field_num)
5944 {
5945   if (field_num < 0 || field_num > type->num_fields ())
5946     return 1;
5947
5948   /* Check the name of that field.  */
5949   {
5950     const char *name = type->field (field_num).name ();
5951
5952     /* Anonymous field names should not be printed.
5953        brobecker/2007-02-20: I don't think this can actually happen
5954        but we don't want to print the value of anonymous fields anyway.  */
5955     if (name == NULL)
5956       return 1;
5957
5958     /* Normally, fields whose name start with an underscore ("_")
5959        are fields that have been internally generated by the compiler,
5960        and thus should not be printed.  The "_parent" field is special,
5961        however: This is a field internally generated by the compiler
5962        for tagged types, and it contains the components inherited from
5963        the parent type.  This field should not be printed as is, but
5964        should not be ignored either.  */
5965     if (name[0] == '_' && !startswith (name, "_parent"))
5966       return 1;
5967   }
5968
5969   /* If this is the dispatch table of a tagged type or an interface tag,
5970      then ignore.  */
5971   if (ada_is_tagged_type (type, 1)
5972       && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
5973           || ada_is_interface_tag (type->field (field_num).type ())))
5974     return 1;
5975
5976   /* Not a special field, so it should not be ignored.  */
5977   return 0;
5978 }
5979
5980 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
5981    pointer or reference type whose ultimate target has a tag field.  */
5982
5983 int
5984 ada_is_tagged_type (struct type *type, int refok)
5985 {
5986   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
5987 }
5988
5989 /* True iff TYPE represents the type of X'Tag */
5990
5991 int
5992 ada_is_tag_type (struct type *type)
5993 {
5994   type = ada_check_typedef (type);
5995
5996   if (type == NULL || type->code () != TYPE_CODE_PTR)
5997     return 0;
5998   else
5999     {
6000       const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6001
6002       return (name != NULL
6003               && strcmp (name, "ada__tags__dispatch_table") == 0);
6004     }
6005 }
6006
6007 /* The type of the tag on VAL.  */
6008
6009 static struct type *
6010 ada_tag_type (struct value *val)
6011 {
6012   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6013 }
6014
6015 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6016    retired at Ada 05).  */
6017
6018 static int
6019 is_ada95_tag (struct value *tag)
6020 {
6021   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6022 }
6023
6024 /* The value of the tag on VAL.  */
6025
6026 static struct value *
6027 ada_value_tag (struct value *val)
6028 {
6029   return ada_value_struct_elt (val, "_tag", 0);
6030 }
6031
6032 /* The value of the tag on the object of type TYPE whose contents are
6033    saved at VALADDR, if it is non-null, or is at memory address
6034    ADDRESS.  */
6035
6036 static struct value *
6037 value_tag_from_contents_and_address (struct type *type,
6038                                      const gdb_byte *valaddr,
6039                                      CORE_ADDR address)
6040 {
6041   int tag_byte_offset;
6042   struct type *tag_type;
6043
6044   if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
6045                          NULL, NULL, NULL))
6046     {
6047       const gdb_byte *valaddr1 = ((valaddr == NULL)
6048                                   ? NULL
6049                                   : valaddr + tag_byte_offset);
6050       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6051
6052       return value_from_contents_and_address (tag_type, valaddr1, address1);
6053     }
6054   return NULL;
6055 }
6056
6057 static struct type *
6058 type_from_tag (struct value *tag)
6059 {
6060   gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6061
6062   if (type_name != NULL)
6063     return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6064   return NULL;
6065 }
6066
6067 /* Given a value OBJ of a tagged type, return a value of this
6068    type at the base address of the object.  The base address, as
6069    defined in Ada.Tags, it is the address of the primary tag of
6070    the object, and therefore where the field values of its full
6071    view can be fetched.  */
6072
6073 struct value *
6074 ada_tag_value_at_base_address (struct value *obj)
6075 {
6076   struct value *val;
6077   LONGEST offset_to_top = 0;
6078   struct type *ptr_type, *obj_type;
6079   struct value *tag;
6080   CORE_ADDR base_address;
6081
6082   obj_type = value_type (obj);
6083
6084   /* It is the responsability of the caller to deref pointers.  */
6085
6086   if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6087     return obj;
6088
6089   tag = ada_value_tag (obj);
6090   if (!tag)
6091     return obj;
6092
6093   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6094
6095   if (is_ada95_tag (tag))
6096     return obj;
6097
6098   ptr_type = language_lookup_primitive_type
6099     (language_def (language_ada), target_gdbarch(), "storage_offset");
6100   ptr_type = lookup_pointer_type (ptr_type);
6101   val = value_cast (ptr_type, tag);
6102   if (!val)
6103     return obj;
6104
6105   /* It is perfectly possible that an exception be raised while
6106      trying to determine the base address, just like for the tag;
6107      see ada_tag_name for more details.  We do not print the error
6108      message for the same reason.  */
6109
6110   try
6111     {
6112       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6113     }
6114
6115   catch (const gdb_exception_error &e)
6116     {
6117       return obj;
6118     }
6119
6120   /* If offset is null, nothing to do.  */
6121
6122   if (offset_to_top == 0)
6123     return obj;
6124
6125   /* -1 is a special case in Ada.Tags; however, what should be done
6126      is not quite clear from the documentation.  So do nothing for
6127      now.  */
6128
6129   if (offset_to_top == -1)
6130     return obj;
6131
6132   /* OFFSET_TO_TOP used to be a positive value to be subtracted
6133      from the base address.  This was however incompatible with
6134      C++ dispatch table: C++ uses a *negative* value to *add*
6135      to the base address.  Ada's convention has therefore been
6136      changed in GNAT 19.0w 20171023: since then, C++ and Ada
6137      use the same convention.  Here, we support both cases by
6138      checking the sign of OFFSET_TO_TOP.  */
6139
6140   if (offset_to_top > 0)
6141     offset_to_top = -offset_to_top;
6142
6143   base_address = value_address (obj) + offset_to_top;
6144   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6145
6146   /* Make sure that we have a proper tag at the new address.
6147      Otherwise, offset_to_top is bogus (which can happen when
6148      the object is not initialized yet).  */
6149
6150   if (!tag)
6151     return obj;
6152
6153   obj_type = type_from_tag (tag);
6154
6155   if (!obj_type)
6156     return obj;
6157
6158   return value_from_contents_and_address (obj_type, NULL, base_address);
6159 }
6160
6161 /* Return the "ada__tags__type_specific_data" type.  */
6162
6163 static struct type *
6164 ada_get_tsd_type (struct inferior *inf)
6165 {
6166   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6167
6168   if (data->tsd_type == 0)
6169     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6170   return data->tsd_type;
6171 }
6172
6173 /* Return the TSD (type-specific data) associated to the given TAG.
6174    TAG is assumed to be the tag of a tagged-type entity.
6175
6176    May return NULL if we are unable to get the TSD.  */
6177
6178 static struct value *
6179 ada_get_tsd_from_tag (struct value *tag)
6180 {
6181   struct value *val;
6182   struct type *type;
6183
6184   /* First option: The TSD is simply stored as a field of our TAG.
6185      Only older versions of GNAT would use this format, but we have
6186      to test it first, because there are no visible markers for
6187      the current approach except the absence of that field.  */
6188
6189   val = ada_value_struct_elt (tag, "tsd", 1);
6190   if (val)
6191     return val;
6192
6193   /* Try the second representation for the dispatch table (in which
6194      there is no explicit 'tsd' field in the referent of the tag pointer,
6195      and instead the tsd pointer is stored just before the dispatch
6196      table.  */
6197
6198   type = ada_get_tsd_type (current_inferior());
6199   if (type == NULL)
6200     return NULL;
6201   type = lookup_pointer_type (lookup_pointer_type (type));
6202   val = value_cast (type, tag);
6203   if (val == NULL)
6204     return NULL;
6205   return value_ind (value_ptradd (val, -1));
6206 }
6207
6208 /* Given the TSD of a tag (type-specific data), return a string
6209    containing the name of the associated type.
6210
6211    May return NULL if we are unable to determine the tag name.  */
6212
6213 static gdb::unique_xmalloc_ptr<char>
6214 ada_tag_name_from_tsd (struct value *tsd)
6215 {
6216   char *p;
6217   struct value *val;
6218
6219   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6220   if (val == NULL)
6221     return NULL;
6222   gdb::unique_xmalloc_ptr<char> buffer
6223     = target_read_string (value_as_address (val), INT_MAX);
6224   if (buffer == nullptr)
6225     return nullptr;
6226
6227   for (p = buffer.get (); *p != '\0'; ++p)
6228     {
6229       if (isalpha (*p))
6230         *p = tolower (*p);
6231     }
6232
6233   return buffer;
6234 }
6235
6236 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6237    a C string.
6238
6239    Return NULL if the TAG is not an Ada tag, or if we were unable to
6240    determine the name of that tag.  */
6241
6242 gdb::unique_xmalloc_ptr<char>
6243 ada_tag_name (struct value *tag)
6244 {
6245   gdb::unique_xmalloc_ptr<char> name;
6246
6247   if (!ada_is_tag_type (value_type (tag)))
6248     return NULL;
6249
6250   /* It is perfectly possible that an exception be raised while trying
6251      to determine the TAG's name, even under normal circumstances:
6252      The associated variable may be uninitialized or corrupted, for
6253      instance. We do not let any exception propagate past this point.
6254      instead we return NULL.
6255
6256      We also do not print the error message either (which often is very
6257      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6258      the caller print a more meaningful message if necessary.  */
6259   try
6260     {
6261       struct value *tsd = ada_get_tsd_from_tag (tag);
6262
6263       if (tsd != NULL)
6264         name = ada_tag_name_from_tsd (tsd);
6265     }
6266   catch (const gdb_exception_error &e)
6267     {
6268     }
6269
6270   return name;
6271 }
6272
6273 /* The parent type of TYPE, or NULL if none.  */
6274
6275 struct type *
6276 ada_parent_type (struct type *type)
6277 {
6278   int i;
6279
6280   type = ada_check_typedef (type);
6281
6282   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6283     return NULL;
6284
6285   for (i = 0; i < type->num_fields (); i += 1)
6286     if (ada_is_parent_field (type, i))
6287       {
6288         struct type *parent_type = type->field (i).type ();
6289
6290         /* If the _parent field is a pointer, then dereference it.  */
6291         if (parent_type->code () == TYPE_CODE_PTR)
6292           parent_type = TYPE_TARGET_TYPE (parent_type);
6293         /* If there is a parallel XVS type, get the actual base type.  */
6294         parent_type = ada_get_base_type (parent_type);
6295
6296         return ada_check_typedef (parent_type);
6297       }
6298
6299   return NULL;
6300 }
6301
6302 /* True iff field number FIELD_NUM of structure type TYPE contains the
6303    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6304    a structure type with at least FIELD_NUM+1 fields.  */
6305
6306 int
6307 ada_is_parent_field (struct type *type, int field_num)
6308 {
6309   const char *name = ada_check_typedef (type)->field (field_num).name ();
6310
6311   return (name != NULL
6312           && (startswith (name, "PARENT")
6313               || startswith (name, "_parent")));
6314 }
6315
6316 /* True iff field number FIELD_NUM of structure type TYPE is a
6317    transparent wrapper field (which should be silently traversed when doing
6318    field selection and flattened when printing).  Assumes TYPE is a
6319    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6320    structures.  */
6321
6322 int
6323 ada_is_wrapper_field (struct type *type, int field_num)
6324 {
6325   const char *name = type->field (field_num).name ();
6326
6327   if (name != NULL && strcmp (name, "RETVAL") == 0)
6328     {
6329       /* This happens in functions with "out" or "in out" parameters
6330          which are passed by copy.  For such functions, GNAT describes
6331          the function's return type as being a struct where the return
6332          value is in a field called RETVAL, and where the other "out"
6333          or "in out" parameters are fields of that struct.  This is not
6334          a wrapper.  */
6335       return 0;
6336     }
6337
6338   return (name != NULL
6339           && (startswith (name, "PARENT")
6340               || strcmp (name, "REP") == 0
6341               || startswith (name, "_parent")
6342               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6343 }
6344
6345 /* True iff field number FIELD_NUM of structure or union type TYPE
6346    is a variant wrapper.  Assumes TYPE is a structure type with at least
6347    FIELD_NUM+1 fields.  */
6348
6349 int
6350 ada_is_variant_part (struct type *type, int field_num)
6351 {
6352   /* Only Ada types are eligible.  */
6353   if (!ADA_TYPE_P (type))
6354     return 0;
6355
6356   struct type *field_type = type->field (field_num).type ();
6357
6358   return (field_type->code () == TYPE_CODE_UNION
6359           || (is_dynamic_field (type, field_num)
6360               && (TYPE_TARGET_TYPE (field_type)->code ()
6361                   == TYPE_CODE_UNION)));
6362 }
6363
6364 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6365    whose discriminants are contained in the record type OUTER_TYPE,
6366    returns the type of the controlling discriminant for the variant.
6367    May return NULL if the type could not be found.  */
6368
6369 struct type *
6370 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6371 {
6372   const char *name = ada_variant_discrim_name (var_type);
6373
6374   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6375 }
6376
6377 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6378    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6379    represents a 'when others' clause; otherwise 0.  */
6380
6381 static int
6382 ada_is_others_clause (struct type *type, int field_num)
6383 {
6384   const char *name = type->field (field_num).name ();
6385
6386   return (name != NULL && name[0] == 'O');
6387 }
6388
6389 /* Assuming that TYPE0 is the type of the variant part of a record,
6390    returns the name of the discriminant controlling the variant.
6391    The value is valid until the next call to ada_variant_discrim_name.  */
6392
6393 const char *
6394 ada_variant_discrim_name (struct type *type0)
6395 {
6396   static std::string result;
6397   struct type *type;
6398   const char *name;
6399   const char *discrim_end;
6400   const char *discrim_start;
6401
6402   if (type0->code () == TYPE_CODE_PTR)
6403     type = TYPE_TARGET_TYPE (type0);
6404   else
6405     type = type0;
6406
6407   name = ada_type_name (type);
6408
6409   if (name == NULL || name[0] == '\000')
6410     return "";
6411
6412   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6413        discrim_end -= 1)
6414     {
6415       if (startswith (discrim_end, "___XVN"))
6416         break;
6417     }
6418   if (discrim_end == name)
6419     return "";
6420
6421   for (discrim_start = discrim_end; discrim_start != name + 3;
6422        discrim_start -= 1)
6423     {
6424       if (discrim_start == name + 1)
6425         return "";
6426       if ((discrim_start > name + 3
6427            && startswith (discrim_start - 3, "___"))
6428           || discrim_start[-1] == '.')
6429         break;
6430     }
6431
6432   result = std::string (discrim_start, discrim_end - discrim_start);
6433   return result.c_str ();
6434 }
6435
6436 /* Scan STR for a subtype-encoded number, beginning at position K.
6437    Put the position of the character just past the number scanned in
6438    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
6439    Return 1 if there was a valid number at the given position, and 0
6440    otherwise.  A "subtype-encoded" number consists of the absolute value
6441    in decimal, followed by the letter 'm' to indicate a negative number.
6442    Assumes 0m does not occur.  */
6443
6444 int
6445 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6446 {
6447   ULONGEST RU;
6448
6449   if (!isdigit (str[k]))
6450     return 0;
6451
6452   /* Do it the hard way so as not to make any assumption about
6453      the relationship of unsigned long (%lu scan format code) and
6454      LONGEST.  */
6455   RU = 0;
6456   while (isdigit (str[k]))
6457     {
6458       RU = RU * 10 + (str[k] - '0');
6459       k += 1;
6460     }
6461
6462   if (str[k] == 'm')
6463     {
6464       if (R != NULL)
6465         *R = (-(LONGEST) (RU - 1)) - 1;
6466       k += 1;
6467     }
6468   else if (R != NULL)
6469     *R = (LONGEST) RU;
6470
6471   /* NOTE on the above: Technically, C does not say what the results of
6472      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6473      number representable as a LONGEST (although either would probably work
6474      in most implementations).  When RU>0, the locution in the then branch
6475      above is always equivalent to the negative of RU.  */
6476
6477   if (new_k != NULL)
6478     *new_k = k;
6479   return 1;
6480 }
6481
6482 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6483    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6484    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
6485
6486 static int
6487 ada_in_variant (LONGEST val, struct type *type, int field_num)
6488 {
6489   const char *name = type->field (field_num).name ();
6490   int p;
6491
6492   p = 0;
6493   while (1)
6494     {
6495       switch (name[p])
6496         {
6497         case '\0':
6498           return 0;
6499         case 'S':
6500           {
6501             LONGEST W;
6502
6503             if (!ada_scan_number (name, p + 1, &W, &p))
6504               return 0;
6505             if (val == W)
6506               return 1;
6507             break;
6508           }
6509         case 'R':
6510           {
6511             LONGEST L, U;
6512
6513             if (!ada_scan_number (name, p + 1, &L, &p)
6514                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6515               return 0;
6516             if (val >= L && val <= U)
6517               return 1;
6518             break;
6519           }
6520         case 'O':
6521           return 1;
6522         default:
6523           return 0;
6524         }
6525     }
6526 }
6527
6528 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
6529
6530 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6531    ARG_TYPE, extract and return the value of one of its (non-static)
6532    fields.  FIELDNO says which field.   Differs from value_primitive_field
6533    only in that it can handle packed values of arbitrary type.  */
6534
6535 struct value *
6536 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6537                            struct type *arg_type)
6538 {
6539   struct type *type;
6540
6541   arg_type = ada_check_typedef (arg_type);
6542   type = arg_type->field (fieldno).type ();
6543
6544   /* Handle packed fields.  It might be that the field is not packed
6545      relative to its containing structure, but the structure itself is
6546      packed; in this case we must take the bit-field path.  */
6547   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6548     {
6549       int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6550       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6551
6552       return ada_value_primitive_packed_val (arg1, value_contents (arg1),
6553                                              offset + bit_pos / 8,
6554                                              bit_pos % 8, bit_size, type);
6555     }
6556   else
6557     return value_primitive_field (arg1, offset, fieldno, arg_type);
6558 }
6559
6560 /* Find field with name NAME in object of type TYPE.  If found, 
6561    set the following for each argument that is non-null:
6562     - *FIELD_TYPE_P to the field's type; 
6563     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
6564       an object of that type;
6565     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
6566     - *BIT_SIZE_P to its size in bits if the field is packed, and 
6567       0 otherwise;
6568    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6569    fields up to but not including the desired field, or by the total
6570    number of fields if not found.   A NULL value of NAME never
6571    matches; the function just counts visible fields in this case.
6572    
6573    Notice that we need to handle when a tagged record hierarchy
6574    has some components with the same name, like in this scenario:
6575
6576       type Top_T is tagged record
6577          N : Integer := 1;
6578          U : Integer := 974;
6579          A : Integer := 48;
6580       end record;
6581
6582       type Middle_T is new Top.Top_T with record
6583          N : Character := 'a';
6584          C : Integer := 3;
6585       end record;
6586
6587      type Bottom_T is new Middle.Middle_T with record
6588         N : Float := 4.0;
6589         C : Character := '5';
6590         X : Integer := 6;
6591         A : Character := 'J';
6592      end record;
6593
6594    Let's say we now have a variable declared and initialized as follow:
6595
6596      TC : Top_A := new Bottom_T;
6597
6598    And then we use this variable to call this function
6599
6600      procedure Assign (Obj: in out Top_T; TV : Integer);
6601
6602    as follow:
6603
6604       Assign (Top_T (B), 12);
6605
6606    Now, we're in the debugger, and we're inside that procedure
6607    then and we want to print the value of obj.c:
6608
6609    Usually, the tagged record or one of the parent type owns the
6610    component to print and there's no issue but in this particular
6611    case, what does it mean to ask for Obj.C? Since the actual
6612    type for object is type Bottom_T, it could mean two things: type
6613    component C from the Middle_T view, but also component C from
6614    Bottom_T.  So in that "undefined" case, when the component is
6615    not found in the non-resolved type (which includes all the
6616    components of the parent type), then resolve it and see if we
6617    get better luck once expanded.
6618
6619    In the case of homonyms in the derived tagged type, we don't
6620    guaranty anything, and pick the one that's easiest for us
6621    to program.
6622
6623    Returns 1 if found, 0 otherwise.  */
6624
6625 static int
6626 find_struct_field (const char *name, struct type *type, int offset,
6627                    struct type **field_type_p,
6628                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6629                    int *index_p)
6630 {
6631   int i;
6632   int parent_offset = -1;
6633
6634   type = ada_check_typedef (type);
6635
6636   if (field_type_p != NULL)
6637     *field_type_p = NULL;
6638   if (byte_offset_p != NULL)
6639     *byte_offset_p = 0;
6640   if (bit_offset_p != NULL)
6641     *bit_offset_p = 0;
6642   if (bit_size_p != NULL)
6643     *bit_size_p = 0;
6644
6645   for (i = 0; i < type->num_fields (); i += 1)
6646     {
6647       int bit_pos = TYPE_FIELD_BITPOS (type, i);
6648       int fld_offset = offset + bit_pos / 8;
6649       const char *t_field_name = type->field (i).name ();
6650
6651       if (t_field_name == NULL)
6652         continue;
6653
6654       else if (ada_is_parent_field (type, i))
6655         {
6656           /* This is a field pointing us to the parent type of a tagged
6657              type.  As hinted in this function's documentation, we give
6658              preference to fields in the current record first, so what
6659              we do here is just record the index of this field before
6660              we skip it.  If it turns out we couldn't find our field
6661              in the current record, then we'll get back to it and search
6662              inside it whether the field might exist in the parent.  */
6663
6664           parent_offset = i;
6665           continue;
6666         }
6667
6668       else if (name != NULL && field_name_match (t_field_name, name))
6669         {
6670           int bit_size = TYPE_FIELD_BITSIZE (type, i);
6671
6672           if (field_type_p != NULL)
6673             *field_type_p = type->field (i).type ();
6674           if (byte_offset_p != NULL)
6675             *byte_offset_p = fld_offset;
6676           if (bit_offset_p != NULL)
6677             *bit_offset_p = bit_pos % 8;
6678           if (bit_size_p != NULL)
6679             *bit_size_p = bit_size;
6680           return 1;
6681         }
6682       else if (ada_is_wrapper_field (type, i))
6683         {
6684           if (find_struct_field (name, type->field (i).type (), fld_offset,
6685                                  field_type_p, byte_offset_p, bit_offset_p,
6686                                  bit_size_p, index_p))
6687             return 1;
6688         }
6689       else if (ada_is_variant_part (type, i))
6690         {
6691           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
6692              fixed type?? */
6693           int j;
6694           struct type *field_type
6695             = ada_check_typedef (type->field (i).type ());
6696
6697           for (j = 0; j < field_type->num_fields (); j += 1)
6698             {
6699               if (find_struct_field (name, field_type->field (j).type (),
6700                                      fld_offset
6701                                      + TYPE_FIELD_BITPOS (field_type, j) / 8,
6702                                      field_type_p, byte_offset_p,
6703                                      bit_offset_p, bit_size_p, index_p))
6704                 return 1;
6705             }
6706         }
6707       else if (index_p != NULL)
6708         *index_p += 1;
6709     }
6710
6711   /* Field not found so far.  If this is a tagged type which
6712      has a parent, try finding that field in the parent now.  */
6713
6714   if (parent_offset != -1)
6715     {
6716       int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
6717       int fld_offset = offset + bit_pos / 8;
6718
6719       if (find_struct_field (name, type->field (parent_offset).type (),
6720                              fld_offset, field_type_p, byte_offset_p,
6721                              bit_offset_p, bit_size_p, index_p))
6722         return 1;
6723     }
6724
6725   return 0;
6726 }
6727
6728 /* Number of user-visible fields in record type TYPE.  */
6729
6730 static int
6731 num_visible_fields (struct type *type)
6732 {
6733   int n;
6734
6735   n = 0;
6736   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6737   return n;
6738 }
6739
6740 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
6741    and search in it assuming it has (class) type TYPE.
6742    If found, return value, else return NULL.
6743
6744    Searches recursively through wrapper fields (e.g., '_parent').
6745
6746    In the case of homonyms in the tagged types, please refer to the
6747    long explanation in find_struct_field's function documentation.  */
6748
6749 static struct value *
6750 ada_search_struct_field (const char *name, struct value *arg, int offset,
6751                          struct type *type)
6752 {
6753   int i;
6754   int parent_offset = -1;
6755
6756   type = ada_check_typedef (type);
6757   for (i = 0; i < type->num_fields (); i += 1)
6758     {
6759       const char *t_field_name = type->field (i).name ();
6760
6761       if (t_field_name == NULL)
6762         continue;
6763
6764       else if (ada_is_parent_field (type, i))
6765         {
6766           /* This is a field pointing us to the parent type of a tagged
6767              type.  As hinted in this function's documentation, we give
6768              preference to fields in the current record first, so what
6769              we do here is just record the index of this field before
6770              we skip it.  If it turns out we couldn't find our field
6771              in the current record, then we'll get back to it and search
6772              inside it whether the field might exist in the parent.  */
6773
6774           parent_offset = i;
6775           continue;
6776         }
6777
6778       else if (field_name_match (t_field_name, name))
6779         return ada_value_primitive_field (arg, offset, i, type);
6780
6781       else if (ada_is_wrapper_field (type, i))
6782         {
6783           struct value *v =     /* Do not let indent join lines here.  */
6784             ada_search_struct_field (name, arg,
6785                                      offset + TYPE_FIELD_BITPOS (type, i) / 8,
6786                                      type->field (i).type ());
6787
6788           if (v != NULL)
6789             return v;
6790         }
6791
6792       else if (ada_is_variant_part (type, i))
6793         {
6794           /* PNH: Do we ever get here?  See find_struct_field.  */
6795           int j;
6796           struct type *field_type = ada_check_typedef (type->field (i).type ());
6797           int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6798
6799           for (j = 0; j < field_type->num_fields (); j += 1)
6800             {
6801               struct value *v = ada_search_struct_field /* Force line
6802                                                            break.  */
6803                 (name, arg,
6804                  var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6805                  field_type->field (j).type ());
6806
6807               if (v != NULL)
6808                 return v;
6809             }
6810         }
6811     }
6812
6813   /* Field not found so far.  If this is a tagged type which
6814      has a parent, try finding that field in the parent now.  */
6815
6816   if (parent_offset != -1)
6817     {
6818       struct value *v = ada_search_struct_field (
6819         name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
6820         type->field (parent_offset).type ());
6821
6822       if (v != NULL)
6823         return v;
6824     }
6825
6826   return NULL;
6827 }
6828
6829 static struct value *ada_index_struct_field_1 (int *, struct value *,
6830                                                int, struct type *);
6831
6832
6833 /* Return field #INDEX in ARG, where the index is that returned by
6834  * find_struct_field through its INDEX_P argument.  Adjust the address
6835  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6836  * If found, return value, else return NULL.  */
6837
6838 static struct value *
6839 ada_index_struct_field (int index, struct value *arg, int offset,
6840                         struct type *type)
6841 {
6842   return ada_index_struct_field_1 (&index, arg, offset, type);
6843 }
6844
6845
6846 /* Auxiliary function for ada_index_struct_field.  Like
6847  * ada_index_struct_field, but takes index from *INDEX_P and modifies
6848  * *INDEX_P.  */
6849
6850 static struct value *
6851 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6852                           struct type *type)
6853 {
6854   int i;
6855   type = ada_check_typedef (type);
6856
6857   for (i = 0; i < type->num_fields (); i += 1)
6858     {
6859       if (type->field (i).name () == NULL)
6860         continue;
6861       else if (ada_is_wrapper_field (type, i))
6862         {
6863           struct value *v =     /* Do not let indent join lines here.  */
6864             ada_index_struct_field_1 (index_p, arg,
6865                                       offset + TYPE_FIELD_BITPOS (type, i) / 8,
6866                                       type->field (i).type ());
6867
6868           if (v != NULL)
6869             return v;
6870         }
6871
6872       else if (ada_is_variant_part (type, i))
6873         {
6874           /* PNH: Do we ever get here?  See ada_search_struct_field,
6875              find_struct_field.  */
6876           error (_("Cannot assign this kind of variant record"));
6877         }
6878       else if (*index_p == 0)
6879         return ada_value_primitive_field (arg, offset, i, type);
6880       else
6881         *index_p -= 1;
6882     }
6883   return NULL;
6884 }
6885
6886 /* Return a string representation of type TYPE.  */
6887
6888 static std::string
6889 type_as_string (struct type *type)
6890 {
6891   string_file tmp_stream;
6892
6893   type_print (type, "", &tmp_stream, -1);
6894
6895   return std::move (tmp_stream.string ());
6896 }
6897
6898 /* Given a type TYPE, look up the type of the component of type named NAME.
6899    If DISPP is non-null, add its byte displacement from the beginning of a
6900    structure (pointed to by a value) of type TYPE to *DISPP (does not
6901    work for packed fields).
6902
6903    Matches any field whose name has NAME as a prefix, possibly
6904    followed by "___".
6905
6906    TYPE can be either a struct or union.  If REFOK, TYPE may also 
6907    be a (pointer or reference)+ to a struct or union, and the
6908    ultimate target type will be searched.
6909
6910    Looks recursively into variant clauses and parent types.
6911
6912    In the case of homonyms in the tagged types, please refer to the
6913    long explanation in find_struct_field's function documentation.
6914
6915    If NOERR is nonzero, return NULL if NAME is not suitably defined or
6916    TYPE is not a type of the right kind.  */
6917
6918 static struct type *
6919 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
6920                             int noerr)
6921 {
6922   int i;
6923   int parent_offset = -1;
6924
6925   if (name == NULL)
6926     goto BadName;
6927
6928   if (refok && type != NULL)
6929     while (1)
6930       {
6931         type = ada_check_typedef (type);
6932         if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
6933           break;
6934         type = TYPE_TARGET_TYPE (type);
6935       }
6936
6937   if (type == NULL
6938       || (type->code () != TYPE_CODE_STRUCT
6939           && type->code () != TYPE_CODE_UNION))
6940     {
6941       if (noerr)
6942         return NULL;
6943
6944       error (_("Type %s is not a structure or union type"),
6945              type != NULL ? type_as_string (type).c_str () : _("(null)"));
6946     }
6947
6948   type = to_static_fixed_type (type);
6949
6950   for (i = 0; i < type->num_fields (); i += 1)
6951     {
6952       const char *t_field_name = type->field (i).name ();
6953       struct type *t;
6954
6955       if (t_field_name == NULL)
6956         continue;
6957
6958       else if (ada_is_parent_field (type, i))
6959         {
6960           /* This is a field pointing us to the parent type of a tagged
6961              type.  As hinted in this function's documentation, we give
6962              preference to fields in the current record first, so what
6963              we do here is just record the index of this field before
6964              we skip it.  If it turns out we couldn't find our field
6965              in the current record, then we'll get back to it and search
6966              inside it whether the field might exist in the parent.  */
6967
6968           parent_offset = i;
6969           continue;
6970         }
6971
6972       else if (field_name_match (t_field_name, name))
6973         return type->field (i).type ();
6974
6975       else if (ada_is_wrapper_field (type, i))
6976         {
6977           t = ada_lookup_struct_elt_type (type->field (i).type (), name,
6978                                           0, 1);
6979           if (t != NULL)
6980             return t;
6981         }
6982
6983       else if (ada_is_variant_part (type, i))
6984         {
6985           int j;
6986           struct type *field_type = ada_check_typedef (type->field (i).type ());
6987
6988           for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
6989             {
6990               /* FIXME pnh 2008/01/26: We check for a field that is
6991                  NOT wrapped in a struct, since the compiler sometimes
6992                  generates these for unchecked variant types.  Revisit
6993                  if the compiler changes this practice.  */
6994               const char *v_field_name = field_type->field (j).name ();
6995
6996               if (v_field_name != NULL 
6997                   && field_name_match (v_field_name, name))
6998                 t = field_type->field (j).type ();
6999               else
7000                 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
7001                                                 name, 0, 1);
7002
7003               if (t != NULL)
7004                 return t;
7005             }
7006         }
7007
7008     }
7009
7010     /* Field not found so far.  If this is a tagged type which
7011        has a parent, try finding that field in the parent now.  */
7012
7013     if (parent_offset != -1)
7014       {
7015         struct type *t;
7016
7017         t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
7018                                         name, 0, 1);
7019         if (t != NULL)
7020           return t;
7021       }
7022
7023 BadName:
7024   if (!noerr)
7025     {
7026       const char *name_str = name != NULL ? name : _("<null>");
7027
7028       error (_("Type %s has no component named %s"),
7029              type_as_string (type).c_str (), name_str);
7030     }
7031
7032   return NULL;
7033 }
7034
7035 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7036    within a value of type OUTER_TYPE, return true iff VAR_TYPE
7037    represents an unchecked union (that is, the variant part of a
7038    record that is named in an Unchecked_Union pragma).  */
7039
7040 static int
7041 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7042 {
7043   const char *discrim_name = ada_variant_discrim_name (var_type);
7044
7045   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7046 }
7047
7048
7049 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7050    within OUTER, determine which variant clause (field number in VAR_TYPE,
7051    numbering from 0) is applicable.  Returns -1 if none are.  */
7052
7053 int
7054 ada_which_variant_applies (struct type *var_type, struct value *outer)
7055 {
7056   int others_clause;
7057   int i;
7058   const char *discrim_name = ada_variant_discrim_name (var_type);
7059   struct value *discrim;
7060   LONGEST discrim_val;
7061
7062   /* Using plain value_from_contents_and_address here causes problems
7063      because we will end up trying to resolve a type that is currently
7064      being constructed.  */
7065   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7066   if (discrim == NULL)
7067     return -1;
7068   discrim_val = value_as_long (discrim);
7069
7070   others_clause = -1;
7071   for (i = 0; i < var_type->num_fields (); i += 1)
7072     {
7073       if (ada_is_others_clause (var_type, i))
7074         others_clause = i;
7075       else if (ada_in_variant (discrim_val, var_type, i))
7076         return i;
7077     }
7078
7079   return others_clause;
7080 }
7081 \f
7082
7083
7084                                 /* Dynamic-Sized Records */
7085
7086 /* Strategy: The type ostensibly attached to a value with dynamic size
7087    (i.e., a size that is not statically recorded in the debugging
7088    data) does not accurately reflect the size or layout of the value.
7089    Our strategy is to convert these values to values with accurate,
7090    conventional types that are constructed on the fly.  */
7091
7092 /* There is a subtle and tricky problem here.  In general, we cannot
7093    determine the size of dynamic records without its data.  However,
7094    the 'struct value' data structure, which GDB uses to represent
7095    quantities in the inferior process (the target), requires the size
7096    of the type at the time of its allocation in order to reserve space
7097    for GDB's internal copy of the data.  That's why the
7098    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7099    rather than struct value*s.
7100
7101    However, GDB's internal history variables ($1, $2, etc.) are
7102    struct value*s containing internal copies of the data that are not, in
7103    general, the same as the data at their corresponding addresses in
7104    the target.  Fortunately, the types we give to these values are all
7105    conventional, fixed-size types (as per the strategy described
7106    above), so that we don't usually have to perform the
7107    'to_fixed_xxx_type' conversions to look at their values.
7108    Unfortunately, there is one exception: if one of the internal
7109    history variables is an array whose elements are unconstrained
7110    records, then we will need to create distinct fixed types for each
7111    element selected.  */
7112
7113 /* The upshot of all of this is that many routines take a (type, host
7114    address, target address) triple as arguments to represent a value.
7115    The host address, if non-null, is supposed to contain an internal
7116    copy of the relevant data; otherwise, the program is to consult the
7117    target at the target address.  */
7118
7119 /* Assuming that VAL0 represents a pointer value, the result of
7120    dereferencing it.  Differs from value_ind in its treatment of
7121    dynamic-sized types.  */
7122
7123 struct value *
7124 ada_value_ind (struct value *val0)
7125 {
7126   struct value *val = value_ind (val0);
7127
7128   if (ada_is_tagged_type (value_type (val), 0))
7129     val = ada_tag_value_at_base_address (val);
7130
7131   return ada_to_fixed_value (val);
7132 }
7133
7134 /* The value resulting from dereferencing any "reference to"
7135    qualifiers on VAL0.  */
7136
7137 static struct value *
7138 ada_coerce_ref (struct value *val0)
7139 {
7140   if (value_type (val0)->code () == TYPE_CODE_REF)
7141     {
7142       struct value *val = val0;
7143
7144       val = coerce_ref (val);
7145
7146       if (ada_is_tagged_type (value_type (val), 0))
7147         val = ada_tag_value_at_base_address (val);
7148
7149       return ada_to_fixed_value (val);
7150     }
7151   else
7152     return val0;
7153 }
7154
7155 /* Return the bit alignment required for field #F of template type TYPE.  */
7156
7157 static unsigned int
7158 field_alignment (struct type *type, int f)
7159 {
7160   const char *name = type->field (f).name ();
7161   int len;
7162   int align_offset;
7163
7164   /* The field name should never be null, unless the debugging information
7165      is somehow malformed.  In this case, we assume the field does not
7166      require any alignment.  */
7167   if (name == NULL)
7168     return 1;
7169
7170   len = strlen (name);
7171
7172   if (!isdigit (name[len - 1]))
7173     return 1;
7174
7175   if (isdigit (name[len - 2]))
7176     align_offset = len - 2;
7177   else
7178     align_offset = len - 1;
7179
7180   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7181     return TARGET_CHAR_BIT;
7182
7183   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7184 }
7185
7186 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7187
7188 static struct symbol *
7189 ada_find_any_type_symbol (const char *name)
7190 {
7191   struct symbol *sym;
7192
7193   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7194   if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7195     return sym;
7196
7197   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7198   return sym;
7199 }
7200
7201 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7202    solely for types defined by debug info, it will not search the GDB
7203    primitive types.  */
7204
7205 static struct type *
7206 ada_find_any_type (const char *name)
7207 {
7208   struct symbol *sym = ada_find_any_type_symbol (name);
7209
7210   if (sym != NULL)
7211     return SYMBOL_TYPE (sym);
7212
7213   return NULL;
7214 }
7215
7216 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7217    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
7218    symbol, in which case it is returned.  Otherwise, this looks for
7219    symbols whose name is that of NAME_SYM suffixed with  "___XR".
7220    Return symbol if found, and NULL otherwise.  */
7221
7222 static bool
7223 ada_is_renaming_symbol (struct symbol *name_sym)
7224 {
7225   const char *name = name_sym->linkage_name ();
7226   return strstr (name, "___XR") != NULL;
7227 }
7228
7229 /* Because of GNAT encoding conventions, several GDB symbols may match a
7230    given type name.  If the type denoted by TYPE0 is to be preferred to
7231    that of TYPE1 for purposes of type printing, return non-zero;
7232    otherwise return 0.  */
7233
7234 int
7235 ada_prefer_type (struct type *type0, struct type *type1)
7236 {
7237   if (type1 == NULL)
7238     return 1;
7239   else if (type0 == NULL)
7240     return 0;
7241   else if (type1->code () == TYPE_CODE_VOID)
7242     return 1;
7243   else if (type0->code () == TYPE_CODE_VOID)
7244     return 0;
7245   else if (type1->name () == NULL && type0->name () != NULL)
7246     return 1;
7247   else if (ada_is_constrained_packed_array_type (type0))
7248     return 1;
7249   else if (ada_is_array_descriptor_type (type0)
7250            && !ada_is_array_descriptor_type (type1))
7251     return 1;
7252   else
7253     {
7254       const char *type0_name = type0->name ();
7255       const char *type1_name = type1->name ();
7256
7257       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7258           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7259         return 1;
7260     }
7261   return 0;
7262 }
7263
7264 /* The name of TYPE, which is its TYPE_NAME.  Null if TYPE is
7265    null.  */
7266
7267 const char *
7268 ada_type_name (struct type *type)
7269 {
7270   if (type == NULL)
7271     return NULL;
7272   return type->name ();
7273 }
7274
7275 /* Search the list of "descriptive" types associated to TYPE for a type
7276    whose name is NAME.  */
7277
7278 static struct type *
7279 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7280 {
7281   struct type *result, *tmp;
7282
7283   if (ada_ignore_descriptive_types_p)
7284     return NULL;
7285
7286   /* If there no descriptive-type info, then there is no parallel type
7287      to be found.  */
7288   if (!HAVE_GNAT_AUX_INFO (type))
7289     return NULL;
7290
7291   result = TYPE_DESCRIPTIVE_TYPE (type);
7292   while (result != NULL)
7293     {
7294       const char *result_name = ada_type_name (result);
7295
7296       if (result_name == NULL)
7297         {
7298           warning (_("unexpected null name on descriptive type"));
7299           return NULL;
7300         }
7301
7302       /* If the names match, stop.  */
7303       if (strcmp (result_name, name) == 0)
7304         break;
7305
7306       /* Otherwise, look at the next item on the list, if any.  */
7307       if (HAVE_GNAT_AUX_INFO (result))
7308         tmp = TYPE_DESCRIPTIVE_TYPE (result);
7309       else
7310         tmp = NULL;
7311
7312       /* If not found either, try after having resolved the typedef.  */
7313       if (tmp != NULL)
7314         result = tmp;
7315       else
7316         {
7317           result = check_typedef (result);
7318           if (HAVE_GNAT_AUX_INFO (result))
7319             result = TYPE_DESCRIPTIVE_TYPE (result);
7320           else
7321             result = NULL;
7322         }
7323     }
7324
7325   /* If we didn't find a match, see whether this is a packed array.  With
7326      older compilers, the descriptive type information is either absent or
7327      irrelevant when it comes to packed arrays so the above lookup fails.
7328      Fall back to using a parallel lookup by name in this case.  */
7329   if (result == NULL && ada_is_constrained_packed_array_type (type))
7330     return ada_find_any_type (name);
7331
7332   return result;
7333 }
7334
7335 /* Find a parallel type to TYPE with the specified NAME, using the
7336    descriptive type taken from the debugging information, if available,
7337    and otherwise using the (slower) name-based method.  */
7338
7339 static struct type *
7340 ada_find_parallel_type_with_name (struct type *type, const char *name)
7341 {
7342   struct type *result = NULL;
7343
7344   if (HAVE_GNAT_AUX_INFO (type))
7345     result = find_parallel_type_by_descriptive_type (type, name);
7346   else
7347     result = ada_find_any_type (name);
7348
7349   return result;
7350 }
7351
7352 /* Same as above, but specify the name of the parallel type by appending
7353    SUFFIX to the name of TYPE.  */
7354
7355 struct type *
7356 ada_find_parallel_type (struct type *type, const char *suffix)
7357 {
7358   char *name;
7359   const char *type_name = ada_type_name (type);
7360   int len;
7361
7362   if (type_name == NULL)
7363     return NULL;
7364
7365   len = strlen (type_name);
7366
7367   name = (char *) alloca (len + strlen (suffix) + 1);
7368
7369   strcpy (name, type_name);
7370   strcpy (name + len, suffix);
7371
7372   return ada_find_parallel_type_with_name (type, name);
7373 }
7374
7375 /* If TYPE is a variable-size record type, return the corresponding template
7376    type describing its fields.  Otherwise, return NULL.  */
7377
7378 static struct type *
7379 dynamic_template_type (struct type *type)
7380 {
7381   type = ada_check_typedef (type);
7382
7383   if (type == NULL || type->code () != TYPE_CODE_STRUCT
7384       || ada_type_name (type) == NULL)
7385     return NULL;
7386   else
7387     {
7388       int len = strlen (ada_type_name (type));
7389
7390       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7391         return type;
7392       else
7393         return ada_find_parallel_type (type, "___XVE");
7394     }
7395 }
7396
7397 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7398    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
7399
7400 static int
7401 is_dynamic_field (struct type *templ_type, int field_num)
7402 {
7403   const char *name = templ_type->field (field_num).name ();
7404
7405   return name != NULL
7406     && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7407     && strstr (name, "___XVL") != NULL;
7408 }
7409
7410 /* The index of the variant field of TYPE, or -1 if TYPE does not
7411    represent a variant record type.  */
7412
7413 static int
7414 variant_field_index (struct type *type)
7415 {
7416   int f;
7417
7418   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7419     return -1;
7420
7421   for (f = 0; f < type->num_fields (); f += 1)
7422     {
7423       if (ada_is_variant_part (type, f))
7424         return f;
7425     }
7426   return -1;
7427 }
7428
7429 /* A record type with no fields.  */
7430
7431 static struct type *
7432 empty_record (struct type *templ)
7433 {
7434   struct type *type = alloc_type_copy (templ);
7435
7436   type->set_code (TYPE_CODE_STRUCT);
7437   INIT_NONE_SPECIFIC (type);
7438   type->set_name ("<empty>");
7439   TYPE_LENGTH (type) = 0;
7440   return type;
7441 }
7442
7443 /* An ordinary record type (with fixed-length fields) that describes
7444    the value of type TYPE at VALADDR or ADDRESS (see comments at
7445    the beginning of this section) VAL according to GNAT conventions.
7446    DVAL0 should describe the (portion of a) record that contains any
7447    necessary discriminants.  It should be NULL if value_type (VAL) is
7448    an outer-level type (i.e., as opposed to a branch of a variant.)  A
7449    variant field (unless unchecked) is replaced by a particular branch
7450    of the variant.
7451
7452    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7453    length are not statically known are discarded.  As a consequence,
7454    VALADDR, ADDRESS and DVAL0 are ignored.
7455
7456    NOTE: Limitations: For now, we assume that dynamic fields and
7457    variants occupy whole numbers of bytes.  However, they need not be
7458    byte-aligned.  */
7459
7460 struct type *
7461 ada_template_to_fixed_record_type_1 (struct type *type,
7462                                      const gdb_byte *valaddr,
7463                                      CORE_ADDR address, struct value *dval0,
7464                                      int keep_dynamic_fields)
7465 {
7466   struct value *mark = value_mark ();
7467   struct value *dval;
7468   struct type *rtype;
7469   int nfields, bit_len;
7470   int variant_field;
7471   long off;
7472   int fld_bit_len;
7473   int f;
7474
7475   /* Compute the number of fields in this record type that are going
7476      to be processed: unless keep_dynamic_fields, this includes only
7477      fields whose position and length are static will be processed.  */
7478   if (keep_dynamic_fields)
7479     nfields = type->num_fields ();
7480   else
7481     {
7482       nfields = 0;
7483       while (nfields < type->num_fields ()
7484              && !ada_is_variant_part (type, nfields)
7485              && !is_dynamic_field (type, nfields))
7486         nfields++;
7487     }
7488
7489   rtype = alloc_type_copy (type);
7490   rtype->set_code (TYPE_CODE_STRUCT);
7491   INIT_NONE_SPECIFIC (rtype);
7492   rtype->set_num_fields (nfields);
7493   rtype->set_fields
7494    ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7495   rtype->set_name (ada_type_name (type));
7496   rtype->set_is_fixed_instance (true);
7497
7498   off = 0;
7499   bit_len = 0;
7500   variant_field = -1;
7501
7502   for (f = 0; f < nfields; f += 1)
7503     {
7504       off = align_up (off, field_alignment (type, f))
7505         + TYPE_FIELD_BITPOS (type, f);
7506       SET_FIELD_BITPOS (rtype->field (f), off);
7507       TYPE_FIELD_BITSIZE (rtype, f) = 0;
7508
7509       if (ada_is_variant_part (type, f))
7510         {
7511           variant_field = f;
7512           fld_bit_len = 0;
7513         }
7514       else if (is_dynamic_field (type, f))
7515         {
7516           const gdb_byte *field_valaddr = valaddr;
7517           CORE_ADDR field_address = address;
7518           struct type *field_type =
7519             TYPE_TARGET_TYPE (type->field (f).type ());
7520
7521           if (dval0 == NULL)
7522             {
7523               /* Using plain value_from_contents_and_address here
7524                  causes problems because we will end up trying to
7525                  resolve a type that is currently being
7526                  constructed.  */
7527               dval = value_from_contents_and_address_unresolved (rtype,
7528                                                                  valaddr,
7529                                                                  address);
7530               rtype = value_type (dval);
7531             }
7532           else
7533             dval = dval0;
7534
7535           /* If the type referenced by this field is an aligner type, we need
7536              to unwrap that aligner type, because its size might not be set.
7537              Keeping the aligner type would cause us to compute the wrong
7538              size for this field, impacting the offset of the all the fields
7539              that follow this one.  */
7540           if (ada_is_aligner_type (field_type))
7541             {
7542               long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7543
7544               field_valaddr = cond_offset_host (field_valaddr, field_offset);
7545               field_address = cond_offset_target (field_address, field_offset);
7546               field_type = ada_aligned_type (field_type);
7547             }
7548
7549           field_valaddr = cond_offset_host (field_valaddr,
7550                                             off / TARGET_CHAR_BIT);
7551           field_address = cond_offset_target (field_address,
7552                                               off / TARGET_CHAR_BIT);
7553
7554           /* Get the fixed type of the field.  Note that, in this case,
7555              we do not want to get the real type out of the tag: if
7556              the current field is the parent part of a tagged record,
7557              we will get the tag of the object.  Clearly wrong: the real
7558              type of the parent is not the real type of the child.  We
7559              would end up in an infinite loop.  */
7560           field_type = ada_get_base_type (field_type);
7561           field_type = ada_to_fixed_type (field_type, field_valaddr,
7562                                           field_address, dval, 0);
7563
7564           rtype->field (f).set_type (field_type);
7565           rtype->field (f).set_name (type->field (f).name ());
7566           /* The multiplication can potentially overflow.  But because
7567              the field length has been size-checked just above, and
7568              assuming that the maximum size is a reasonable value,
7569              an overflow should not happen in practice.  So rather than
7570              adding overflow recovery code to this already complex code,
7571              we just assume that it's not going to happen.  */
7572           fld_bit_len =
7573             TYPE_LENGTH (rtype->field (f).type ()) * TARGET_CHAR_BIT;
7574         }
7575       else
7576         {
7577           /* Note: If this field's type is a typedef, it is important
7578              to preserve the typedef layer.
7579
7580              Otherwise, we might be transforming a typedef to a fat
7581              pointer (encoding a pointer to an unconstrained array),
7582              into a basic fat pointer (encoding an unconstrained
7583              array).  As both types are implemented using the same
7584              structure, the typedef is the only clue which allows us
7585              to distinguish between the two options.  Stripping it
7586              would prevent us from printing this field appropriately.  */
7587           rtype->field (f).set_type (type->field (f).type ());
7588           rtype->field (f).set_name (type->field (f).name ());
7589           if (TYPE_FIELD_BITSIZE (type, f) > 0)
7590             fld_bit_len =
7591               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7592           else
7593             {
7594               struct type *field_type = type->field (f).type ();
7595
7596               /* We need to be careful of typedefs when computing
7597                  the length of our field.  If this is a typedef,
7598                  get the length of the target type, not the length
7599                  of the typedef.  */
7600               if (field_type->code () == TYPE_CODE_TYPEDEF)
7601                 field_type = ada_typedef_target_type (field_type);
7602
7603               fld_bit_len =
7604                 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7605             }
7606         }
7607       if (off + fld_bit_len > bit_len)
7608         bit_len = off + fld_bit_len;
7609       off += fld_bit_len;
7610       TYPE_LENGTH (rtype) =
7611         align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7612     }
7613
7614   /* We handle the variant part, if any, at the end because of certain
7615      odd cases in which it is re-ordered so as NOT to be the last field of
7616      the record.  This can happen in the presence of representation
7617      clauses.  */
7618   if (variant_field >= 0)
7619     {
7620       struct type *branch_type;
7621
7622       off = TYPE_FIELD_BITPOS (rtype, variant_field);
7623
7624       if (dval0 == NULL)
7625         {
7626           /* Using plain value_from_contents_and_address here causes
7627              problems because we will end up trying to resolve a type
7628              that is currently being constructed.  */
7629           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
7630                                                              address);
7631           rtype = value_type (dval);
7632         }
7633       else
7634         dval = dval0;
7635
7636       branch_type =
7637         to_fixed_variant_branch_type
7638         (type->field (variant_field).type (),
7639          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7640          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7641       if (branch_type == NULL)
7642         {
7643           for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
7644             rtype->field (f - 1) = rtype->field (f);
7645           rtype->set_num_fields (rtype->num_fields () - 1);
7646         }
7647       else
7648         {
7649           rtype->field (variant_field).set_type (branch_type);
7650           rtype->field (variant_field).set_name ("S");
7651           fld_bit_len =
7652             TYPE_LENGTH (rtype->field (variant_field).type ()) *
7653             TARGET_CHAR_BIT;
7654           if (off + fld_bit_len > bit_len)
7655             bit_len = off + fld_bit_len;
7656           TYPE_LENGTH (rtype) =
7657             align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7658         }
7659     }
7660
7661   /* According to exp_dbug.ads, the size of TYPE for variable-size records
7662      should contain the alignment of that record, which should be a strictly
7663      positive value.  If null or negative, then something is wrong, most
7664      probably in the debug info.  In that case, we don't round up the size
7665      of the resulting type.  If this record is not part of another structure,
7666      the current RTYPE length might be good enough for our purposes.  */
7667   if (TYPE_LENGTH (type) <= 0)
7668     {
7669       if (rtype->name ())
7670         warning (_("Invalid type size for `%s' detected: %s."),
7671                  rtype->name (), pulongest (TYPE_LENGTH (type)));
7672       else
7673         warning (_("Invalid type size for <unnamed> detected: %s."),
7674                  pulongest (TYPE_LENGTH (type)));
7675     }
7676   else
7677     {
7678       TYPE_LENGTH (rtype) = align_up (TYPE_LENGTH (rtype),
7679                                       TYPE_LENGTH (type));
7680     }
7681
7682   value_free_to_mark (mark);
7683   return rtype;
7684 }
7685
7686 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7687    of 1.  */
7688
7689 static struct type *
7690 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
7691                                CORE_ADDR address, struct value *dval0)
7692 {
7693   return ada_template_to_fixed_record_type_1 (type, valaddr,
7694                                               address, dval0, 1);
7695 }
7696
7697 /* An ordinary record type in which ___XVL-convention fields and
7698    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7699    static approximations, containing all possible fields.  Uses
7700    no runtime values.  Useless for use in values, but that's OK,
7701    since the results are used only for type determinations.   Works on both
7702    structs and unions.  Representation note: to save space, we memorize
7703    the result of this function in the TYPE_TARGET_TYPE of the
7704    template type.  */
7705
7706 static struct type *
7707 template_to_static_fixed_type (struct type *type0)
7708 {
7709   struct type *type;
7710   int nfields;
7711   int f;
7712
7713   /* No need no do anything if the input type is already fixed.  */
7714   if (type0->is_fixed_instance ())
7715     return type0;
7716
7717   /* Likewise if we already have computed the static approximation.  */
7718   if (TYPE_TARGET_TYPE (type0) != NULL)
7719     return TYPE_TARGET_TYPE (type0);
7720
7721   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
7722   type = type0;
7723   nfields = type0->num_fields ();
7724
7725   /* Whether or not we cloned TYPE0, cache the result so that we don't do
7726      recompute all over next time.  */
7727   TYPE_TARGET_TYPE (type0) = type;
7728
7729   for (f = 0; f < nfields; f += 1)
7730     {
7731       struct type *field_type = type0->field (f).type ();
7732       struct type *new_type;
7733
7734       if (is_dynamic_field (type0, f))
7735         {
7736           field_type = ada_check_typedef (field_type);
7737           new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
7738         }
7739       else
7740         new_type = static_unwrap_type (field_type);
7741
7742       if (new_type != field_type)
7743         {
7744           /* Clone TYPE0 only the first time we get a new field type.  */
7745           if (type == type0)
7746             {
7747               TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
7748               type->set_code (type0->code ());
7749               INIT_NONE_SPECIFIC (type);
7750               type->set_num_fields (nfields);
7751
7752               field *fields =
7753                 ((struct field *)
7754                  TYPE_ALLOC (type, nfields * sizeof (struct field)));
7755               memcpy (fields, type0->fields (),
7756                       sizeof (struct field) * nfields);
7757               type->set_fields (fields);
7758
7759               type->set_name (ada_type_name (type0));
7760               type->set_is_fixed_instance (true);
7761               TYPE_LENGTH (type) = 0;
7762             }
7763           type->field (f).set_type (new_type);
7764           type->field (f).set_name (type0->field (f).name ());
7765         }
7766     }
7767
7768   return type;
7769 }
7770
7771 /* Given an object of type TYPE whose contents are at VALADDR and
7772    whose address in memory is ADDRESS, returns a revision of TYPE,
7773    which should be a non-dynamic-sized record, in which the variant
7774    part, if any, is replaced with the appropriate branch.  Looks
7775    for discriminant values in DVAL0, which can be NULL if the record
7776    contains the necessary discriminant values.  */
7777
7778 static struct type *
7779 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
7780                                    CORE_ADDR address, struct value *dval0)
7781 {
7782   struct value *mark = value_mark ();
7783   struct value *dval;
7784   struct type *rtype;
7785   struct type *branch_type;
7786   int nfields = type->num_fields ();
7787   int variant_field = variant_field_index (type);
7788
7789   if (variant_field == -1)
7790     return type;
7791
7792   if (dval0 == NULL)
7793     {
7794       dval = value_from_contents_and_address (type, valaddr, address);
7795       type = value_type (dval);
7796     }
7797   else
7798     dval = dval0;
7799
7800   rtype = alloc_type_copy (type);
7801   rtype->set_code (TYPE_CODE_STRUCT);
7802   INIT_NONE_SPECIFIC (rtype);
7803   rtype->set_num_fields (nfields);
7804
7805   field *fields =
7806     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7807   memcpy (fields, type->fields (), sizeof (struct field) * nfields);
7808   rtype->set_fields (fields);
7809
7810   rtype->set_name (ada_type_name (type));
7811   rtype->set_is_fixed_instance (true);
7812   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7813
7814   branch_type = to_fixed_variant_branch_type
7815     (type->field (variant_field).type (),
7816      cond_offset_host (valaddr,
7817                        TYPE_FIELD_BITPOS (type, variant_field)
7818                        / TARGET_CHAR_BIT),
7819      cond_offset_target (address,
7820                          TYPE_FIELD_BITPOS (type, variant_field)
7821                          / TARGET_CHAR_BIT), dval);
7822   if (branch_type == NULL)
7823     {
7824       int f;
7825
7826       for (f = variant_field + 1; f < nfields; f += 1)
7827         rtype->field (f - 1) = rtype->field (f);
7828       rtype->set_num_fields (rtype->num_fields () - 1);
7829     }
7830   else
7831     {
7832       rtype->field (variant_field).set_type (branch_type);
7833       rtype->field (variant_field).set_name ("S");
7834       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
7835       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
7836     }
7837   TYPE_LENGTH (rtype) -= TYPE_LENGTH (type->field (variant_field).type ());
7838
7839   value_free_to_mark (mark);
7840   return rtype;
7841 }
7842
7843 /* An ordinary record type (with fixed-length fields) that describes
7844    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7845    beginning of this section].   Any necessary discriminants' values
7846    should be in DVAL, a record value; it may be NULL if the object
7847    at ADDR itself contains any necessary discriminant values.
7848    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7849    values from the record are needed.  Except in the case that DVAL,
7850    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7851    unchecked) is replaced by a particular branch of the variant.
7852
7853    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7854    is questionable and may be removed.  It can arise during the
7855    processing of an unconstrained-array-of-record type where all the
7856    variant branches have exactly the same size.  This is because in
7857    such cases, the compiler does not bother to use the XVS convention
7858    when encoding the record.  I am currently dubious of this
7859    shortcut and suspect the compiler should be altered.  FIXME.  */
7860
7861 static struct type *
7862 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
7863                       CORE_ADDR address, struct value *dval)
7864 {
7865   struct type *templ_type;
7866
7867   if (type0->is_fixed_instance ())
7868     return type0;
7869
7870   templ_type = dynamic_template_type (type0);
7871
7872   if (templ_type != NULL)
7873     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
7874   else if (variant_field_index (type0) >= 0)
7875     {
7876       if (dval == NULL && valaddr == NULL && address == 0)
7877         return type0;
7878       return to_record_with_fixed_variant_part (type0, valaddr, address,
7879                                                 dval);
7880     }
7881   else
7882     {
7883       type0->set_is_fixed_instance (true);
7884       return type0;
7885     }
7886
7887 }
7888
7889 /* An ordinary record type (with fixed-length fields) that describes
7890    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7891    union type.  Any necessary discriminants' values should be in DVAL,
7892    a record value.  That is, this routine selects the appropriate
7893    branch of the union at ADDR according to the discriminant value
7894    indicated in the union's type name.  Returns VAR_TYPE0 itself if
7895    it represents a variant subject to a pragma Unchecked_Union.  */
7896
7897 static struct type *
7898 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
7899                               CORE_ADDR address, struct value *dval)
7900 {
7901   int which;
7902   struct type *templ_type;
7903   struct type *var_type;
7904
7905   if (var_type0->code () == TYPE_CODE_PTR)
7906     var_type = TYPE_TARGET_TYPE (var_type0);
7907   else
7908     var_type = var_type0;
7909
7910   templ_type = ada_find_parallel_type (var_type, "___XVU");
7911
7912   if (templ_type != NULL)
7913     var_type = templ_type;
7914
7915   if (is_unchecked_variant (var_type, value_type (dval)))
7916       return var_type0;
7917   which = ada_which_variant_applies (var_type, dval);
7918
7919   if (which < 0)
7920     return empty_record (var_type);
7921   else if (is_dynamic_field (var_type, which))
7922     return to_fixed_record_type
7923       (TYPE_TARGET_TYPE (var_type->field (which).type ()),
7924        valaddr, address, dval);
7925   else if (variant_field_index (var_type->field (which).type ()) >= 0)
7926     return
7927       to_fixed_record_type
7928       (var_type->field (which).type (), valaddr, address, dval);
7929   else
7930     return var_type->field (which).type ();
7931 }
7932
7933 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
7934    ENCODING_TYPE, a type following the GNAT conventions for discrete
7935    type encodings, only carries redundant information.  */
7936
7937 static int
7938 ada_is_redundant_range_encoding (struct type *range_type,
7939                                  struct type *encoding_type)
7940 {
7941   const char *bounds_str;
7942   int n;
7943   LONGEST lo, hi;
7944
7945   gdb_assert (range_type->code () == TYPE_CODE_RANGE);
7946
7947   if (get_base_type (range_type)->code ()
7948       != get_base_type (encoding_type)->code ())
7949     {
7950       /* The compiler probably used a simple base type to describe
7951          the range type instead of the range's actual base type,
7952          expecting us to get the real base type from the encoding
7953          anyway.  In this situation, the encoding cannot be ignored
7954          as redundant.  */
7955       return 0;
7956     }
7957
7958   if (is_dynamic_type (range_type))
7959     return 0;
7960
7961   if (encoding_type->name () == NULL)
7962     return 0;
7963
7964   bounds_str = strstr (encoding_type->name (), "___XDLU_");
7965   if (bounds_str == NULL)
7966     return 0;
7967
7968   n = 8; /* Skip "___XDLU_".  */
7969   if (!ada_scan_number (bounds_str, n, &lo, &n))
7970     return 0;
7971   if (range_type->bounds ()->low.const_val () != lo)
7972     return 0;
7973
7974   n += 2; /* Skip the "__" separator between the two bounds.  */
7975   if (!ada_scan_number (bounds_str, n, &hi, &n))
7976     return 0;
7977   if (range_type->bounds ()->high.const_val () != hi)
7978     return 0;
7979
7980   return 1;
7981 }
7982
7983 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
7984    a type following the GNAT encoding for describing array type
7985    indices, only carries redundant information.  */
7986
7987 static int
7988 ada_is_redundant_index_type_desc (struct type *array_type,
7989                                   struct type *desc_type)
7990 {
7991   struct type *this_layer = check_typedef (array_type);
7992   int i;
7993
7994   for (i = 0; i < desc_type->num_fields (); i++)
7995     {
7996       if (!ada_is_redundant_range_encoding (this_layer->index_type (),
7997                                             desc_type->field (i).type ()))
7998         return 0;
7999       this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8000     }
8001
8002   return 1;
8003 }
8004
8005 /* Assuming that TYPE0 is an array type describing the type of a value
8006    at ADDR, and that DVAL describes a record containing any
8007    discriminants used in TYPE0, returns a type for the value that
8008    contains no dynamic components (that is, no components whose sizes
8009    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
8010    true, gives an error message if the resulting type's size is over
8011    varsize_limit.  */
8012
8013 static struct type *
8014 to_fixed_array_type (struct type *type0, struct value *dval,
8015                      int ignore_too_big)
8016 {
8017   struct type *index_type_desc;
8018   struct type *result;
8019   int constrained_packed_array_p;
8020   static const char *xa_suffix = "___XA";
8021
8022   type0 = ada_check_typedef (type0);
8023   if (type0->is_fixed_instance ())
8024     return type0;
8025
8026   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8027   if (constrained_packed_array_p)
8028     {
8029       type0 = decode_constrained_packed_array_type (type0);
8030       if (type0 == nullptr)
8031         error (_("could not decode constrained packed array type"));
8032     }
8033
8034   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8035
8036   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8037      encoding suffixed with 'P' may still be generated.  If so,
8038      it should be used to find the XA type.  */
8039
8040   if (index_type_desc == NULL)
8041     {
8042       const char *type_name = ada_type_name (type0);
8043
8044       if (type_name != NULL)
8045         {
8046           const int len = strlen (type_name);
8047           char *name = (char *) alloca (len + strlen (xa_suffix));
8048
8049           if (type_name[len - 1] == 'P')
8050             {
8051               strcpy (name, type_name);
8052               strcpy (name + len - 1, xa_suffix);
8053               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8054             }
8055         }
8056     }
8057
8058   ada_fixup_array_indexes_type (index_type_desc);
8059   if (index_type_desc != NULL
8060       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8061     {
8062       /* Ignore this ___XA parallel type, as it does not bring any
8063          useful information.  This allows us to avoid creating fixed
8064          versions of the array's index types, which would be identical
8065          to the original ones.  This, in turn, can also help avoid
8066          the creation of fixed versions of the array itself.  */
8067       index_type_desc = NULL;
8068     }
8069
8070   if (index_type_desc == NULL)
8071     {
8072       struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8073
8074       /* NOTE: elt_type---the fixed version of elt_type0---should never
8075          depend on the contents of the array in properly constructed
8076          debugging data.  */
8077       /* Create a fixed version of the array element type.
8078          We're not providing the address of an element here,
8079          and thus the actual object value cannot be inspected to do
8080          the conversion.  This should not be a problem, since arrays of
8081          unconstrained objects are not allowed.  In particular, all
8082          the elements of an array of a tagged type should all be of
8083          the same type specified in the debugging info.  No need to
8084          consult the object tag.  */
8085       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8086
8087       /* Make sure we always create a new array type when dealing with
8088          packed array types, since we're going to fix-up the array
8089          type length and element bitsize a little further down.  */
8090       if (elt_type0 == elt_type && !constrained_packed_array_p)
8091         result = type0;
8092       else
8093         result = create_array_type (alloc_type_copy (type0),
8094                                     elt_type, type0->index_type ());
8095     }
8096   else
8097     {
8098       int i;
8099       struct type *elt_type0;
8100
8101       elt_type0 = type0;
8102       for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8103         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8104
8105       /* NOTE: result---the fixed version of elt_type0---should never
8106          depend on the contents of the array in properly constructed
8107          debugging data.  */
8108       /* Create a fixed version of the array element type.
8109          We're not providing the address of an element here,
8110          and thus the actual object value cannot be inspected to do
8111          the conversion.  This should not be a problem, since arrays of
8112          unconstrained objects are not allowed.  In particular, all
8113          the elements of an array of a tagged type should all be of
8114          the same type specified in the debugging info.  No need to
8115          consult the object tag.  */
8116       result =
8117         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8118
8119       elt_type0 = type0;
8120       for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8121         {
8122           struct type *range_type =
8123             to_fixed_range_type (index_type_desc->field (i).type (), dval);
8124
8125           result = create_array_type (alloc_type_copy (elt_type0),
8126                                       result, range_type);
8127           elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8128         }
8129     }
8130
8131   /* We want to preserve the type name.  This can be useful when
8132      trying to get the type name of a value that has already been
8133      printed (for instance, if the user did "print VAR; whatis $".  */
8134   result->set_name (type0->name ());
8135
8136   if (constrained_packed_array_p)
8137     {
8138       /* So far, the resulting type has been created as if the original
8139          type was a regular (non-packed) array type.  As a result, the
8140          bitsize of the array elements needs to be set again, and the array
8141          length needs to be recomputed based on that bitsize.  */
8142       int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8143       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8144
8145       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8146       TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8147       if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8148         TYPE_LENGTH (result)++;
8149     }
8150
8151   result->set_is_fixed_instance (true);
8152   return result;
8153 }
8154
8155
8156 /* A standard type (containing no dynamically sized components)
8157    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8158    DVAL describes a record containing any discriminants used in TYPE0,
8159    and may be NULL if there are none, or if the object of type TYPE at
8160    ADDRESS or in VALADDR contains these discriminants.
8161    
8162    If CHECK_TAG is not null, in the case of tagged types, this function
8163    attempts to locate the object's tag and use it to compute the actual
8164    type.  However, when ADDRESS is null, we cannot use it to determine the
8165    location of the tag, and therefore compute the tagged type's actual type.
8166    So we return the tagged type without consulting the tag.  */
8167    
8168 static struct type *
8169 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8170                    CORE_ADDR address, struct value *dval, int check_tag)
8171 {
8172   type = ada_check_typedef (type);
8173
8174   /* Only un-fixed types need to be handled here.  */
8175   if (!HAVE_GNAT_AUX_INFO (type))
8176     return type;
8177
8178   switch (type->code ())
8179     {
8180     default:
8181       return type;
8182     case TYPE_CODE_STRUCT:
8183       {
8184         struct type *static_type = to_static_fixed_type (type);
8185         struct type *fixed_record_type =
8186           to_fixed_record_type (type, valaddr, address, NULL);
8187
8188         /* If STATIC_TYPE is a tagged type and we know the object's address,
8189            then we can determine its tag, and compute the object's actual
8190            type from there.  Note that we have to use the fixed record
8191            type (the parent part of the record may have dynamic fields
8192            and the way the location of _tag is expressed may depend on
8193            them).  */
8194
8195         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8196           {
8197             struct value *tag =
8198               value_tag_from_contents_and_address
8199               (fixed_record_type,
8200                valaddr,
8201                address);
8202             struct type *real_type = type_from_tag (tag);
8203             struct value *obj =
8204               value_from_contents_and_address (fixed_record_type,
8205                                                valaddr,
8206                                                address);
8207             fixed_record_type = value_type (obj);
8208             if (real_type != NULL)
8209               return to_fixed_record_type
8210                 (real_type, NULL,
8211                  value_address (ada_tag_value_at_base_address (obj)), NULL);
8212           }
8213
8214         /* Check to see if there is a parallel ___XVZ variable.
8215            If there is, then it provides the actual size of our type.  */
8216         else if (ada_type_name (fixed_record_type) != NULL)
8217           {
8218             const char *name = ada_type_name (fixed_record_type);
8219             char *xvz_name
8220               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8221             bool xvz_found = false;
8222             LONGEST size;
8223
8224             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8225             try
8226               {
8227                 xvz_found = get_int_var_value (xvz_name, size);
8228               }
8229             catch (const gdb_exception_error &except)
8230               {
8231                 /* We found the variable, but somehow failed to read
8232                    its value.  Rethrow the same error, but with a little
8233                    bit more information, to help the user understand
8234                    what went wrong (Eg: the variable might have been
8235                    optimized out).  */
8236                 throw_error (except.error,
8237                              _("unable to read value of %s (%s)"),
8238                              xvz_name, except.what ());
8239               }
8240
8241             if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8242               {
8243                 fixed_record_type = copy_type (fixed_record_type);
8244                 TYPE_LENGTH (fixed_record_type) = size;
8245
8246                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
8247                    observed this when the debugging info is STABS, and
8248                    apparently it is something that is hard to fix.
8249
8250                    In practice, we don't need the actual type definition
8251                    at all, because the presence of the XVZ variable allows us
8252                    to assume that there must be a XVS type as well, which we
8253                    should be able to use later, when we need the actual type
8254                    definition.
8255
8256                    In the meantime, pretend that the "fixed" type we are
8257                    returning is NOT a stub, because this can cause trouble
8258                    when using this type to create new types targeting it.
8259                    Indeed, the associated creation routines often check
8260                    whether the target type is a stub and will try to replace
8261                    it, thus using a type with the wrong size.  This, in turn,
8262                    might cause the new type to have the wrong size too.
8263                    Consider the case of an array, for instance, where the size
8264                    of the array is computed from the number of elements in
8265                    our array multiplied by the size of its element.  */
8266                 fixed_record_type->set_is_stub (false);
8267               }
8268           }
8269         return fixed_record_type;
8270       }
8271     case TYPE_CODE_ARRAY:
8272       return to_fixed_array_type (type, dval, 1);
8273     case TYPE_CODE_UNION:
8274       if (dval == NULL)
8275         return type;
8276       else
8277         return to_fixed_variant_branch_type (type, valaddr, address, dval);
8278     }
8279 }
8280
8281 /* The same as ada_to_fixed_type_1, except that it preserves the type
8282    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8283
8284    The typedef layer needs be preserved in order to differentiate between
8285    arrays and array pointers when both types are implemented using the same
8286    fat pointer.  In the array pointer case, the pointer is encoded as
8287    a typedef of the pointer type.  For instance, considering:
8288
8289           type String_Access is access String;
8290           S1 : String_Access := null;
8291
8292    To the debugger, S1 is defined as a typedef of type String.  But
8293    to the user, it is a pointer.  So if the user tries to print S1,
8294    we should not dereference the array, but print the array address
8295    instead.
8296
8297    If we didn't preserve the typedef layer, we would lose the fact that
8298    the type is to be presented as a pointer (needs de-reference before
8299    being printed).  And we would also use the source-level type name.  */
8300
8301 struct type *
8302 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8303                    CORE_ADDR address, struct value *dval, int check_tag)
8304
8305 {
8306   struct type *fixed_type =
8307     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8308
8309   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8310       then preserve the typedef layer.
8311
8312       Implementation note: We can only check the main-type portion of
8313       the TYPE and FIXED_TYPE, because eliminating the typedef layer
8314       from TYPE now returns a type that has the same instance flags
8315       as TYPE.  For instance, if TYPE is a "typedef const", and its
8316       target type is a "struct", then the typedef elimination will return
8317       a "const" version of the target type.  See check_typedef for more
8318       details about how the typedef layer elimination is done.
8319
8320       brobecker/2010-11-19: It seems to me that the only case where it is
8321       useful to preserve the typedef layer is when dealing with fat pointers.
8322       Perhaps, we could add a check for that and preserve the typedef layer
8323       only in that situation.  But this seems unnecessary so far, probably
8324       because we call check_typedef/ada_check_typedef pretty much everywhere.
8325       */
8326   if (type->code () == TYPE_CODE_TYPEDEF
8327       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8328           == TYPE_MAIN_TYPE (fixed_type)))
8329     return type;
8330
8331   return fixed_type;
8332 }
8333
8334 /* A standard (static-sized) type corresponding as well as possible to
8335    TYPE0, but based on no runtime data.  */
8336
8337 static struct type *
8338 to_static_fixed_type (struct type *type0)
8339 {
8340   struct type *type;
8341
8342   if (type0 == NULL)
8343     return NULL;
8344
8345   if (type0->is_fixed_instance ())
8346     return type0;
8347
8348   type0 = ada_check_typedef (type0);
8349
8350   switch (type0->code ())
8351     {
8352     default:
8353       return type0;
8354     case TYPE_CODE_STRUCT:
8355       type = dynamic_template_type (type0);
8356       if (type != NULL)
8357         return template_to_static_fixed_type (type);
8358       else
8359         return template_to_static_fixed_type (type0);
8360     case TYPE_CODE_UNION:
8361       type = ada_find_parallel_type (type0, "___XVU");
8362       if (type != NULL)
8363         return template_to_static_fixed_type (type);
8364       else
8365         return template_to_static_fixed_type (type0);
8366     }
8367 }
8368
8369 /* A static approximation of TYPE with all type wrappers removed.  */
8370
8371 static struct type *
8372 static_unwrap_type (struct type *type)
8373 {
8374   if (ada_is_aligner_type (type))
8375     {
8376       struct type *type1 = ada_check_typedef (type)->field (0).type ();
8377       if (ada_type_name (type1) == NULL)
8378         type1->set_name (ada_type_name (type));
8379
8380       return static_unwrap_type (type1);
8381     }
8382   else
8383     {
8384       struct type *raw_real_type = ada_get_base_type (type);
8385
8386       if (raw_real_type == type)
8387         return type;
8388       else
8389         return to_static_fixed_type (raw_real_type);
8390     }
8391 }
8392
8393 /* In some cases, incomplete and private types require
8394    cross-references that are not resolved as records (for example,
8395       type Foo;
8396       type FooP is access Foo;
8397       V: FooP;
8398       type Foo is array ...;
8399    ).  In these cases, since there is no mechanism for producing
8400    cross-references to such types, we instead substitute for FooP a
8401    stub enumeration type that is nowhere resolved, and whose tag is
8402    the name of the actual type.  Call these types "non-record stubs".  */
8403
8404 /* A type equivalent to TYPE that is not a non-record stub, if one
8405    exists, otherwise TYPE.  */
8406
8407 struct type *
8408 ada_check_typedef (struct type *type)
8409 {
8410   if (type == NULL)
8411     return NULL;
8412
8413   /* If our type is an access to an unconstrained array, which is encoded
8414      as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8415      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8416      what allows us to distinguish between fat pointers that represent
8417      array types, and fat pointers that represent array access types
8418      (in both cases, the compiler implements them as fat pointers).  */
8419   if (ada_is_access_to_unconstrained_array (type))
8420     return type;
8421
8422   type = check_typedef (type);
8423   if (type == NULL || type->code () != TYPE_CODE_ENUM
8424       || !type->is_stub ()
8425       || type->name () == NULL)
8426     return type;
8427   else
8428     {
8429       const char *name = type->name ();
8430       struct type *type1 = ada_find_any_type (name);
8431
8432       if (type1 == NULL)
8433         return type;
8434
8435       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8436          stubs pointing to arrays, as we don't create symbols for array
8437          types, only for the typedef-to-array types).  If that's the case,
8438          strip the typedef layer.  */
8439       if (type1->code () == TYPE_CODE_TYPEDEF)
8440         type1 = ada_check_typedef (type1);
8441
8442       return type1;
8443     }
8444 }
8445
8446 /* A value representing the data at VALADDR/ADDRESS as described by
8447    type TYPE0, but with a standard (static-sized) type that correctly
8448    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
8449    type, then return VAL0 [this feature is simply to avoid redundant
8450    creation of struct values].  */
8451
8452 static struct value *
8453 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8454                            struct value *val0)
8455 {
8456   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8457
8458   if (type == type0 && val0 != NULL)
8459     return val0;
8460
8461   if (VALUE_LVAL (val0) != lval_memory)
8462     {
8463       /* Our value does not live in memory; it could be a convenience
8464          variable, for instance.  Create a not_lval value using val0's
8465          contents.  */
8466       return value_from_contents (type, value_contents (val0));
8467     }
8468
8469   return value_from_contents_and_address (type, 0, address);
8470 }
8471
8472 /* A value representing VAL, but with a standard (static-sized) type
8473    that correctly describes it.  Does not necessarily create a new
8474    value.  */
8475
8476 struct value *
8477 ada_to_fixed_value (struct value *val)
8478 {
8479   val = unwrap_value (val);
8480   val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8481   return val;
8482 }
8483 \f
8484
8485 /* Attributes */
8486
8487 /* Table mapping attribute numbers to names.
8488    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
8489
8490 static const char * const attribute_names[] = {
8491   "<?>",
8492
8493   "first",
8494   "last",
8495   "length",
8496   "image",
8497   "max",
8498   "min",
8499   "modulus",
8500   "pos",
8501   "size",
8502   "tag",
8503   "val",
8504   0
8505 };
8506
8507 static const char *
8508 ada_attribute_name (enum exp_opcode n)
8509 {
8510   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8511     return attribute_names[n - OP_ATR_FIRST + 1];
8512   else
8513     return attribute_names[0];
8514 }
8515
8516 /* Evaluate the 'POS attribute applied to ARG.  */
8517
8518 static LONGEST
8519 pos_atr (struct value *arg)
8520 {
8521   struct value *val = coerce_ref (arg);
8522   struct type *type = value_type (val);
8523
8524   if (!discrete_type_p (type))
8525     error (_("'POS only defined on discrete types"));
8526
8527   gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8528   if (!result.has_value ())
8529     error (_("enumeration value is invalid: can't find 'POS"));
8530
8531   return *result;
8532 }
8533
8534 struct value *
8535 ada_pos_atr (struct type *expect_type,
8536              struct expression *exp,
8537              enum noside noside, enum exp_opcode op,
8538              struct value *arg)
8539 {
8540   struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8541   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8542     return value_zero (type, not_lval);
8543   return value_from_longest (type, pos_atr (arg));
8544 }
8545
8546 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
8547
8548 static struct value *
8549 val_atr (struct type *type, LONGEST val)
8550 {
8551   gdb_assert (discrete_type_p (type));
8552   if (type->code () == TYPE_CODE_RANGE)
8553     type = TYPE_TARGET_TYPE (type);
8554   if (type->code () == TYPE_CODE_ENUM)
8555     {
8556       if (val < 0 || val >= type->num_fields ())
8557         error (_("argument to 'VAL out of range"));
8558       val = TYPE_FIELD_ENUMVAL (type, val);
8559     }
8560   return value_from_longest (type, val);
8561 }
8562
8563 struct value *
8564 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8565 {
8566   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8567     return value_zero (type, not_lval);
8568
8569   if (!discrete_type_p (type))
8570     error (_("'VAL only defined on discrete types"));
8571   if (!integer_type_p (value_type (arg)))
8572     error (_("'VAL requires integral argument"));
8573
8574   return val_atr (type, value_as_long (arg));
8575 }
8576 \f
8577
8578                                 /* Evaluation */
8579
8580 /* True if TYPE appears to be an Ada character type.
8581    [At the moment, this is true only for Character and Wide_Character;
8582    It is a heuristic test that could stand improvement].  */
8583
8584 bool
8585 ada_is_character_type (struct type *type)
8586 {
8587   const char *name;
8588
8589   /* If the type code says it's a character, then assume it really is,
8590      and don't check any further.  */
8591   if (type->code () == TYPE_CODE_CHAR)
8592     return true;
8593   
8594   /* Otherwise, assume it's a character type iff it is a discrete type
8595      with a known character type name.  */
8596   name = ada_type_name (type);
8597   return (name != NULL
8598           && (type->code () == TYPE_CODE_INT
8599               || type->code () == TYPE_CODE_RANGE)
8600           && (strcmp (name, "character") == 0
8601               || strcmp (name, "wide_character") == 0
8602               || strcmp (name, "wide_wide_character") == 0
8603               || strcmp (name, "unsigned char") == 0));
8604 }
8605
8606 /* True if TYPE appears to be an Ada string type.  */
8607
8608 bool
8609 ada_is_string_type (struct type *type)
8610 {
8611   type = ada_check_typedef (type);
8612   if (type != NULL
8613       && type->code () != TYPE_CODE_PTR
8614       && (ada_is_simple_array_type (type)
8615           || ada_is_array_descriptor_type (type))
8616       && ada_array_arity (type) == 1)
8617     {
8618       struct type *elttype = ada_array_element_type (type, 1);
8619
8620       return ada_is_character_type (elttype);
8621     }
8622   else
8623     return false;
8624 }
8625
8626 /* The compiler sometimes provides a parallel XVS type for a given
8627    PAD type.  Normally, it is safe to follow the PAD type directly,
8628    but older versions of the compiler have a bug that causes the offset
8629    of its "F" field to be wrong.  Following that field in that case
8630    would lead to incorrect results, but this can be worked around
8631    by ignoring the PAD type and using the associated XVS type instead.
8632
8633    Set to True if the debugger should trust the contents of PAD types.
8634    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
8635 static bool trust_pad_over_xvs = true;
8636
8637 /* True if TYPE is a struct type introduced by the compiler to force the
8638    alignment of a value.  Such types have a single field with a
8639    distinctive name.  */
8640
8641 int
8642 ada_is_aligner_type (struct type *type)
8643 {
8644   type = ada_check_typedef (type);
8645
8646   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
8647     return 0;
8648
8649   return (type->code () == TYPE_CODE_STRUCT
8650           && type->num_fields () == 1
8651           && strcmp (type->field (0).name (), "F") == 0);
8652 }
8653
8654 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8655    the parallel type.  */
8656
8657 struct type *
8658 ada_get_base_type (struct type *raw_type)
8659 {
8660   struct type *real_type_namer;
8661   struct type *raw_real_type;
8662
8663   if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
8664     return raw_type;
8665
8666   if (ada_is_aligner_type (raw_type))
8667     /* The encoding specifies that we should always use the aligner type.
8668        So, even if this aligner type has an associated XVS type, we should
8669        simply ignore it.
8670
8671        According to the compiler gurus, an XVS type parallel to an aligner
8672        type may exist because of a stabs limitation.  In stabs, aligner
8673        types are empty because the field has a variable-sized type, and
8674        thus cannot actually be used as an aligner type.  As a result,
8675        we need the associated parallel XVS type to decode the type.
8676        Since the policy in the compiler is to not change the internal
8677        representation based on the debugging info format, we sometimes
8678        end up having a redundant XVS type parallel to the aligner type.  */
8679     return raw_type;
8680
8681   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
8682   if (real_type_namer == NULL
8683       || real_type_namer->code () != TYPE_CODE_STRUCT
8684       || real_type_namer->num_fields () != 1)
8685     return raw_type;
8686
8687   if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
8688     {
8689       /* This is an older encoding form where the base type needs to be
8690          looked up by name.  We prefer the newer encoding because it is
8691          more efficient.  */
8692       raw_real_type = ada_find_any_type (real_type_namer->field (0).name ());
8693       if (raw_real_type == NULL)
8694         return raw_type;
8695       else
8696         return raw_real_type;
8697     }
8698
8699   /* The field in our XVS type is a reference to the base type.  */
8700   return TYPE_TARGET_TYPE (real_type_namer->field (0).type ());
8701 }
8702
8703 /* The type of value designated by TYPE, with all aligners removed.  */
8704
8705 struct type *
8706 ada_aligned_type (struct type *type)
8707 {
8708   if (ada_is_aligner_type (type))
8709     return ada_aligned_type (type->field (0).type ());
8710   else
8711     return ada_get_base_type (type);
8712 }
8713
8714
8715 /* The address of the aligned value in an object at address VALADDR
8716    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
8717
8718 const gdb_byte *
8719 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
8720 {
8721   if (ada_is_aligner_type (type))
8722     return ada_aligned_value_addr (type->field (0).type (),
8723                                    valaddr +
8724                                    TYPE_FIELD_BITPOS (type,
8725                                                       0) / TARGET_CHAR_BIT);
8726   else
8727     return valaddr;
8728 }
8729
8730
8731
8732 /* The printed representation of an enumeration literal with encoded
8733    name NAME.  The value is good to the next call of ada_enum_name.  */
8734 const char *
8735 ada_enum_name (const char *name)
8736 {
8737   static std::string storage;
8738   const char *tmp;
8739
8740   /* First, unqualify the enumeration name:
8741      1. Search for the last '.' character.  If we find one, then skip
8742      all the preceding characters, the unqualified name starts
8743      right after that dot.
8744      2. Otherwise, we may be debugging on a target where the compiler
8745      translates dots into "__".  Search forward for double underscores,
8746      but stop searching when we hit an overloading suffix, which is
8747      of the form "__" followed by digits.  */
8748
8749   tmp = strrchr (name, '.');
8750   if (tmp != NULL)
8751     name = tmp + 1;
8752   else
8753     {
8754       while ((tmp = strstr (name, "__")) != NULL)
8755         {
8756           if (isdigit (tmp[2]))
8757             break;
8758           else
8759             name = tmp + 2;
8760         }
8761     }
8762
8763   if (name[0] == 'Q')
8764     {
8765       int v;
8766
8767       if (name[1] == 'U' || name[1] == 'W')
8768         {
8769           if (sscanf (name + 2, "%x", &v) != 1)
8770             return name;
8771         }
8772       else if (((name[1] >= '0' && name[1] <= '9')
8773                 || (name[1] >= 'a' && name[1] <= 'z'))
8774                && name[2] == '\0')
8775         {
8776           storage = string_printf ("'%c'", name[1]);
8777           return storage.c_str ();
8778         }
8779       else
8780         return name;
8781
8782       if (isascii (v) && isprint (v))
8783         storage = string_printf ("'%c'", v);
8784       else if (name[1] == 'U')
8785         storage = string_printf ("[\"%02x\"]", v);
8786       else
8787         storage = string_printf ("[\"%04x\"]", v);
8788
8789       return storage.c_str ();
8790     }
8791   else
8792     {
8793       tmp = strstr (name, "__");
8794       if (tmp == NULL)
8795         tmp = strstr (name, "$");
8796       if (tmp != NULL)
8797         {
8798           storage = std::string (name, tmp - name);
8799           return storage.c_str ();
8800         }
8801
8802       return name;
8803     }
8804 }
8805
8806 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8807    value it wraps.  */
8808
8809 static struct value *
8810 unwrap_value (struct value *val)
8811 {
8812   struct type *type = ada_check_typedef (value_type (val));
8813
8814   if (ada_is_aligner_type (type))
8815     {
8816       struct value *v = ada_value_struct_elt (val, "F", 0);
8817       struct type *val_type = ada_check_typedef (value_type (v));
8818
8819       if (ada_type_name (val_type) == NULL)
8820         val_type->set_name (ada_type_name (type));
8821
8822       return unwrap_value (v);
8823     }
8824   else
8825     {
8826       struct type *raw_real_type =
8827         ada_check_typedef (ada_get_base_type (type));
8828
8829       /* If there is no parallel XVS or XVE type, then the value is
8830          already unwrapped.  Return it without further modification.  */
8831       if ((type == raw_real_type)
8832           && ada_find_parallel_type (type, "___XVE") == NULL)
8833         return val;
8834
8835       return
8836         coerce_unspec_val_to_type
8837         (val, ada_to_fixed_type (raw_real_type, 0,
8838                                  value_address (val),
8839                                  NULL, 1));
8840     }
8841 }
8842
8843 /* Given two array types T1 and T2, return nonzero iff both arrays
8844    contain the same number of elements.  */
8845
8846 static int
8847 ada_same_array_size_p (struct type *t1, struct type *t2)
8848 {
8849   LONGEST lo1, hi1, lo2, hi2;
8850
8851   /* Get the array bounds in order to verify that the size of
8852      the two arrays match.  */
8853   if (!get_array_bounds (t1, &lo1, &hi1)
8854       || !get_array_bounds (t2, &lo2, &hi2))
8855     error (_("unable to determine array bounds"));
8856
8857   /* To make things easier for size comparison, normalize a bit
8858      the case of empty arrays by making sure that the difference
8859      between upper bound and lower bound is always -1.  */
8860   if (lo1 > hi1)
8861     hi1 = lo1 - 1;
8862   if (lo2 > hi2)
8863     hi2 = lo2 - 1;
8864
8865   return (hi1 - lo1 == hi2 - lo2);
8866 }
8867
8868 /* Assuming that VAL is an array of integrals, and TYPE represents
8869    an array with the same number of elements, but with wider integral
8870    elements, return an array "casted" to TYPE.  In practice, this
8871    means that the returned array is built by casting each element
8872    of the original array into TYPE's (wider) element type.  */
8873
8874 static struct value *
8875 ada_promote_array_of_integrals (struct type *type, struct value *val)
8876 {
8877   struct type *elt_type = TYPE_TARGET_TYPE (type);
8878   LONGEST lo, hi;
8879   struct value *res;
8880   LONGEST i;
8881
8882   /* Verify that both val and type are arrays of scalars, and
8883      that the size of val's elements is smaller than the size
8884      of type's element.  */
8885   gdb_assert (type->code () == TYPE_CODE_ARRAY);
8886   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
8887   gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
8888   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
8889   gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
8890               > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
8891
8892   if (!get_array_bounds (type, &lo, &hi))
8893     error (_("unable to determine array bounds"));
8894
8895   res = allocate_value (type);
8896
8897   /* Promote each array element.  */
8898   for (i = 0; i < hi - lo + 1; i++)
8899     {
8900       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
8901
8902       memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
8903               value_contents_all (elt), TYPE_LENGTH (elt_type));
8904     }
8905
8906   return res;
8907 }
8908
8909 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8910    return the converted value.  */
8911
8912 static struct value *
8913 coerce_for_assign (struct type *type, struct value *val)
8914 {
8915   struct type *type2 = value_type (val);
8916
8917   if (type == type2)
8918     return val;
8919
8920   type2 = ada_check_typedef (type2);
8921   type = ada_check_typedef (type);
8922
8923   if (type2->code () == TYPE_CODE_PTR
8924       && type->code () == TYPE_CODE_ARRAY)
8925     {
8926       val = ada_value_ind (val);
8927       type2 = value_type (val);
8928     }
8929
8930   if (type2->code () == TYPE_CODE_ARRAY
8931       && type->code () == TYPE_CODE_ARRAY)
8932     {
8933       if (!ada_same_array_size_p (type, type2))
8934         error (_("cannot assign arrays of different length"));
8935
8936       if (is_integral_type (TYPE_TARGET_TYPE (type))
8937           && is_integral_type (TYPE_TARGET_TYPE (type2))
8938           && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8939                < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8940         {
8941           /* Allow implicit promotion of the array elements to
8942              a wider type.  */
8943           return ada_promote_array_of_integrals (type, val);
8944         }
8945
8946       if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8947           != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8948         error (_("Incompatible types in assignment"));
8949       deprecated_set_value_type (val, type);
8950     }
8951   return val;
8952 }
8953
8954 static struct value *
8955 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
8956 {
8957   struct value *val;
8958   struct type *type1, *type2;
8959   LONGEST v, v1, v2;
8960
8961   arg1 = coerce_ref (arg1);
8962   arg2 = coerce_ref (arg2);
8963   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
8964   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
8965
8966   if (type1->code () != TYPE_CODE_INT
8967       || type2->code () != TYPE_CODE_INT)
8968     return value_binop (arg1, arg2, op);
8969
8970   switch (op)
8971     {
8972     case BINOP_MOD:
8973     case BINOP_DIV:
8974     case BINOP_REM:
8975       break;
8976     default:
8977       return value_binop (arg1, arg2, op);
8978     }
8979
8980   v2 = value_as_long (arg2);
8981   if (v2 == 0)
8982     {
8983       const char *name;
8984       if (op == BINOP_MOD)
8985         name = "mod";
8986       else if (op == BINOP_DIV)
8987         name = "/";
8988       else
8989         {
8990           gdb_assert (op == BINOP_REM);
8991           name = "rem";
8992         }
8993
8994       error (_("second operand of %s must not be zero."), name);
8995     }
8996
8997   if (type1->is_unsigned () || op == BINOP_MOD)
8998     return value_binop (arg1, arg2, op);
8999
9000   v1 = value_as_long (arg1);
9001   switch (op)
9002     {
9003     case BINOP_DIV:
9004       v = v1 / v2;
9005       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9006         v += v > 0 ? -1 : 1;
9007       break;
9008     case BINOP_REM:
9009       v = v1 % v2;
9010       if (v * v1 < 0)
9011         v -= v2;
9012       break;
9013     default:
9014       /* Should not reach this point.  */
9015       v = 0;
9016     }
9017
9018   val = allocate_value (type1);
9019   store_unsigned_integer (value_contents_raw (val),
9020                           TYPE_LENGTH (value_type (val)),
9021                           type_byte_order (type1), v);
9022   return val;
9023 }
9024
9025 static int
9026 ada_value_equal (struct value *arg1, struct value *arg2)
9027 {
9028   if (ada_is_direct_array_type (value_type (arg1))
9029       || ada_is_direct_array_type (value_type (arg2)))
9030     {
9031       struct type *arg1_type, *arg2_type;
9032
9033       /* Automatically dereference any array reference before
9034          we attempt to perform the comparison.  */
9035       arg1 = ada_coerce_ref (arg1);
9036       arg2 = ada_coerce_ref (arg2);
9037
9038       arg1 = ada_coerce_to_simple_array (arg1);
9039       arg2 = ada_coerce_to_simple_array (arg2);
9040
9041       arg1_type = ada_check_typedef (value_type (arg1));
9042       arg2_type = ada_check_typedef (value_type (arg2));
9043
9044       if (arg1_type->code () != TYPE_CODE_ARRAY
9045           || arg2_type->code () != TYPE_CODE_ARRAY)
9046         error (_("Attempt to compare array with non-array"));
9047       /* FIXME: The following works only for types whose
9048          representations use all bits (no padding or undefined bits)
9049          and do not have user-defined equality.  */
9050       return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9051               && memcmp (value_contents (arg1), value_contents (arg2),
9052                          TYPE_LENGTH (arg1_type)) == 0);
9053     }
9054   return value_equal (arg1, arg2);
9055 }
9056
9057 namespace expr
9058 {
9059
9060 bool
9061 check_objfile (const std::unique_ptr<ada_component> &comp,
9062                struct objfile *objfile)
9063 {
9064   return comp->uses_objfile (objfile);
9065 }
9066
9067 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9068    component of LHS (a simple array or a record).  Does not modify the
9069    inferior's memory, nor does it modify LHS (unless LHS ==
9070    CONTAINER).  */
9071
9072 static void
9073 assign_component (struct value *container, struct value *lhs, LONGEST index,
9074                   struct expression *exp, operation_up &arg)
9075 {
9076   scoped_value_mark mark;
9077
9078   struct value *elt;
9079   struct type *lhs_type = check_typedef (value_type (lhs));
9080
9081   if (lhs_type->code () == TYPE_CODE_ARRAY)
9082     {
9083       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9084       struct value *index_val = value_from_longest (index_type, index);
9085
9086       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9087     }
9088   else
9089     {
9090       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9091       elt = ada_to_fixed_value (elt);
9092     }
9093
9094   ada_aggregate_operation *ag_op
9095     = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9096   if (ag_op != nullptr)
9097     ag_op->assign_aggregate (container, elt, exp);
9098   else
9099     value_assign_to_component (container, elt,
9100                                arg->evaluate (nullptr, exp,
9101                                               EVAL_NORMAL));
9102 }
9103
9104 bool
9105 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9106 {
9107   for (const auto &item : m_components)
9108     if (item->uses_objfile (objfile))
9109       return true;
9110   return false;
9111 }
9112
9113 void
9114 ada_aggregate_component::dump (ui_file *stream, int depth)
9115 {
9116   fprintf_filtered (stream, _("%*sAggregate\n"), depth, "");
9117   for (const auto &item : m_components)
9118     item->dump (stream, depth + 1);
9119 }
9120
9121 void
9122 ada_aggregate_component::assign (struct value *container,
9123                                  struct value *lhs, struct expression *exp,
9124                                  std::vector<LONGEST> &indices,
9125                                  LONGEST low, LONGEST high)
9126 {
9127   for (auto &item : m_components)
9128     item->assign (container, lhs, exp, indices, low, high);
9129 }
9130
9131 /* See ada-exp.h.  */
9132
9133 value *
9134 ada_aggregate_operation::assign_aggregate (struct value *container,
9135                                            struct value *lhs,
9136                                            struct expression *exp)
9137 {
9138   struct type *lhs_type;
9139   LONGEST low_index, high_index;
9140
9141   container = ada_coerce_ref (container);
9142   if (ada_is_direct_array_type (value_type (container)))
9143     container = ada_coerce_to_simple_array (container);
9144   lhs = ada_coerce_ref (lhs);
9145   if (!deprecated_value_modifiable (lhs))
9146     error (_("Left operand of assignment is not a modifiable lvalue."));
9147
9148   lhs_type = check_typedef (value_type (lhs));
9149   if (ada_is_direct_array_type (lhs_type))
9150     {
9151       lhs = ada_coerce_to_simple_array (lhs);
9152       lhs_type = check_typedef (value_type (lhs));
9153       low_index = lhs_type->bounds ()->low.const_val ();
9154       high_index = lhs_type->bounds ()->high.const_val ();
9155     }
9156   else if (lhs_type->code () == TYPE_CODE_STRUCT)
9157     {
9158       low_index = 0;
9159       high_index = num_visible_fields (lhs_type) - 1;
9160     }
9161   else
9162     error (_("Left-hand side must be array or record."));
9163
9164   std::vector<LONGEST> indices (4);
9165   indices[0] = indices[1] = low_index - 1;
9166   indices[2] = indices[3] = high_index + 1;
9167
9168   std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9169                                    low_index, high_index);
9170
9171   return container;
9172 }
9173
9174 bool
9175 ada_positional_component::uses_objfile (struct objfile *objfile)
9176 {
9177   return m_op->uses_objfile (objfile);
9178 }
9179
9180 void
9181 ada_positional_component::dump (ui_file *stream, int depth)
9182 {
9183   fprintf_filtered (stream, _("%*sPositional, index = %d\n"),
9184                     depth, "", m_index);
9185   m_op->dump (stream, depth + 1);
9186 }
9187
9188 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9189    construct, given that the positions are relative to lower bound
9190    LOW, where HIGH is the upper bound.  Record the position in
9191    INDICES.  CONTAINER is as for assign_aggregate.  */
9192 void
9193 ada_positional_component::assign (struct value *container,
9194                                   struct value *lhs, struct expression *exp,
9195                                   std::vector<LONGEST> &indices,
9196                                   LONGEST low, LONGEST high)
9197 {
9198   LONGEST ind = m_index + low;
9199
9200   if (ind - 1 == high)
9201     warning (_("Extra components in aggregate ignored."));
9202   if (ind <= high)
9203     {
9204       add_component_interval (ind, ind, indices);
9205       assign_component (container, lhs, ind, exp, m_op);
9206     }
9207 }
9208
9209 bool
9210 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9211 {
9212   return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9213 }
9214
9215 void
9216 ada_discrete_range_association::dump (ui_file *stream, int depth)
9217 {
9218   fprintf_filtered (stream, _("%*sDiscrete range:\n"), depth, "");
9219   m_low->dump (stream, depth + 1);
9220   m_high->dump (stream, depth + 1);
9221 }
9222
9223 void
9224 ada_discrete_range_association::assign (struct value *container,
9225                                         struct value *lhs,
9226                                         struct expression *exp,
9227                                         std::vector<LONGEST> &indices,
9228                                         LONGEST low, LONGEST high,
9229                                         operation_up &op)
9230 {
9231   LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9232   LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9233
9234   if (lower <= upper && (lower < low || upper > high))
9235     error (_("Index in component association out of bounds."));
9236
9237   add_component_interval (lower, upper, indices);
9238   while (lower <= upper)
9239     {
9240       assign_component (container, lhs, lower, exp, op);
9241       lower += 1;
9242     }
9243 }
9244
9245 bool
9246 ada_name_association::uses_objfile (struct objfile *objfile)
9247 {
9248   return m_val->uses_objfile (objfile);
9249 }
9250
9251 void
9252 ada_name_association::dump (ui_file *stream, int depth)
9253 {
9254   fprintf_filtered (stream, _("%*sName:\n"), depth, "");
9255   m_val->dump (stream, depth + 1);
9256 }
9257
9258 void
9259 ada_name_association::assign (struct value *container,
9260                               struct value *lhs,
9261                               struct expression *exp,
9262                               std::vector<LONGEST> &indices,
9263                               LONGEST low, LONGEST high,
9264                               operation_up &op)
9265 {
9266   int index;
9267
9268   if (ada_is_direct_array_type (value_type (lhs)))
9269     index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9270                                                             EVAL_NORMAL)));
9271   else
9272     {
9273       ada_string_operation *strop
9274         = dynamic_cast<ada_string_operation *> (m_val.get ());
9275
9276       const char *name;
9277       if (strop != nullptr)
9278         name = strop->get_name ();
9279       else
9280         {
9281           ada_var_value_operation *vvo
9282             = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9283           if (vvo != nullptr)
9284             error (_("Invalid record component association."));
9285           name = vvo->get_symbol ()->natural_name ();
9286         }
9287
9288       index = 0;
9289       if (! find_struct_field (name, value_type (lhs), 0,
9290                                NULL, NULL, NULL, NULL, &index))
9291         error (_("Unknown component name: %s."), name);
9292     }
9293
9294   add_component_interval (index, index, indices);
9295   assign_component (container, lhs, index, exp, op);
9296 }
9297
9298 bool
9299 ada_choices_component::uses_objfile (struct objfile *objfile)
9300 {
9301   if (m_op->uses_objfile (objfile))
9302     return true;
9303   for (const auto &item : m_assocs)
9304     if (item->uses_objfile (objfile))
9305       return true;
9306   return false;
9307 }
9308
9309 void
9310 ada_choices_component::dump (ui_file *stream, int depth)
9311 {
9312   fprintf_filtered (stream, _("%*sChoices:\n"), depth, "");
9313   m_op->dump (stream, depth + 1);
9314   for (const auto &item : m_assocs)
9315     item->dump (stream, depth + 1);
9316 }
9317
9318 /* Assign into the components of LHS indexed by the OP_CHOICES
9319    construct at *POS, updating *POS past the construct, given that
9320    the allowable indices are LOW..HIGH.  Record the indices assigned
9321    to in INDICES.  CONTAINER is as for assign_aggregate.  */
9322 void
9323 ada_choices_component::assign (struct value *container,
9324                                struct value *lhs, struct expression *exp,
9325                                std::vector<LONGEST> &indices,
9326                                LONGEST low, LONGEST high)
9327 {
9328   for (auto &item : m_assocs)
9329     item->assign (container, lhs, exp, indices, low, high, m_op);
9330 }
9331
9332 bool
9333 ada_others_component::uses_objfile (struct objfile *objfile)
9334 {
9335   return m_op->uses_objfile (objfile);
9336 }
9337
9338 void
9339 ada_others_component::dump (ui_file *stream, int depth)
9340 {
9341   fprintf_filtered (stream, _("%*sOthers:\n"), depth, "");
9342   m_op->dump (stream, depth + 1);
9343 }
9344
9345 /* Assign the value of the expression in the OP_OTHERS construct in
9346    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9347    have not been previously assigned.  The index intervals already assigned
9348    are in INDICES.  CONTAINER is as for assign_aggregate.  */
9349 void
9350 ada_others_component::assign (struct value *container,
9351                               struct value *lhs, struct expression *exp,
9352                               std::vector<LONGEST> &indices,
9353                               LONGEST low, LONGEST high)
9354 {
9355   int num_indices = indices.size ();
9356   for (int i = 0; i < num_indices - 2; i += 2)
9357     {
9358       for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9359         assign_component (container, lhs, ind, exp, m_op);
9360     }
9361 }
9362
9363 struct value *
9364 ada_assign_operation::evaluate (struct type *expect_type,
9365                                 struct expression *exp,
9366                                 enum noside noside)
9367 {
9368   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9369
9370   ada_aggregate_operation *ag_op
9371     = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9372   if (ag_op != nullptr)
9373     {
9374       if (noside != EVAL_NORMAL)
9375         return arg1;
9376
9377       arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9378       return ada_value_assign (arg1, arg1);
9379     }
9380   /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9381      except if the lhs of our assignment is a convenience variable.
9382      In the case of assigning to a convenience variable, the lhs
9383      should be exactly the result of the evaluation of the rhs.  */
9384   struct type *type = value_type (arg1);
9385   if (VALUE_LVAL (arg1) == lval_internalvar)
9386     type = NULL;
9387   value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9388   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9389     return arg1;
9390   if (VALUE_LVAL (arg1) == lval_internalvar)
9391     {
9392       /* Nothing.  */
9393     }
9394   else
9395     arg2 = coerce_for_assign (value_type (arg1), arg2);
9396   return ada_value_assign (arg1, arg2);
9397 }
9398
9399 } /* namespace expr */
9400
9401 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9402    [ INDICES[0] .. INDICES[1] ],...  The resulting intervals do not
9403    overlap.  */
9404 static void
9405 add_component_interval (LONGEST low, LONGEST high, 
9406                         std::vector<LONGEST> &indices)
9407 {
9408   int i, j;
9409
9410   int size = indices.size ();
9411   for (i = 0; i < size; i += 2) {
9412     if (high >= indices[i] && low <= indices[i + 1])
9413       {
9414         int kh;
9415
9416         for (kh = i + 2; kh < size; kh += 2)
9417           if (high < indices[kh])
9418             break;
9419         if (low < indices[i])
9420           indices[i] = low;
9421         indices[i + 1] = indices[kh - 1];
9422         if (high > indices[i + 1])
9423           indices[i + 1] = high;
9424         memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9425         indices.resize (kh - i - 2);
9426         return;
9427       }
9428     else if (high < indices[i])
9429       break;
9430   }
9431         
9432   indices.resize (indices.size () + 2);
9433   for (j = indices.size () - 1; j >= i + 2; j -= 1)
9434     indices[j] = indices[j - 2];
9435   indices[i] = low;
9436   indices[i + 1] = high;
9437 }
9438
9439 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9440    is different.  */
9441
9442 static struct value *
9443 ada_value_cast (struct type *type, struct value *arg2)
9444 {
9445   if (type == ada_check_typedef (value_type (arg2)))
9446     return arg2;
9447
9448   return value_cast (type, arg2);
9449 }
9450
9451 /*  Evaluating Ada expressions, and printing their result.
9452     ------------------------------------------------------
9453
9454     1. Introduction:
9455     ----------------
9456
9457     We usually evaluate an Ada expression in order to print its value.
9458     We also evaluate an expression in order to print its type, which
9459     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9460     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
9461     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9462     the evaluation compared to the EVAL_NORMAL, but is otherwise very
9463     similar.
9464
9465     Evaluating expressions is a little more complicated for Ada entities
9466     than it is for entities in languages such as C.  The main reason for
9467     this is that Ada provides types whose definition might be dynamic.
9468     One example of such types is variant records.  Or another example
9469     would be an array whose bounds can only be known at run time.
9470
9471     The following description is a general guide as to what should be
9472     done (and what should NOT be done) in order to evaluate an expression
9473     involving such types, and when.  This does not cover how the semantic
9474     information is encoded by GNAT as this is covered separatly.  For the
9475     document used as the reference for the GNAT encoding, see exp_dbug.ads
9476     in the GNAT sources.
9477
9478     Ideally, we should embed each part of this description next to its
9479     associated code.  Unfortunately, the amount of code is so vast right
9480     now that it's hard to see whether the code handling a particular
9481     situation might be duplicated or not.  One day, when the code is
9482     cleaned up, this guide might become redundant with the comments
9483     inserted in the code, and we might want to remove it.
9484
9485     2. ``Fixing'' an Entity, the Simple Case:
9486     -----------------------------------------
9487
9488     When evaluating Ada expressions, the tricky issue is that they may
9489     reference entities whose type contents and size are not statically
9490     known.  Consider for instance a variant record:
9491
9492        type Rec (Empty : Boolean := True) is record
9493           case Empty is
9494              when True => null;
9495              when False => Value : Integer;
9496           end case;
9497        end record;
9498        Yes : Rec := (Empty => False, Value => 1);
9499        No  : Rec := (empty => True);
9500
9501     The size and contents of that record depends on the value of the
9502     descriminant (Rec.Empty).  At this point, neither the debugging
9503     information nor the associated type structure in GDB are able to
9504     express such dynamic types.  So what the debugger does is to create
9505     "fixed" versions of the type that applies to the specific object.
9506     We also informally refer to this operation as "fixing" an object,
9507     which means creating its associated fixed type.
9508
9509     Example: when printing the value of variable "Yes" above, its fixed
9510     type would look like this:
9511
9512        type Rec is record
9513           Empty : Boolean;
9514           Value : Integer;
9515        end record;
9516
9517     On the other hand, if we printed the value of "No", its fixed type
9518     would become:
9519
9520        type Rec is record
9521           Empty : Boolean;
9522        end record;
9523
9524     Things become a little more complicated when trying to fix an entity
9525     with a dynamic type that directly contains another dynamic type,
9526     such as an array of variant records, for instance.  There are
9527     two possible cases: Arrays, and records.
9528
9529     3. ``Fixing'' Arrays:
9530     ---------------------
9531
9532     The type structure in GDB describes an array in terms of its bounds,
9533     and the type of its elements.  By design, all elements in the array
9534     have the same type and we cannot represent an array of variant elements
9535     using the current type structure in GDB.  When fixing an array,
9536     we cannot fix the array element, as we would potentially need one
9537     fixed type per element of the array.  As a result, the best we can do
9538     when fixing an array is to produce an array whose bounds and size
9539     are correct (allowing us to read it from memory), but without having
9540     touched its element type.  Fixing each element will be done later,
9541     when (if) necessary.
9542
9543     Arrays are a little simpler to handle than records, because the same
9544     amount of memory is allocated for each element of the array, even if
9545     the amount of space actually used by each element differs from element
9546     to element.  Consider for instance the following array of type Rec:
9547
9548        type Rec_Array is array (1 .. 2) of Rec;
9549
9550     The actual amount of memory occupied by each element might be different
9551     from element to element, depending on the value of their discriminant.
9552     But the amount of space reserved for each element in the array remains
9553     fixed regardless.  So we simply need to compute that size using
9554     the debugging information available, from which we can then determine
9555     the array size (we multiply the number of elements of the array by
9556     the size of each element).
9557
9558     The simplest case is when we have an array of a constrained element
9559     type. For instance, consider the following type declarations:
9560
9561         type Bounded_String (Max_Size : Integer) is
9562            Length : Integer;
9563            Buffer : String (1 .. Max_Size);
9564         end record;
9565         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9566
9567     In this case, the compiler describes the array as an array of
9568     variable-size elements (identified by its XVS suffix) for which
9569     the size can be read in the parallel XVZ variable.
9570
9571     In the case of an array of an unconstrained element type, the compiler
9572     wraps the array element inside a private PAD type.  This type should not
9573     be shown to the user, and must be "unwrap"'ed before printing.  Note
9574     that we also use the adjective "aligner" in our code to designate
9575     these wrapper types.
9576
9577     In some cases, the size allocated for each element is statically
9578     known.  In that case, the PAD type already has the correct size,
9579     and the array element should remain unfixed.
9580
9581     But there are cases when this size is not statically known.
9582     For instance, assuming that "Five" is an integer variable:
9583
9584         type Dynamic is array (1 .. Five) of Integer;
9585         type Wrapper (Has_Length : Boolean := False) is record
9586            Data : Dynamic;
9587            case Has_Length is
9588               when True => Length : Integer;
9589               when False => null;
9590            end case;
9591         end record;
9592         type Wrapper_Array is array (1 .. 2) of Wrapper;
9593
9594         Hello : Wrapper_Array := (others => (Has_Length => True,
9595                                              Data => (others => 17),
9596                                              Length => 1));
9597
9598
9599     The debugging info would describe variable Hello as being an
9600     array of a PAD type.  The size of that PAD type is not statically
9601     known, but can be determined using a parallel XVZ variable.
9602     In that case, a copy of the PAD type with the correct size should
9603     be used for the fixed array.
9604
9605     3. ``Fixing'' record type objects:
9606     ----------------------------------
9607
9608     Things are slightly different from arrays in the case of dynamic
9609     record types.  In this case, in order to compute the associated
9610     fixed type, we need to determine the size and offset of each of
9611     its components.  This, in turn, requires us to compute the fixed
9612     type of each of these components.
9613
9614     Consider for instance the example:
9615
9616         type Bounded_String (Max_Size : Natural) is record
9617            Str : String (1 .. Max_Size);
9618            Length : Natural;
9619         end record;
9620         My_String : Bounded_String (Max_Size => 10);
9621
9622     In that case, the position of field "Length" depends on the size
9623     of field Str, which itself depends on the value of the Max_Size
9624     discriminant.  In order to fix the type of variable My_String,
9625     we need to fix the type of field Str.  Therefore, fixing a variant
9626     record requires us to fix each of its components.
9627
9628     However, if a component does not have a dynamic size, the component
9629     should not be fixed.  In particular, fields that use a PAD type
9630     should not fixed.  Here is an example where this might happen
9631     (assuming type Rec above):
9632
9633        type Container (Big : Boolean) is record
9634           First : Rec;
9635           After : Integer;
9636           case Big is
9637              when True => Another : Integer;
9638              when False => null;
9639           end case;
9640        end record;
9641        My_Container : Container := (Big => False,
9642                                     First => (Empty => True),
9643                                     After => 42);
9644
9645     In that example, the compiler creates a PAD type for component First,
9646     whose size is constant, and then positions the component After just
9647     right after it.  The offset of component After is therefore constant
9648     in this case.
9649
9650     The debugger computes the position of each field based on an algorithm
9651     that uses, among other things, the actual position and size of the field
9652     preceding it.  Let's now imagine that the user is trying to print
9653     the value of My_Container.  If the type fixing was recursive, we would
9654     end up computing the offset of field After based on the size of the
9655     fixed version of field First.  And since in our example First has
9656     only one actual field, the size of the fixed type is actually smaller
9657     than the amount of space allocated to that field, and thus we would
9658     compute the wrong offset of field After.
9659
9660     To make things more complicated, we need to watch out for dynamic
9661     components of variant records (identified by the ___XVL suffix in
9662     the component name).  Even if the target type is a PAD type, the size
9663     of that type might not be statically known.  So the PAD type needs
9664     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
9665     we might end up with the wrong size for our component.  This can be
9666     observed with the following type declarations:
9667
9668         type Octal is new Integer range 0 .. 7;
9669         type Octal_Array is array (Positive range <>) of Octal;
9670         pragma Pack (Octal_Array);
9671
9672         type Octal_Buffer (Size : Positive) is record
9673            Buffer : Octal_Array (1 .. Size);
9674            Length : Integer;
9675         end record;
9676
9677     In that case, Buffer is a PAD type whose size is unset and needs
9678     to be computed by fixing the unwrapped type.
9679
9680     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9681     ----------------------------------------------------------
9682
9683     Lastly, when should the sub-elements of an entity that remained unfixed
9684     thus far, be actually fixed?
9685
9686     The answer is: Only when referencing that element.  For instance
9687     when selecting one component of a record, this specific component
9688     should be fixed at that point in time.  Or when printing the value
9689     of a record, each component should be fixed before its value gets
9690     printed.  Similarly for arrays, the element of the array should be
9691     fixed when printing each element of the array, or when extracting
9692     one element out of that array.  On the other hand, fixing should
9693     not be performed on the elements when taking a slice of an array!
9694
9695     Note that one of the side effects of miscomputing the offset and
9696     size of each field is that we end up also miscomputing the size
9697     of the containing type.  This can have adverse results when computing
9698     the value of an entity.  GDB fetches the value of an entity based
9699     on the size of its type, and thus a wrong size causes GDB to fetch
9700     the wrong amount of memory.  In the case where the computed size is
9701     too small, GDB fetches too little data to print the value of our
9702     entity.  Results in this case are unpredictable, as we usually read
9703     past the buffer containing the data =:-o.  */
9704
9705 /* A helper function for TERNOP_IN_RANGE.  */
9706
9707 static value *
9708 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
9709                       enum noside noside,
9710                       value *arg1, value *arg2, value *arg3)
9711 {
9712   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9713   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9714   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
9715   return
9716     value_from_longest (type,
9717                         (value_less (arg1, arg3)
9718                          || value_equal (arg1, arg3))
9719                         && (value_less (arg2, arg1)
9720                             || value_equal (arg2, arg1)));
9721 }
9722
9723 /* A helper function for UNOP_NEG.  */
9724
9725 value *
9726 ada_unop_neg (struct type *expect_type,
9727               struct expression *exp,
9728               enum noside noside, enum exp_opcode op,
9729               struct value *arg1)
9730 {
9731   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9732   return value_neg (arg1);
9733 }
9734
9735 /* A helper function for UNOP_IN_RANGE.  */
9736
9737 value *
9738 ada_unop_in_range (struct type *expect_type,
9739                    struct expression *exp,
9740                    enum noside noside, enum exp_opcode op,
9741                    struct value *arg1, struct type *type)
9742 {
9743   struct value *arg2, *arg3;
9744   switch (type->code ())
9745     {
9746     default:
9747       lim_warning (_("Membership test incompletely implemented; "
9748                      "always returns true"));
9749       type = language_bool_type (exp->language_defn, exp->gdbarch);
9750       return value_from_longest (type, (LONGEST) 1);
9751
9752     case TYPE_CODE_RANGE:
9753       arg2 = value_from_longest (type,
9754                                  type->bounds ()->low.const_val ());
9755       arg3 = value_from_longest (type,
9756                                  type->bounds ()->high.const_val ());
9757       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9758       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9759       type = language_bool_type (exp->language_defn, exp->gdbarch);
9760       return
9761         value_from_longest (type,
9762                             (value_less (arg1, arg3)
9763                              || value_equal (arg1, arg3))
9764                             && (value_less (arg2, arg1)
9765                                 || value_equal (arg2, arg1)));
9766     }
9767 }
9768
9769 /* A helper function for OP_ATR_TAG.  */
9770
9771 value *
9772 ada_atr_tag (struct type *expect_type,
9773              struct expression *exp,
9774              enum noside noside, enum exp_opcode op,
9775              struct value *arg1)
9776 {
9777   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9778     return value_zero (ada_tag_type (arg1), not_lval);
9779
9780   return ada_value_tag (arg1);
9781 }
9782
9783 /* A helper function for OP_ATR_SIZE.  */
9784
9785 value *
9786 ada_atr_size (struct type *expect_type,
9787               struct expression *exp,
9788               enum noside noside, enum exp_opcode op,
9789               struct value *arg1)
9790 {
9791   struct type *type = value_type (arg1);
9792
9793   /* If the argument is a reference, then dereference its type, since
9794      the user is really asking for the size of the actual object,
9795      not the size of the pointer.  */
9796   if (type->code () == TYPE_CODE_REF)
9797     type = TYPE_TARGET_TYPE (type);
9798
9799   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9800     return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
9801   else
9802     return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
9803                                TARGET_CHAR_BIT * TYPE_LENGTH (type));
9804 }
9805
9806 /* A helper function for UNOP_ABS.  */
9807
9808 value *
9809 ada_abs (struct type *expect_type,
9810          struct expression *exp,
9811          enum noside noside, enum exp_opcode op,
9812          struct value *arg1)
9813 {
9814   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9815   if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
9816     return value_neg (arg1);
9817   else
9818     return arg1;
9819 }
9820
9821 /* A helper function for BINOP_MUL.  */
9822
9823 value *
9824 ada_mult_binop (struct type *expect_type,
9825                 struct expression *exp,
9826                 enum noside noside, enum exp_opcode op,
9827                 struct value *arg1, struct value *arg2)
9828 {
9829   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9830     {
9831       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9832       return value_zero (value_type (arg1), not_lval);
9833     }
9834   else
9835     {
9836       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9837       return ada_value_binop (arg1, arg2, op);
9838     }
9839 }
9840
9841 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL.  */
9842
9843 value *
9844 ada_equal_binop (struct type *expect_type,
9845                  struct expression *exp,
9846                  enum noside noside, enum exp_opcode op,
9847                  struct value *arg1, struct value *arg2)
9848 {
9849   int tem;
9850   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9851     tem = 0;
9852   else
9853     {
9854       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9855       tem = ada_value_equal (arg1, arg2);
9856     }
9857   if (op == BINOP_NOTEQUAL)
9858     tem = !tem;
9859   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
9860   return value_from_longest (type, (LONGEST) tem);
9861 }
9862
9863 /* A helper function for TERNOP_SLICE.  */
9864
9865 value *
9866 ada_ternop_slice (struct expression *exp,
9867                   enum noside noside,
9868                   struct value *array, struct value *low_bound_val,
9869                   struct value *high_bound_val)
9870 {
9871   LONGEST low_bound;
9872   LONGEST high_bound;
9873
9874   low_bound_val = coerce_ref (low_bound_val);
9875   high_bound_val = coerce_ref (high_bound_val);
9876   low_bound = value_as_long (low_bound_val);
9877   high_bound = value_as_long (high_bound_val);
9878
9879   /* If this is a reference to an aligner type, then remove all
9880      the aligners.  */
9881   if (value_type (array)->code () == TYPE_CODE_REF
9882       && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
9883     TYPE_TARGET_TYPE (value_type (array)) =
9884       ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
9885
9886   if (ada_is_any_packed_array_type (value_type (array)))
9887     error (_("cannot slice a packed array"));
9888
9889   /* If this is a reference to an array or an array lvalue,
9890      convert to a pointer.  */
9891   if (value_type (array)->code () == TYPE_CODE_REF
9892       || (value_type (array)->code () == TYPE_CODE_ARRAY
9893           && VALUE_LVAL (array) == lval_memory))
9894     array = value_addr (array);
9895
9896   if (noside == EVAL_AVOID_SIDE_EFFECTS
9897       && ada_is_array_descriptor_type (ada_check_typedef
9898                                        (value_type (array))))
9899     return empty_array (ada_type_of_array (array, 0), low_bound,
9900                         high_bound);
9901
9902   array = ada_coerce_to_simple_array_ptr (array);
9903
9904   /* If we have more than one level of pointer indirection,
9905      dereference the value until we get only one level.  */
9906   while (value_type (array)->code () == TYPE_CODE_PTR
9907          && (TYPE_TARGET_TYPE (value_type (array))->code ()
9908              == TYPE_CODE_PTR))
9909     array = value_ind (array);
9910
9911   /* Make sure we really do have an array type before going further,
9912      to avoid a SEGV when trying to get the index type or the target
9913      type later down the road if the debug info generated by
9914      the compiler is incorrect or incomplete.  */
9915   if (!ada_is_simple_array_type (value_type (array)))
9916     error (_("cannot take slice of non-array"));
9917
9918   if (ada_check_typedef (value_type (array))->code ()
9919       == TYPE_CODE_PTR)
9920     {
9921       struct type *type0 = ada_check_typedef (value_type (array));
9922
9923       if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
9924         return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
9925       else
9926         {
9927           struct type *arr_type0 =
9928             to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
9929
9930           return ada_value_slice_from_ptr (array, arr_type0,
9931                                            longest_to_int (low_bound),
9932                                            longest_to_int (high_bound));
9933         }
9934     }
9935   else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9936     return array;
9937   else if (high_bound < low_bound)
9938     return empty_array (value_type (array), low_bound, high_bound);
9939   else
9940     return ada_value_slice (array, longest_to_int (low_bound),
9941                             longest_to_int (high_bound));
9942 }
9943
9944 /* A helper function for BINOP_IN_BOUNDS.  */
9945
9946 value *
9947 ada_binop_in_bounds (struct expression *exp, enum noside noside,
9948                      struct value *arg1, struct value *arg2, int n)
9949 {
9950   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9951     {
9952       struct type *type = language_bool_type (exp->language_defn,
9953                                               exp->gdbarch);
9954       return value_zero (type, not_lval);
9955     }
9956
9957   struct type *type = ada_index_type (value_type (arg2), n, "range");
9958   if (!type)
9959     type = value_type (arg1);
9960
9961   value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
9962   arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
9963
9964   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9965   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9966   type = language_bool_type (exp->language_defn, exp->gdbarch);
9967   return value_from_longest (type,
9968                              (value_less (arg1, arg3)
9969                               || value_equal (arg1, arg3))
9970                              && (value_less (arg2, arg1)
9971                                  || value_equal (arg2, arg1)));
9972 }
9973
9974 /* A helper function for some attribute operations.  */
9975
9976 static value *
9977 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
9978               struct value *arg1, struct type *type_arg, int tem)
9979 {
9980   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9981     {
9982       if (type_arg == NULL)
9983         type_arg = value_type (arg1);
9984
9985       if (ada_is_constrained_packed_array_type (type_arg))
9986         type_arg = decode_constrained_packed_array_type (type_arg);
9987
9988       if (!discrete_type_p (type_arg))
9989         {
9990           switch (op)
9991             {
9992             default:          /* Should never happen.  */
9993               error (_("unexpected attribute encountered"));
9994             case OP_ATR_FIRST:
9995             case OP_ATR_LAST:
9996               type_arg = ada_index_type (type_arg, tem,
9997                                          ada_attribute_name (op));
9998               break;
9999             case OP_ATR_LENGTH:
10000               type_arg = builtin_type (exp->gdbarch)->builtin_int;
10001               break;
10002             }
10003         }
10004
10005       return value_zero (type_arg, not_lval);
10006     }
10007   else if (type_arg == NULL)
10008     {
10009       arg1 = ada_coerce_ref (arg1);
10010
10011       if (ada_is_constrained_packed_array_type (value_type (arg1)))
10012         arg1 = ada_coerce_to_simple_array (arg1);
10013
10014       struct type *type;
10015       if (op == OP_ATR_LENGTH)
10016         type = builtin_type (exp->gdbarch)->builtin_int;
10017       else
10018         {
10019           type = ada_index_type (value_type (arg1), tem,
10020                                  ada_attribute_name (op));
10021           if (type == NULL)
10022             type = builtin_type (exp->gdbarch)->builtin_int;
10023         }
10024
10025       switch (op)
10026         {
10027         default:          /* Should never happen.  */
10028           error (_("unexpected attribute encountered"));
10029         case OP_ATR_FIRST:
10030           return value_from_longest
10031             (type, ada_array_bound (arg1, tem, 0));
10032         case OP_ATR_LAST:
10033           return value_from_longest
10034             (type, ada_array_bound (arg1, tem, 1));
10035         case OP_ATR_LENGTH:
10036           return value_from_longest
10037             (type, ada_array_length (arg1, tem));
10038         }
10039     }
10040   else if (discrete_type_p (type_arg))
10041     {
10042       struct type *range_type;
10043       const char *name = ada_type_name (type_arg);
10044
10045       range_type = NULL;
10046       if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10047         range_type = to_fixed_range_type (type_arg, NULL);
10048       if (range_type == NULL)
10049         range_type = type_arg;
10050       switch (op)
10051         {
10052         default:
10053           error (_("unexpected attribute encountered"));
10054         case OP_ATR_FIRST:
10055           return value_from_longest 
10056             (range_type, ada_discrete_type_low_bound (range_type));
10057         case OP_ATR_LAST:
10058           return value_from_longest
10059             (range_type, ada_discrete_type_high_bound (range_type));
10060         case OP_ATR_LENGTH:
10061           error (_("the 'length attribute applies only to array types"));
10062         }
10063     }
10064   else if (type_arg->code () == TYPE_CODE_FLT)
10065     error (_("unimplemented type attribute"));
10066   else
10067     {
10068       LONGEST low, high;
10069
10070       if (ada_is_constrained_packed_array_type (type_arg))
10071         type_arg = decode_constrained_packed_array_type (type_arg);
10072
10073       struct type *type;
10074       if (op == OP_ATR_LENGTH)
10075         type = builtin_type (exp->gdbarch)->builtin_int;
10076       else
10077         {
10078           type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10079           if (type == NULL)
10080             type = builtin_type (exp->gdbarch)->builtin_int;
10081         }
10082
10083       switch (op)
10084         {
10085         default:
10086           error (_("unexpected attribute encountered"));
10087         case OP_ATR_FIRST:
10088           low = ada_array_bound_from_type (type_arg, tem, 0);
10089           return value_from_longest (type, low);
10090         case OP_ATR_LAST:
10091           high = ada_array_bound_from_type (type_arg, tem, 1);
10092           return value_from_longest (type, high);
10093         case OP_ATR_LENGTH:
10094           low = ada_array_bound_from_type (type_arg, tem, 0);
10095           high = ada_array_bound_from_type (type_arg, tem, 1);
10096           return value_from_longest (type, high - low + 1);
10097         }
10098     }
10099 }
10100
10101 /* A helper function for OP_ATR_MIN and OP_ATR_MAX.  */
10102
10103 struct value *
10104 ada_binop_minmax (struct type *expect_type,
10105                   struct expression *exp,
10106                   enum noside noside, enum exp_opcode op,
10107                   struct value *arg1, struct value *arg2)
10108 {
10109   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10110     return value_zero (value_type (arg1), not_lval);
10111   else
10112     {
10113       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10114       return value_binop (arg1, arg2, op);
10115     }
10116 }
10117
10118 /* A helper function for BINOP_EXP.  */
10119
10120 struct value *
10121 ada_binop_exp (struct type *expect_type,
10122                struct expression *exp,
10123                enum noside noside, enum exp_opcode op,
10124                struct value *arg1, struct value *arg2)
10125 {
10126   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10127     return value_zero (value_type (arg1), not_lval);
10128   else
10129     {
10130       /* For integer exponentiation operations,
10131          only promote the first argument.  */
10132       if (is_integral_type (value_type (arg2)))
10133         unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10134       else
10135         binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10136
10137       return value_binop (arg1, arg2, op);
10138     }
10139 }
10140
10141 namespace expr
10142 {
10143
10144 /* See ada-exp.h.  */
10145
10146 operation_up
10147 ada_resolvable::replace (operation_up &&owner,
10148                          struct expression *exp,
10149                          bool deprocedure_p,
10150                          bool parse_completion,
10151                          innermost_block_tracker *tracker,
10152                          struct type *context_type)
10153 {
10154   if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10155     return (make_operation<ada_funcall_operation>
10156             (std::move (owner),
10157              std::vector<operation_up> ()));
10158   return std::move (owner);
10159 }
10160
10161 /* Convert the character literal whose ASCII value would be VAL to the
10162    appropriate value of type TYPE, if there is a translation.
10163    Otherwise return VAL.  Hence, in an enumeration type ('A', 'B'),
10164    the literal 'A' (VAL == 65), returns 0.  */
10165
10166 static LONGEST
10167 convert_char_literal (struct type *type, LONGEST val)
10168 {
10169   char name[7];
10170   int f;
10171
10172   if (type == NULL)
10173     return val;
10174   type = check_typedef (type);
10175   if (type->code () != TYPE_CODE_ENUM)
10176     return val;
10177
10178   if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10179     xsnprintf (name, sizeof (name), "Q%c", (int) val);
10180   else
10181     xsnprintf (name, sizeof (name), "QU%02x", (int) val);
10182   size_t len = strlen (name);
10183   for (f = 0; f < type->num_fields (); f += 1)
10184     {
10185       /* Check the suffix because an enum constant in a package will
10186          have a name like "pkg__QUxx".  This is safe enough because we
10187          already have the correct type, and because mangling means
10188          there can't be clashes.  */
10189       const char *ename = type->field (f).name ();
10190       size_t elen = strlen (ename);
10191
10192       if (elen >= len && strcmp (name, ename + elen - len) == 0)
10193         return TYPE_FIELD_ENUMVAL (type, f);
10194     }
10195   return val;
10196 }
10197
10198 /* See ada-exp.h.  */
10199
10200 operation_up
10201 ada_char_operation::replace (operation_up &&owner,
10202                              struct expression *exp,
10203                              bool deprocedure_p,
10204                              bool parse_completion,
10205                              innermost_block_tracker *tracker,
10206                              struct type *context_type)
10207 {
10208   operation_up result = std::move (owner);
10209
10210   if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10211     {
10212       gdb_assert (result.get () == this);
10213       std::get<0> (m_storage) = context_type;
10214       std::get<1> (m_storage)
10215         = convert_char_literal (context_type, std::get<1> (m_storage));
10216     }
10217
10218   return make_operation<ada_wrapped_operation> (std::move (result));
10219 }
10220
10221 value *
10222 ada_wrapped_operation::evaluate (struct type *expect_type,
10223                                  struct expression *exp,
10224                                  enum noside noside)
10225 {
10226   value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10227   if (noside == EVAL_NORMAL)
10228     result = unwrap_value (result);
10229
10230   /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10231      then we need to perform the conversion manually, because
10232      evaluate_subexp_standard doesn't do it.  This conversion is
10233      necessary in Ada because the different kinds of float/fixed
10234      types in Ada have different representations.
10235
10236      Similarly, we need to perform the conversion from OP_LONG
10237      ourselves.  */
10238   if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10239     result = ada_value_cast (expect_type, result);
10240
10241   return result;
10242 }
10243
10244 value *
10245 ada_string_operation::evaluate (struct type *expect_type,
10246                                 struct expression *exp,
10247                                 enum noside noside)
10248 {
10249   value *result = string_operation::evaluate (expect_type, exp, noside);
10250   /* The result type will have code OP_STRING, bashed there from 
10251      OP_ARRAY.  Bash it back.  */
10252   if (value_type (result)->code () == TYPE_CODE_STRING)
10253     value_type (result)->set_code (TYPE_CODE_ARRAY);
10254   return result;
10255 }
10256
10257 value *
10258 ada_qual_operation::evaluate (struct type *expect_type,
10259                               struct expression *exp,
10260                               enum noside noside)
10261 {
10262   struct type *type = std::get<1> (m_storage);
10263   return std::get<0> (m_storage)->evaluate (type, exp, noside);
10264 }
10265
10266 value *
10267 ada_ternop_range_operation::evaluate (struct type *expect_type,
10268                                       struct expression *exp,
10269                                       enum noside noside)
10270 {
10271   value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10272   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10273   value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10274   return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10275 }
10276
10277 value *
10278 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10279                                       struct expression *exp,
10280                                       enum noside noside)
10281 {
10282   value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10283   value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10284
10285   auto do_op = [=] (LONGEST x, LONGEST y)
10286     {
10287       if (std::get<0> (m_storage) == BINOP_ADD)
10288         return x + y;
10289       return x - y;
10290     };
10291
10292   if (value_type (arg1)->code () == TYPE_CODE_PTR)
10293     return (value_from_longest
10294             (value_type (arg1),
10295              do_op (value_as_long (arg1), value_as_long (arg2))));
10296   if (value_type (arg2)->code () == TYPE_CODE_PTR)
10297     return (value_from_longest
10298             (value_type (arg2),
10299              do_op (value_as_long (arg1), value_as_long (arg2))));
10300   /* Preserve the original type for use by the range case below.
10301      We cannot cast the result to a reference type, so if ARG1 is
10302      a reference type, find its underlying type.  */
10303   struct type *type = value_type (arg1);
10304   while (type->code () == TYPE_CODE_REF)
10305     type = TYPE_TARGET_TYPE (type);
10306   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10307   arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10308   /* We need to special-case the result with a range.
10309      This is done for the benefit of "ptype".  gdb's Ada support
10310      historically used the LHS to set the result type here, so
10311      preserve this behavior.  */
10312   if (type->code () == TYPE_CODE_RANGE)
10313     arg1 = value_cast (type, arg1);
10314   return arg1;
10315 }
10316
10317 value *
10318 ada_unop_atr_operation::evaluate (struct type *expect_type,
10319                                   struct expression *exp,
10320                                   enum noside noside)
10321 {
10322   struct type *type_arg = nullptr;
10323   value *val = nullptr;
10324
10325   if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10326     {
10327       value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10328                                                       EVAL_AVOID_SIDE_EFFECTS);
10329       type_arg = value_type (tem);
10330     }
10331   else
10332     val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10333
10334   return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10335                        val, type_arg, std::get<2> (m_storage));
10336 }
10337
10338 value *
10339 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10340                                                  struct expression *exp,
10341                                                  enum noside noside)
10342 {
10343   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10344     return value_zero (expect_type, not_lval);
10345
10346   const bound_minimal_symbol &b = std::get<0> (m_storage);
10347   value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10348
10349   val = ada_value_cast (expect_type, val);
10350
10351   /* Follow the Ada language semantics that do not allow taking
10352      an address of the result of a cast (view conversion in Ada).  */
10353   if (VALUE_LVAL (val) == lval_memory)
10354     {
10355       if (value_lazy (val))
10356         value_fetch_lazy (val);
10357       VALUE_LVAL (val) = not_lval;
10358     }
10359   return val;
10360 }
10361
10362 value *
10363 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10364                                             struct expression *exp,
10365                                             enum noside noside)
10366 {
10367   value *val = evaluate_var_value (noside,
10368                                    std::get<0> (m_storage).block,
10369                                    std::get<0> (m_storage).symbol);
10370
10371   val = ada_value_cast (expect_type, val);
10372
10373   /* Follow the Ada language semantics that do not allow taking
10374      an address of the result of a cast (view conversion in Ada).  */
10375   if (VALUE_LVAL (val) == lval_memory)
10376     {
10377       if (value_lazy (val))
10378         value_fetch_lazy (val);
10379       VALUE_LVAL (val) = not_lval;
10380     }
10381   return val;
10382 }
10383
10384 value *
10385 ada_var_value_operation::evaluate (struct type *expect_type,
10386                                    struct expression *exp,
10387                                    enum noside noside)
10388 {
10389   symbol *sym = std::get<0> (m_storage).symbol;
10390
10391   if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
10392     /* Only encountered when an unresolved symbol occurs in a
10393        context other than a function call, in which case, it is
10394        invalid.  */
10395     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10396            sym->print_name ());
10397
10398   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10399     {
10400       struct type *type = static_unwrap_type (SYMBOL_TYPE (sym));
10401       /* Check to see if this is a tagged type.  We also need to handle
10402          the case where the type is a reference to a tagged type, but
10403          we have to be careful to exclude pointers to tagged types.
10404          The latter should be shown as usual (as a pointer), whereas
10405          a reference should mostly be transparent to the user.  */
10406       if (ada_is_tagged_type (type, 0)
10407           || (type->code () == TYPE_CODE_REF
10408               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10409         {
10410           /* Tagged types are a little special in the fact that the real
10411              type is dynamic and can only be determined by inspecting the
10412              object's tag.  This means that we need to get the object's
10413              value first (EVAL_NORMAL) and then extract the actual object
10414              type from its tag.
10415
10416              Note that we cannot skip the final step where we extract
10417              the object type from its tag, because the EVAL_NORMAL phase
10418              results in dynamic components being resolved into fixed ones.
10419              This can cause problems when trying to print the type
10420              description of tagged types whose parent has a dynamic size:
10421              We use the type name of the "_parent" component in order
10422              to print the name of the ancestor type in the type description.
10423              If that component had a dynamic size, the resolution into
10424              a fixed type would result in the loss of that type name,
10425              thus preventing us from printing the name of the ancestor
10426              type in the type description.  */
10427           value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10428
10429           if (type->code () != TYPE_CODE_REF)
10430             {
10431               struct type *actual_type;
10432
10433               actual_type = type_from_tag (ada_value_tag (arg1));
10434               if (actual_type == NULL)
10435                 /* If, for some reason, we were unable to determine
10436                    the actual type from the tag, then use the static
10437                    approximation that we just computed as a fallback.
10438                    This can happen if the debugging information is
10439                    incomplete, for instance.  */
10440                 actual_type = type;
10441               return value_zero (actual_type, not_lval);
10442             }
10443           else
10444             {
10445               /* In the case of a ref, ada_coerce_ref takes care
10446                  of determining the actual type.  But the evaluation
10447                  should return a ref as it should be valid to ask
10448                  for its address; so rebuild a ref after coerce.  */
10449               arg1 = ada_coerce_ref (arg1);
10450               return value_ref (arg1, TYPE_CODE_REF);
10451             }
10452         }
10453
10454       /* Records and unions for which GNAT encodings have been
10455          generated need to be statically fixed as well.
10456          Otherwise, non-static fixing produces a type where
10457          all dynamic properties are removed, which prevents "ptype"
10458          from being able to completely describe the type.
10459          For instance, a case statement in a variant record would be
10460          replaced by the relevant components based on the actual
10461          value of the discriminants.  */
10462       if ((type->code () == TYPE_CODE_STRUCT
10463            && dynamic_template_type (type) != NULL)
10464           || (type->code () == TYPE_CODE_UNION
10465               && ada_find_parallel_type (type, "___XVU") != NULL))
10466         return value_zero (to_static_fixed_type (type), not_lval);
10467     }
10468
10469   value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10470   return ada_to_fixed_value (arg1);
10471 }
10472
10473 bool
10474 ada_var_value_operation::resolve (struct expression *exp,
10475                                   bool deprocedure_p,
10476                                   bool parse_completion,
10477                                   innermost_block_tracker *tracker,
10478                                   struct type *context_type)
10479 {
10480   symbol *sym = std::get<0> (m_storage).symbol;
10481   if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
10482     {
10483       block_symbol resolved
10484         = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10485                                 context_type, parse_completion,
10486                                 deprocedure_p, tracker);
10487       std::get<0> (m_storage) = resolved;
10488     }
10489
10490   if (deprocedure_p
10491       && (SYMBOL_TYPE (std::get<0> (m_storage).symbol)->code ()
10492           == TYPE_CODE_FUNC))
10493     return true;
10494
10495   return false;
10496 }
10497
10498 value *
10499 ada_atr_val_operation::evaluate (struct type *expect_type,
10500                                  struct expression *exp,
10501                                  enum noside noside)
10502 {
10503   value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10504   return ada_val_atr (noside, std::get<0> (m_storage), arg);
10505 }
10506
10507 value *
10508 ada_unop_ind_operation::evaluate (struct type *expect_type,
10509                                   struct expression *exp,
10510                                   enum noside noside)
10511 {
10512   value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10513
10514   struct type *type = ada_check_typedef (value_type (arg1));
10515   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10516     {
10517       if (ada_is_array_descriptor_type (type))
10518         /* GDB allows dereferencing GNAT array descriptors.  */
10519         {
10520           struct type *arrType = ada_type_of_array (arg1, 0);
10521
10522           if (arrType == NULL)
10523             error (_("Attempt to dereference null array pointer."));
10524           return value_at_lazy (arrType, 0);
10525         }
10526       else if (type->code () == TYPE_CODE_PTR
10527                || type->code () == TYPE_CODE_REF
10528                /* In C you can dereference an array to get the 1st elt.  */
10529                || type->code () == TYPE_CODE_ARRAY)
10530         {
10531           /* As mentioned in the OP_VAR_VALUE case, tagged types can
10532              only be determined by inspecting the object's tag.
10533              This means that we need to evaluate completely the
10534              expression in order to get its type.  */
10535
10536           if ((type->code () == TYPE_CODE_REF
10537                || type->code () == TYPE_CODE_PTR)
10538               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
10539             {
10540               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
10541                                                         EVAL_NORMAL);
10542               type = value_type (ada_value_ind (arg1));
10543             }
10544           else
10545             {
10546               type = to_static_fixed_type
10547                 (ada_aligned_type
10548                  (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10549             }
10550           return value_zero (type, lval_memory);
10551         }
10552       else if (type->code () == TYPE_CODE_INT)
10553         {
10554           /* GDB allows dereferencing an int.  */
10555           if (expect_type == NULL)
10556             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10557                                lval_memory);
10558           else
10559             {
10560               expect_type =
10561                 to_static_fixed_type (ada_aligned_type (expect_type));
10562               return value_zero (expect_type, lval_memory);
10563             }
10564         }
10565       else
10566         error (_("Attempt to take contents of a non-pointer value."));
10567     }
10568   arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
10569   type = ada_check_typedef (value_type (arg1));
10570
10571   if (type->code () == TYPE_CODE_INT)
10572     /* GDB allows dereferencing an int.  If we were given
10573        the expect_type, then use that as the target type.
10574        Otherwise, assume that the target type is an int.  */
10575     {
10576       if (expect_type != NULL)
10577         return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10578                                           arg1));
10579       else
10580         return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10581                               (CORE_ADDR) value_as_address (arg1));
10582     }
10583
10584   if (ada_is_array_descriptor_type (type))
10585     /* GDB allows dereferencing GNAT array descriptors.  */
10586     return ada_coerce_to_simple_array (arg1);
10587   else
10588     return ada_value_ind (arg1);
10589 }
10590
10591 value *
10592 ada_structop_operation::evaluate (struct type *expect_type,
10593                                   struct expression *exp,
10594                                   enum noside noside)
10595 {
10596   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10597   const char *str = std::get<1> (m_storage).c_str ();
10598   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10599     {
10600       struct type *type;
10601       struct type *type1 = value_type (arg1);
10602
10603       if (ada_is_tagged_type (type1, 1))
10604         {
10605           type = ada_lookup_struct_elt_type (type1, str, 1, 1);
10606
10607           /* If the field is not found, check if it exists in the
10608              extension of this object's type. This means that we
10609              need to evaluate completely the expression.  */
10610
10611           if (type == NULL)
10612             {
10613               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
10614                                                         EVAL_NORMAL);
10615               arg1 = ada_value_struct_elt (arg1, str, 0);
10616               arg1 = unwrap_value (arg1);
10617               type = value_type (ada_to_fixed_value (arg1));
10618             }
10619         }
10620       else
10621         type = ada_lookup_struct_elt_type (type1, str, 1, 0);
10622
10623       return value_zero (ada_aligned_type (type), lval_memory);
10624     }
10625   else
10626     {
10627       arg1 = ada_value_struct_elt (arg1, str, 0);
10628       arg1 = unwrap_value (arg1);
10629       return ada_to_fixed_value (arg1);
10630     }
10631 }
10632
10633 value *
10634 ada_funcall_operation::evaluate (struct type *expect_type,
10635                                  struct expression *exp,
10636                                  enum noside noside)
10637 {
10638   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
10639   int nargs = args_up.size ();
10640   std::vector<value *> argvec (nargs);
10641   operation_up &callee_op = std::get<0> (m_storage);
10642
10643   ada_var_value_operation *avv
10644     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
10645   if (avv != nullptr
10646       && SYMBOL_DOMAIN (avv->get_symbol ()) == UNDEF_DOMAIN)
10647     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10648            avv->get_symbol ()->print_name ());
10649
10650   value *callee = callee_op->evaluate (nullptr, exp, noside);
10651   for (int i = 0; i < args_up.size (); ++i)
10652     argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
10653
10654   if (ada_is_constrained_packed_array_type
10655       (desc_base_type (value_type (callee))))
10656     callee = ada_coerce_to_simple_array (callee);
10657   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
10658            && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
10659     /* This is a packed array that has already been fixed, and
10660        therefore already coerced to a simple array.  Nothing further
10661        to do.  */
10662     ;
10663   else if (value_type (callee)->code () == TYPE_CODE_REF)
10664     {
10665       /* Make sure we dereference references so that all the code below
10666          feels like it's really handling the referenced value.  Wrapping
10667          types (for alignment) may be there, so make sure we strip them as
10668          well.  */
10669       callee = ada_to_fixed_value (coerce_ref (callee));
10670     }
10671   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
10672            && VALUE_LVAL (callee) == lval_memory)
10673     callee = value_addr (callee);
10674
10675   struct type *type = ada_check_typedef (value_type (callee));
10676
10677   /* Ada allows us to implicitly dereference arrays when subscripting
10678      them.  So, if this is an array typedef (encoding use for array
10679      access types encoded as fat pointers), strip it now.  */
10680   if (type->code () == TYPE_CODE_TYPEDEF)
10681     type = ada_typedef_target_type (type);
10682
10683   if (type->code () == TYPE_CODE_PTR)
10684     {
10685       switch (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ())
10686         {
10687         case TYPE_CODE_FUNC:
10688           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10689           break;
10690         case TYPE_CODE_ARRAY:
10691           break;
10692         case TYPE_CODE_STRUCT:
10693           if (noside != EVAL_AVOID_SIDE_EFFECTS)
10694             callee = ada_value_ind (callee);
10695           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10696           break;
10697         default:
10698           error (_("cannot subscript or call something of type `%s'"),
10699                  ada_type_name (value_type (callee)));
10700           break;
10701         }
10702     }
10703
10704   switch (type->code ())
10705     {
10706     case TYPE_CODE_FUNC:
10707       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10708         {
10709           if (TYPE_TARGET_TYPE (type) == NULL)
10710             error_call_unknown_return_type (NULL);
10711           return allocate_value (TYPE_TARGET_TYPE (type));
10712         }
10713       return call_function_by_hand (callee, NULL, argvec);
10714     case TYPE_CODE_INTERNAL_FUNCTION:
10715       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10716         /* We don't know anything about what the internal
10717            function might return, but we have to return
10718            something.  */
10719         return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10720                            not_lval);
10721       else
10722         return call_internal_function (exp->gdbarch, exp->language_defn,
10723                                        callee, nargs,
10724                                        argvec.data ());
10725
10726     case TYPE_CODE_STRUCT:
10727       {
10728         int arity;
10729
10730         arity = ada_array_arity (type);
10731         type = ada_array_element_type (type, nargs);
10732         if (type == NULL)
10733           error (_("cannot subscript or call a record"));
10734         if (arity != nargs)
10735           error (_("wrong number of subscripts; expecting %d"), arity);
10736         if (noside == EVAL_AVOID_SIDE_EFFECTS)
10737           return value_zero (ada_aligned_type (type), lval_memory);
10738         return
10739           unwrap_value (ada_value_subscript
10740                         (callee, nargs, argvec.data ()));
10741       }
10742     case TYPE_CODE_ARRAY:
10743       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10744         {
10745           type = ada_array_element_type (type, nargs);
10746           if (type == NULL)
10747             error (_("element type of array unknown"));
10748           else
10749             return value_zero (ada_aligned_type (type), lval_memory);
10750         }
10751       return
10752         unwrap_value (ada_value_subscript
10753                       (ada_coerce_to_simple_array (callee),
10754                        nargs, argvec.data ()));
10755     case TYPE_CODE_PTR:     /* Pointer to array */
10756       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10757         {
10758           type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10759           type = ada_array_element_type (type, nargs);
10760           if (type == NULL)
10761             error (_("element type of array unknown"));
10762           else
10763             return value_zero (ada_aligned_type (type), lval_memory);
10764         }
10765       return
10766         unwrap_value (ada_value_ptr_subscript (callee, nargs,
10767                                                argvec.data ()));
10768
10769     default:
10770       error (_("Attempt to index or call something other than an "
10771                "array or function"));
10772     }
10773 }
10774
10775 bool
10776 ada_funcall_operation::resolve (struct expression *exp,
10777                                 bool deprocedure_p,
10778                                 bool parse_completion,
10779                                 innermost_block_tracker *tracker,
10780                                 struct type *context_type)
10781 {
10782   operation_up &callee_op = std::get<0> (m_storage);
10783
10784   ada_var_value_operation *avv
10785     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
10786   if (avv == nullptr)
10787     return false;
10788
10789   symbol *sym = avv->get_symbol ();
10790   if (SYMBOL_DOMAIN (sym) != UNDEF_DOMAIN)
10791     return false;
10792
10793   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
10794   int nargs = args_up.size ();
10795   std::vector<value *> argvec (nargs);
10796
10797   for (int i = 0; i < args_up.size (); ++i)
10798     argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
10799
10800   const block *block = avv->get_block ();
10801   block_symbol resolved
10802     = ada_resolve_funcall (sym, block,
10803                            context_type, parse_completion,
10804                            nargs, argvec.data (),
10805                            tracker);
10806
10807   std::get<0> (m_storage)
10808     = make_operation<ada_var_value_operation> (resolved);
10809   return false;
10810 }
10811
10812 bool
10813 ada_ternop_slice_operation::resolve (struct expression *exp,
10814                                      bool deprocedure_p,
10815                                      bool parse_completion,
10816                                      innermost_block_tracker *tracker,
10817                                      struct type *context_type)
10818 {
10819   /* Historically this check was done during resolution, so we
10820      continue that here.  */
10821   value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
10822                                                 EVAL_AVOID_SIDE_EFFECTS);
10823   if (ada_is_any_packed_array_type (value_type (v)))
10824     error (_("cannot slice a packed array"));
10825   return false;
10826 }
10827
10828 }
10829
10830 \f
10831
10832 /* Return non-zero iff TYPE represents a System.Address type.  */
10833
10834 int
10835 ada_is_system_address_type (struct type *type)
10836 {
10837   return (type->name () && strcmp (type->name (), "system__address") == 0);
10838 }
10839
10840 \f
10841
10842                                 /* Range types */
10843
10844 /* Scan STR beginning at position K for a discriminant name, and
10845    return the value of that discriminant field of DVAL in *PX.  If
10846    PNEW_K is not null, put the position of the character beyond the
10847    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
10848    not alter *PX and *PNEW_K if unsuccessful.  */
10849
10850 static int
10851 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
10852                     int *pnew_k)
10853 {
10854   static std::string storage;
10855   const char *pstart, *pend, *bound;
10856   struct value *bound_val;
10857
10858   if (dval == NULL || str == NULL || str[k] == '\0')
10859     return 0;
10860
10861   pstart = str + k;
10862   pend = strstr (pstart, "__");
10863   if (pend == NULL)
10864     {
10865       bound = pstart;
10866       k += strlen (bound);
10867     }
10868   else
10869     {
10870       int len = pend - pstart;
10871
10872       /* Strip __ and beyond.  */
10873       storage = std::string (pstart, len);
10874       bound = storage.c_str ();
10875       k = pend - str;
10876     }
10877
10878   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
10879   if (bound_val == NULL)
10880     return 0;
10881
10882   *px = value_as_long (bound_val);
10883   if (pnew_k != NULL)
10884     *pnew_k = k;
10885   return 1;
10886 }
10887
10888 /* Value of variable named NAME.  Only exact matches are considered.
10889    If no such variable found, then if ERR_MSG is null, returns 0, and
10890    otherwise causes an error with message ERR_MSG.  */
10891
10892 static struct value *
10893 get_var_value (const char *name, const char *err_msg)
10894 {
10895   std::string quoted_name = add_angle_brackets (name);
10896
10897   lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
10898
10899   std::vector<struct block_symbol> syms
10900     = ada_lookup_symbol_list_worker (lookup_name,
10901                                      get_selected_block (0),
10902                                      VAR_DOMAIN, 1);
10903
10904   if (syms.size () != 1)
10905     {
10906       if (err_msg == NULL)
10907         return 0;
10908       else
10909         error (("%s"), err_msg);
10910     }
10911
10912   return value_of_variable (syms[0].symbol, syms[0].block);
10913 }
10914
10915 /* Value of integer variable named NAME in the current environment.
10916    If no such variable is found, returns false.  Otherwise, sets VALUE
10917    to the variable's value and returns true.  */
10918
10919 bool
10920 get_int_var_value (const char *name, LONGEST &value)
10921 {
10922   struct value *var_val = get_var_value (name, 0);
10923
10924   if (var_val == 0)
10925     return false;
10926
10927   value = value_as_long (var_val);
10928   return true;
10929 }
10930
10931
10932 /* Return a range type whose base type is that of the range type named
10933    NAME in the current environment, and whose bounds are calculated
10934    from NAME according to the GNAT range encoding conventions.
10935    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
10936    corresponding range type from debug information; fall back to using it
10937    if symbol lookup fails.  If a new type must be created, allocate it
10938    like ORIG_TYPE was.  The bounds information, in general, is encoded
10939    in NAME, the base type given in the named range type.  */
10940
10941 static struct type *
10942 to_fixed_range_type (struct type *raw_type, struct value *dval)
10943 {
10944   const char *name;
10945   struct type *base_type;
10946   const char *subtype_info;
10947
10948   gdb_assert (raw_type != NULL);
10949   gdb_assert (raw_type->name () != NULL);
10950
10951   if (raw_type->code () == TYPE_CODE_RANGE)
10952     base_type = TYPE_TARGET_TYPE (raw_type);
10953   else
10954     base_type = raw_type;
10955
10956   name = raw_type->name ();
10957   subtype_info = strstr (name, "___XD");
10958   if (subtype_info == NULL)
10959     {
10960       LONGEST L = ada_discrete_type_low_bound (raw_type);
10961       LONGEST U = ada_discrete_type_high_bound (raw_type);
10962
10963       if (L < INT_MIN || U > INT_MAX)
10964         return raw_type;
10965       else
10966         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
10967                                          L, U);
10968     }
10969   else
10970     {
10971       int prefix_len = subtype_info - name;
10972       LONGEST L, U;
10973       struct type *type;
10974       const char *bounds_str;
10975       int n;
10976
10977       subtype_info += 5;
10978       bounds_str = strchr (subtype_info, '_');
10979       n = 1;
10980
10981       if (*subtype_info == 'L')
10982         {
10983           if (!ada_scan_number (bounds_str, n, &L, &n)
10984               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
10985             return raw_type;
10986           if (bounds_str[n] == '_')
10987             n += 2;
10988           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
10989             n += 1;
10990           subtype_info += 1;
10991         }
10992       else
10993         {
10994           std::string name_buf = std::string (name, prefix_len) + "___L";
10995           if (!get_int_var_value (name_buf.c_str (), L))
10996             {
10997               lim_warning (_("Unknown lower bound, using 1."));
10998               L = 1;
10999             }
11000         }
11001
11002       if (*subtype_info == 'U')
11003         {
11004           if (!ada_scan_number (bounds_str, n, &U, &n)
11005               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11006             return raw_type;
11007         }
11008       else
11009         {
11010           std::string name_buf = std::string (name, prefix_len) + "___U";
11011           if (!get_int_var_value (name_buf.c_str (), U))
11012             {
11013               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11014               U = L;
11015             }
11016         }
11017
11018       type = create_static_range_type (alloc_type_copy (raw_type),
11019                                        base_type, L, U);
11020       /* create_static_range_type alters the resulting type's length
11021          to match the size of the base_type, which is not what we want.
11022          Set it back to the original range type's length.  */
11023       TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11024       type->set_name (name);
11025       return type;
11026     }
11027 }
11028
11029 /* True iff NAME is the name of a range type.  */
11030
11031 int
11032 ada_is_range_type_name (const char *name)
11033 {
11034   return (name != NULL && strstr (name, "___XD"));
11035 }
11036 \f
11037
11038                                 /* Modular types */
11039
11040 /* True iff TYPE is an Ada modular type.  */
11041
11042 int
11043 ada_is_modular_type (struct type *type)
11044 {
11045   struct type *subranged_type = get_base_type (type);
11046
11047   return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11048           && subranged_type->code () == TYPE_CODE_INT
11049           && subranged_type->is_unsigned ());
11050 }
11051
11052 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
11053
11054 ULONGEST
11055 ada_modulus (struct type *type)
11056 {
11057   const dynamic_prop &high = type->bounds ()->high;
11058
11059   if (high.kind () == PROP_CONST)
11060     return (ULONGEST) high.const_val () + 1;
11061
11062   /* If TYPE is unresolved, the high bound might be a location list.  Return
11063      0, for lack of a better value to return.  */
11064   return 0;
11065 }
11066 \f
11067
11068 /* Ada exception catchpoint support:
11069    ---------------------------------
11070
11071    We support 3 kinds of exception catchpoints:
11072      . catchpoints on Ada exceptions
11073      . catchpoints on unhandled Ada exceptions
11074      . catchpoints on failed assertions
11075
11076    Exceptions raised during failed assertions, or unhandled exceptions
11077    could perfectly be caught with the general catchpoint on Ada exceptions.
11078    However, we can easily differentiate these two special cases, and having
11079    the option to distinguish these two cases from the rest can be useful
11080    to zero-in on certain situations.
11081
11082    Exception catchpoints are a specialized form of breakpoint,
11083    since they rely on inserting breakpoints inside known routines
11084    of the GNAT runtime.  The implementation therefore uses a standard
11085    breakpoint structure of the BP_BREAKPOINT type, but with its own set
11086    of breakpoint_ops.
11087
11088    Support in the runtime for exception catchpoints have been changed
11089    a few times already, and these changes affect the implementation
11090    of these catchpoints.  In order to be able to support several
11091    variants of the runtime, we use a sniffer that will determine
11092    the runtime variant used by the program being debugged.  */
11093
11094 /* Ada's standard exceptions.
11095
11096    The Ada 83 standard also defined Numeric_Error.  But there so many
11097    situations where it was unclear from the Ada 83 Reference Manual
11098    (RM) whether Constraint_Error or Numeric_Error should be raised,
11099    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11100    Interpretation saying that anytime the RM says that Numeric_Error
11101    should be raised, the implementation may raise Constraint_Error.
11102    Ada 95 went one step further and pretty much removed Numeric_Error
11103    from the list of standard exceptions (it made it a renaming of
11104    Constraint_Error, to help preserve compatibility when compiling
11105    an Ada83 compiler). As such, we do not include Numeric_Error from
11106    this list of standard exceptions.  */
11107
11108 static const char * const standard_exc[] = {
11109   "constraint_error",
11110   "program_error",
11111   "storage_error",
11112   "tasking_error"
11113 };
11114
11115 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11116
11117 /* A structure that describes how to support exception catchpoints
11118    for a given executable.  */
11119
11120 struct exception_support_info
11121 {
11122    /* The name of the symbol to break on in order to insert
11123       a catchpoint on exceptions.  */
11124    const char *catch_exception_sym;
11125
11126    /* The name of the symbol to break on in order to insert
11127       a catchpoint on unhandled exceptions.  */
11128    const char *catch_exception_unhandled_sym;
11129
11130    /* The name of the symbol to break on in order to insert
11131       a catchpoint on failed assertions.  */
11132    const char *catch_assert_sym;
11133
11134    /* The name of the symbol to break on in order to insert
11135       a catchpoint on exception handling.  */
11136    const char *catch_handlers_sym;
11137
11138    /* Assuming that the inferior just triggered an unhandled exception
11139       catchpoint, this function is responsible for returning the address
11140       in inferior memory where the name of that exception is stored.
11141       Return zero if the address could not be computed.  */
11142    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11143 };
11144
11145 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11146 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11147
11148 /* The following exception support info structure describes how to
11149    implement exception catchpoints with the latest version of the
11150    Ada runtime (as of 2019-08-??).  */
11151
11152 static const struct exception_support_info default_exception_support_info =
11153 {
11154   "__gnat_debug_raise_exception", /* catch_exception_sym */
11155   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11156   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11157   "__gnat_begin_handler_v1", /* catch_handlers_sym */
11158   ada_unhandled_exception_name_addr
11159 };
11160
11161 /* The following exception support info structure describes how to
11162    implement exception catchpoints with an earlier version of the
11163    Ada runtime (as of 2007-03-06) using v0 of the EH ABI.  */
11164
11165 static const struct exception_support_info exception_support_info_v0 =
11166 {
11167   "__gnat_debug_raise_exception", /* catch_exception_sym */
11168   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11169   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11170   "__gnat_begin_handler", /* catch_handlers_sym */
11171   ada_unhandled_exception_name_addr
11172 };
11173
11174 /* The following exception support info structure describes how to
11175    implement exception catchpoints with a slightly older version
11176    of the Ada runtime.  */
11177
11178 static const struct exception_support_info exception_support_info_fallback =
11179 {
11180   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11181   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11182   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
11183   "__gnat_begin_handler", /* catch_handlers_sym */
11184   ada_unhandled_exception_name_addr_from_raise
11185 };
11186
11187 /* Return nonzero if we can detect the exception support routines
11188    described in EINFO.
11189
11190    This function errors out if an abnormal situation is detected
11191    (for instance, if we find the exception support routines, but
11192    that support is found to be incomplete).  */
11193
11194 static int
11195 ada_has_this_exception_support (const struct exception_support_info *einfo)
11196 {
11197   struct symbol *sym;
11198
11199   /* The symbol we're looking up is provided by a unit in the GNAT runtime
11200      that should be compiled with debugging information.  As a result, we
11201      expect to find that symbol in the symtabs.  */
11202
11203   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11204   if (sym == NULL)
11205     {
11206       /* Perhaps we did not find our symbol because the Ada runtime was
11207          compiled without debugging info, or simply stripped of it.
11208          It happens on some GNU/Linux distributions for instance, where
11209          users have to install a separate debug package in order to get
11210          the runtime's debugging info.  In that situation, let the user
11211          know why we cannot insert an Ada exception catchpoint.
11212
11213          Note: Just for the purpose of inserting our Ada exception
11214          catchpoint, we could rely purely on the associated minimal symbol.
11215          But we would be operating in degraded mode anyway, since we are
11216          still lacking the debugging info needed later on to extract
11217          the name of the exception being raised (this name is printed in
11218          the catchpoint message, and is also used when trying to catch
11219          a specific exception).  We do not handle this case for now.  */
11220       struct bound_minimal_symbol msym
11221         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11222
11223       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11224         error (_("Your Ada runtime appears to be missing some debugging "
11225                  "information.\nCannot insert Ada exception catchpoint "
11226                  "in this configuration."));
11227
11228       return 0;
11229     }
11230
11231   /* Make sure that the symbol we found corresponds to a function.  */
11232
11233   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11234     {
11235       error (_("Symbol \"%s\" is not a function (class = %d)"),
11236              sym->linkage_name (), SYMBOL_CLASS (sym));
11237       return 0;
11238     }
11239
11240   sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11241   if (sym == NULL)
11242     {
11243       struct bound_minimal_symbol msym
11244         = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11245
11246       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11247         error (_("Your Ada runtime appears to be missing some debugging "
11248                  "information.\nCannot insert Ada exception catchpoint "
11249                  "in this configuration."));
11250
11251       return 0;
11252     }
11253
11254   /* Make sure that the symbol we found corresponds to a function.  */
11255
11256   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11257     {
11258       error (_("Symbol \"%s\" is not a function (class = %d)"),
11259              sym->linkage_name (), SYMBOL_CLASS (sym));
11260       return 0;
11261     }
11262
11263   return 1;
11264 }
11265
11266 /* Inspect the Ada runtime and determine which exception info structure
11267    should be used to provide support for exception catchpoints.
11268
11269    This function will always set the per-inferior exception_info,
11270    or raise an error.  */
11271
11272 static void
11273 ada_exception_support_info_sniffer (void)
11274 {
11275   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11276
11277   /* If the exception info is already known, then no need to recompute it.  */
11278   if (data->exception_info != NULL)
11279     return;
11280
11281   /* Check the latest (default) exception support info.  */
11282   if (ada_has_this_exception_support (&default_exception_support_info))
11283     {
11284       data->exception_info = &default_exception_support_info;
11285       return;
11286     }
11287
11288   /* Try the v0 exception suport info.  */
11289   if (ada_has_this_exception_support (&exception_support_info_v0))
11290     {
11291       data->exception_info = &exception_support_info_v0;
11292       return;
11293     }
11294
11295   /* Try our fallback exception suport info.  */
11296   if (ada_has_this_exception_support (&exception_support_info_fallback))
11297     {
11298       data->exception_info = &exception_support_info_fallback;
11299       return;
11300     }
11301
11302   /* Sometimes, it is normal for us to not be able to find the routine
11303      we are looking for.  This happens when the program is linked with
11304      the shared version of the GNAT runtime, and the program has not been
11305      started yet.  Inform the user of these two possible causes if
11306      applicable.  */
11307
11308   if (ada_update_initial_language (language_unknown) != language_ada)
11309     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
11310
11311   /* If the symbol does not exist, then check that the program is
11312      already started, to make sure that shared libraries have been
11313      loaded.  If it is not started, this may mean that the symbol is
11314      in a shared library.  */
11315
11316   if (inferior_ptid.pid () == 0)
11317     error (_("Unable to insert catchpoint. Try to start the program first."));
11318
11319   /* At this point, we know that we are debugging an Ada program and
11320      that the inferior has been started, but we still are not able to
11321      find the run-time symbols.  That can mean that we are in
11322      configurable run time mode, or that a-except as been optimized
11323      out by the linker...  In any case, at this point it is not worth
11324      supporting this feature.  */
11325
11326   error (_("Cannot insert Ada exception catchpoints in this configuration."));
11327 }
11328
11329 /* True iff FRAME is very likely to be that of a function that is
11330    part of the runtime system.  This is all very heuristic, but is
11331    intended to be used as advice as to what frames are uninteresting
11332    to most users.  */
11333
11334 static int
11335 is_known_support_routine (struct frame_info *frame)
11336 {
11337   enum language func_lang;
11338   int i;
11339   const char *fullname;
11340
11341   /* If this code does not have any debugging information (no symtab),
11342      This cannot be any user code.  */
11343
11344   symtab_and_line sal = find_frame_sal (frame);
11345   if (sal.symtab == NULL)
11346     return 1;
11347
11348   /* If there is a symtab, but the associated source file cannot be
11349      located, then assume this is not user code:  Selecting a frame
11350      for which we cannot display the code would not be very helpful
11351      for the user.  This should also take care of case such as VxWorks
11352      where the kernel has some debugging info provided for a few units.  */
11353
11354   fullname = symtab_to_fullname (sal.symtab);
11355   if (access (fullname, R_OK) != 0)
11356     return 1;
11357
11358   /* Check the unit filename against the Ada runtime file naming.
11359      We also check the name of the objfile against the name of some
11360      known system libraries that sometimes come with debugging info
11361      too.  */
11362
11363   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11364     {
11365       re_comp (known_runtime_file_name_patterns[i]);
11366       if (re_exec (lbasename (sal.symtab->filename)))
11367         return 1;
11368       if (SYMTAB_OBJFILE (sal.symtab) != NULL
11369           && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
11370         return 1;
11371     }
11372
11373   /* Check whether the function is a GNAT-generated entity.  */
11374
11375   gdb::unique_xmalloc_ptr<char> func_name
11376     = find_frame_funname (frame, &func_lang, NULL);
11377   if (func_name == NULL)
11378     return 1;
11379
11380   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11381     {
11382       re_comp (known_auxiliary_function_name_patterns[i]);
11383       if (re_exec (func_name.get ()))
11384         return 1;
11385     }
11386
11387   return 0;
11388 }
11389
11390 /* Find the first frame that contains debugging information and that is not
11391    part of the Ada run-time, starting from FI and moving upward.  */
11392
11393 void
11394 ada_find_printable_frame (struct frame_info *fi)
11395 {
11396   for (; fi != NULL; fi = get_prev_frame (fi))
11397     {
11398       if (!is_known_support_routine (fi))
11399         {
11400           select_frame (fi);
11401           break;
11402         }
11403     }
11404
11405 }
11406
11407 /* Assuming that the inferior just triggered an unhandled exception
11408    catchpoint, return the address in inferior memory where the name
11409    of the exception is stored.
11410    
11411    Return zero if the address could not be computed.  */
11412
11413 static CORE_ADDR
11414 ada_unhandled_exception_name_addr (void)
11415 {
11416   return parse_and_eval_address ("e.full_name");
11417 }
11418
11419 /* Same as ada_unhandled_exception_name_addr, except that this function
11420    should be used when the inferior uses an older version of the runtime,
11421    where the exception name needs to be extracted from a specific frame
11422    several frames up in the callstack.  */
11423
11424 static CORE_ADDR
11425 ada_unhandled_exception_name_addr_from_raise (void)
11426 {
11427   int frame_level;
11428   struct frame_info *fi;
11429   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11430
11431   /* To determine the name of this exception, we need to select
11432      the frame corresponding to RAISE_SYM_NAME.  This frame is
11433      at least 3 levels up, so we simply skip the first 3 frames
11434      without checking the name of their associated function.  */
11435   fi = get_current_frame ();
11436   for (frame_level = 0; frame_level < 3; frame_level += 1)
11437     if (fi != NULL)
11438       fi = get_prev_frame (fi); 
11439
11440   while (fi != NULL)
11441     {
11442       enum language func_lang;
11443
11444       gdb::unique_xmalloc_ptr<char> func_name
11445         = find_frame_funname (fi, &func_lang, NULL);
11446       if (func_name != NULL)
11447         {
11448           if (strcmp (func_name.get (),
11449                       data->exception_info->catch_exception_sym) == 0)
11450             break; /* We found the frame we were looking for...  */
11451         }
11452       fi = get_prev_frame (fi);
11453     }
11454
11455   if (fi == NULL)
11456     return 0;
11457
11458   select_frame (fi);
11459   return parse_and_eval_address ("id.full_name");
11460 }
11461
11462 /* Assuming the inferior just triggered an Ada exception catchpoint
11463    (of any type), return the address in inferior memory where the name
11464    of the exception is stored, if applicable.
11465
11466    Assumes the selected frame is the current frame.
11467
11468    Return zero if the address could not be computed, or if not relevant.  */
11469
11470 static CORE_ADDR
11471 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
11472                            struct breakpoint *b)
11473 {
11474   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11475
11476   switch (ex)
11477     {
11478       case ada_catch_exception:
11479         return (parse_and_eval_address ("e.full_name"));
11480         break;
11481
11482       case ada_catch_exception_unhandled:
11483         return data->exception_info->unhandled_exception_name_addr ();
11484         break;
11485
11486       case ada_catch_handlers:
11487         return 0;  /* The runtimes does not provide access to the exception
11488                       name.  */
11489         break;
11490
11491       case ada_catch_assert:
11492         return 0;  /* Exception name is not relevant in this case.  */
11493         break;
11494
11495       default:
11496         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11497         break;
11498     }
11499
11500   return 0; /* Should never be reached.  */
11501 }
11502
11503 /* Assuming the inferior is stopped at an exception catchpoint,
11504    return the message which was associated to the exception, if
11505    available.  Return NULL if the message could not be retrieved.
11506
11507    Note: The exception message can be associated to an exception
11508    either through the use of the Raise_Exception function, or
11509    more simply (Ada 2005 and later), via:
11510
11511        raise Exception_Name with "exception message";
11512
11513    */
11514
11515 static gdb::unique_xmalloc_ptr<char>
11516 ada_exception_message_1 (void)
11517 {
11518   struct value *e_msg_val;
11519   int e_msg_len;
11520
11521   /* For runtimes that support this feature, the exception message
11522      is passed as an unbounded string argument called "message".  */
11523   e_msg_val = parse_and_eval ("message");
11524   if (e_msg_val == NULL)
11525     return NULL; /* Exception message not supported.  */
11526
11527   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
11528   gdb_assert (e_msg_val != NULL);
11529   e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
11530
11531   /* If the message string is empty, then treat it as if there was
11532      no exception message.  */
11533   if (e_msg_len <= 0)
11534     return NULL;
11535
11536   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
11537   read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
11538                e_msg_len);
11539   e_msg.get ()[e_msg_len] = '\0';
11540
11541   return e_msg;
11542 }
11543
11544 /* Same as ada_exception_message_1, except that all exceptions are
11545    contained here (returning NULL instead).  */
11546
11547 static gdb::unique_xmalloc_ptr<char>
11548 ada_exception_message (void)
11549 {
11550   gdb::unique_xmalloc_ptr<char> e_msg;
11551
11552   try
11553     {
11554       e_msg = ada_exception_message_1 ();
11555     }
11556   catch (const gdb_exception_error &e)
11557     {
11558       e_msg.reset (nullptr);
11559     }
11560
11561   return e_msg;
11562 }
11563
11564 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11565    any error that ada_exception_name_addr_1 might cause to be thrown.
11566    When an error is intercepted, a warning with the error message is printed,
11567    and zero is returned.  */
11568
11569 static CORE_ADDR
11570 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
11571                          struct breakpoint *b)
11572 {
11573   CORE_ADDR result = 0;
11574
11575   try
11576     {
11577       result = ada_exception_name_addr_1 (ex, b);
11578     }
11579
11580   catch (const gdb_exception_error &e)
11581     {
11582       warning (_("failed to get exception name: %s"), e.what ());
11583       return 0;
11584     }
11585
11586   return result;
11587 }
11588
11589 static std::string ada_exception_catchpoint_cond_string
11590   (const char *excep_string,
11591    enum ada_exception_catchpoint_kind ex);
11592
11593 /* Ada catchpoints.
11594
11595    In the case of catchpoints on Ada exceptions, the catchpoint will
11596    stop the target on every exception the program throws.  When a user
11597    specifies the name of a specific exception, we translate this
11598    request into a condition expression (in text form), and then parse
11599    it into an expression stored in each of the catchpoint's locations.
11600    We then use this condition to check whether the exception that was
11601    raised is the one the user is interested in.  If not, then the
11602    target is resumed again.  We store the name of the requested
11603    exception, in order to be able to re-set the condition expression
11604    when symbols change.  */
11605
11606 /* An instance of this type is used to represent an Ada catchpoint
11607    breakpoint location.  */
11608
11609 class ada_catchpoint_location : public bp_location
11610 {
11611 public:
11612   ada_catchpoint_location (breakpoint *owner)
11613     : bp_location (owner, bp_loc_software_breakpoint)
11614   {}
11615
11616   /* The condition that checks whether the exception that was raised
11617      is the specific exception the user specified on catchpoint
11618      creation.  */
11619   expression_up excep_cond_expr;
11620 };
11621
11622 /* An instance of this type is used to represent an Ada catchpoint.  */
11623
11624 struct ada_catchpoint : public breakpoint
11625 {
11626   explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind)
11627     : m_kind (kind)
11628   {
11629   }
11630
11631   /* The name of the specific exception the user specified.  */
11632   std::string excep_string;
11633
11634   /* What kind of catchpoint this is.  */
11635   enum ada_exception_catchpoint_kind m_kind;
11636 };
11637
11638 /* Parse the exception condition string in the context of each of the
11639    catchpoint's locations, and store them for later evaluation.  */
11640
11641 static void
11642 create_excep_cond_exprs (struct ada_catchpoint *c,
11643                          enum ada_exception_catchpoint_kind ex)
11644 {
11645   /* Nothing to do if there's no specific exception to catch.  */
11646   if (c->excep_string.empty ())
11647     return;
11648
11649   /* Same if there are no locations... */
11650   if (c->loc == NULL)
11651     return;
11652
11653   /* Compute the condition expression in text form, from the specific
11654      expection we want to catch.  */
11655   std::string cond_string
11656     = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
11657
11658   /* Iterate over all the catchpoint's locations, and parse an
11659      expression for each.  */
11660   for (bp_location *bl : c->locations ())
11661     {
11662       struct ada_catchpoint_location *ada_loc
11663         = (struct ada_catchpoint_location *) bl;
11664       expression_up exp;
11665
11666       if (!bl->shlib_disabled)
11667         {
11668           const char *s;
11669
11670           s = cond_string.c_str ();
11671           try
11672             {
11673               exp = parse_exp_1 (&s, bl->address,
11674                                  block_for_pc (bl->address),
11675                                  0);
11676             }
11677           catch (const gdb_exception_error &e)
11678             {
11679               warning (_("failed to reevaluate internal exception condition "
11680                          "for catchpoint %d: %s"),
11681                        c->number, e.what ());
11682             }
11683         }
11684
11685       ada_loc->excep_cond_expr = std::move (exp);
11686     }
11687 }
11688
11689 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11690    structure for all exception catchpoint kinds.  */
11691
11692 static struct bp_location *
11693 allocate_location_exception (struct breakpoint *self)
11694 {
11695   return new ada_catchpoint_location (self);
11696 }
11697
11698 /* Implement the RE_SET method in the breakpoint_ops structure for all
11699    exception catchpoint kinds.  */
11700
11701 static void
11702 re_set_exception (struct breakpoint *b)
11703 {
11704   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11705
11706   /* Call the base class's method.  This updates the catchpoint's
11707      locations.  */
11708   bkpt_breakpoint_ops.re_set (b);
11709
11710   /* Reparse the exception conditional expressions.  One for each
11711      location.  */
11712   create_excep_cond_exprs (c, c->m_kind);
11713 }
11714
11715 /* Returns true if we should stop for this breakpoint hit.  If the
11716    user specified a specific exception, we only want to cause a stop
11717    if the program thrown that exception.  */
11718
11719 static bool
11720 should_stop_exception (const struct bp_location *bl)
11721 {
11722   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11723   const struct ada_catchpoint_location *ada_loc
11724     = (const struct ada_catchpoint_location *) bl;
11725   bool stop;
11726
11727   struct internalvar *var = lookup_internalvar ("_ada_exception");
11728   if (c->m_kind == ada_catch_assert)
11729     clear_internalvar (var);
11730   else
11731     {
11732       try
11733         {
11734           const char *expr;
11735
11736           if (c->m_kind == ada_catch_handlers)
11737             expr = ("GNAT_GCC_exception_Access(gcc_exception)"
11738                     ".all.occurrence.id");
11739           else
11740             expr = "e";
11741
11742           struct value *exc = parse_and_eval (expr);
11743           set_internalvar (var, exc);
11744         }
11745       catch (const gdb_exception_error &ex)
11746         {
11747           clear_internalvar (var);
11748         }
11749     }
11750
11751   /* With no specific exception, should always stop.  */
11752   if (c->excep_string.empty ())
11753     return true;
11754
11755   if (ada_loc->excep_cond_expr == NULL)
11756     {
11757       /* We will have a NULL expression if back when we were creating
11758          the expressions, this location's had failed to parse.  */
11759       return true;
11760     }
11761
11762   stop = true;
11763   try
11764     {
11765       struct value *mark;
11766
11767       mark = value_mark ();
11768       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
11769       value_free_to_mark (mark);
11770     }
11771   catch (const gdb_exception &ex)
11772     {
11773       exception_fprintf (gdb_stderr, ex,
11774                          _("Error in testing exception condition:\n"));
11775     }
11776
11777   return stop;
11778 }
11779
11780 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
11781    for all exception catchpoint kinds.  */
11782
11783 static void
11784 check_status_exception (bpstat bs)
11785 {
11786   bs->stop = should_stop_exception (bs->bp_location_at.get ());
11787 }
11788
11789 /* Implement the PRINT_IT method in the breakpoint_ops structure
11790    for all exception catchpoint kinds.  */
11791
11792 static enum print_stop_action
11793 print_it_exception (bpstat bs)
11794 {
11795   struct ui_out *uiout = current_uiout;
11796   struct breakpoint *b = bs->breakpoint_at;
11797
11798   annotate_catchpoint (b->number);
11799
11800   if (uiout->is_mi_like_p ())
11801     {
11802       uiout->field_string ("reason",
11803                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11804       uiout->field_string ("disp", bpdisp_text (b->disposition));
11805     }
11806
11807   uiout->text (b->disposition == disp_del
11808                ? "\nTemporary catchpoint " : "\nCatchpoint ");
11809   uiout->field_signed ("bkptno", b->number);
11810   uiout->text (", ");
11811
11812   /* ada_exception_name_addr relies on the selected frame being the
11813      current frame.  Need to do this here because this function may be
11814      called more than once when printing a stop, and below, we'll
11815      select the first frame past the Ada run-time (see
11816      ada_find_printable_frame).  */
11817   select_frame (get_current_frame ());
11818
11819   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11820   switch (c->m_kind)
11821     {
11822       case ada_catch_exception:
11823       case ada_catch_exception_unhandled:
11824       case ada_catch_handlers:
11825         {
11826           const CORE_ADDR addr = ada_exception_name_addr (c->m_kind, b);
11827           char exception_name[256];
11828
11829           if (addr != 0)
11830             {
11831               read_memory (addr, (gdb_byte *) exception_name,
11832                            sizeof (exception_name) - 1);
11833               exception_name [sizeof (exception_name) - 1] = '\0';
11834             }
11835           else
11836             {
11837               /* For some reason, we were unable to read the exception
11838                  name.  This could happen if the Runtime was compiled
11839                  without debugging info, for instance.  In that case,
11840                  just replace the exception name by the generic string
11841                  "exception" - it will read as "an exception" in the
11842                  notification we are about to print.  */
11843               memcpy (exception_name, "exception", sizeof ("exception"));
11844             }
11845           /* In the case of unhandled exception breakpoints, we print
11846              the exception name as "unhandled EXCEPTION_NAME", to make
11847              it clearer to the user which kind of catchpoint just got
11848              hit.  We used ui_out_text to make sure that this extra
11849              info does not pollute the exception name in the MI case.  */
11850           if (c->m_kind == ada_catch_exception_unhandled)
11851             uiout->text ("unhandled ");
11852           uiout->field_string ("exception-name", exception_name);
11853         }
11854         break;
11855       case ada_catch_assert:
11856         /* In this case, the name of the exception is not really
11857            important.  Just print "failed assertion" to make it clearer
11858            that his program just hit an assertion-failure catchpoint.
11859            We used ui_out_text because this info does not belong in
11860            the MI output.  */
11861         uiout->text ("failed assertion");
11862         break;
11863     }
11864
11865   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
11866   if (exception_message != NULL)
11867     {
11868       uiout->text (" (");
11869       uiout->field_string ("exception-message", exception_message.get ());
11870       uiout->text (")");
11871     }
11872
11873   uiout->text (" at ");
11874   ada_find_printable_frame (get_current_frame ());
11875
11876   return PRINT_SRC_AND_LOC;
11877 }
11878
11879 /* Implement the PRINT_ONE method in the breakpoint_ops structure
11880    for all exception catchpoint kinds.  */
11881
11882 static void
11883 print_one_exception (struct breakpoint *b, struct bp_location **last_loc)
11884
11885   struct ui_out *uiout = current_uiout;
11886   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11887   struct value_print_options opts;
11888
11889   get_user_print_options (&opts);
11890
11891   if (opts.addressprint)
11892     uiout->field_skip ("addr");
11893
11894   annotate_field (5);
11895   switch (c->m_kind)
11896     {
11897       case ada_catch_exception:
11898         if (!c->excep_string.empty ())
11899           {
11900             std::string msg = string_printf (_("`%s' Ada exception"),
11901                                              c->excep_string.c_str ());
11902
11903             uiout->field_string ("what", msg);
11904           }
11905         else
11906           uiout->field_string ("what", "all Ada exceptions");
11907         
11908         break;
11909
11910       case ada_catch_exception_unhandled:
11911         uiout->field_string ("what", "unhandled Ada exceptions");
11912         break;
11913       
11914       case ada_catch_handlers:
11915         if (!c->excep_string.empty ())
11916           {
11917             uiout->field_fmt ("what",
11918                               _("`%s' Ada exception handlers"),
11919                               c->excep_string.c_str ());
11920           }
11921         else
11922           uiout->field_string ("what", "all Ada exceptions handlers");
11923         break;
11924
11925       case ada_catch_assert:
11926         uiout->field_string ("what", "failed Ada assertions");
11927         break;
11928
11929       default:
11930         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11931         break;
11932     }
11933 }
11934
11935 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
11936    for all exception catchpoint kinds.  */
11937
11938 static void
11939 print_mention_exception (struct breakpoint *b)
11940 {
11941   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11942   struct ui_out *uiout = current_uiout;
11943
11944   uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
11945                                                  : _("Catchpoint "));
11946   uiout->field_signed ("bkptno", b->number);
11947   uiout->text (": ");
11948
11949   switch (c->m_kind)
11950     {
11951       case ada_catch_exception:
11952         if (!c->excep_string.empty ())
11953           {
11954             std::string info = string_printf (_("`%s' Ada exception"),
11955                                               c->excep_string.c_str ());
11956             uiout->text (info);
11957           }
11958         else
11959           uiout->text (_("all Ada exceptions"));
11960         break;
11961
11962       case ada_catch_exception_unhandled:
11963         uiout->text (_("unhandled Ada exceptions"));
11964         break;
11965
11966       case ada_catch_handlers:
11967         if (!c->excep_string.empty ())
11968           {
11969             std::string info
11970               = string_printf (_("`%s' Ada exception handlers"),
11971                                c->excep_string.c_str ());
11972             uiout->text (info);
11973           }
11974         else
11975           uiout->text (_("all Ada exceptions handlers"));
11976         break;
11977
11978       case ada_catch_assert:
11979         uiout->text (_("failed Ada assertions"));
11980         break;
11981
11982       default:
11983         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11984         break;
11985     }
11986 }
11987
11988 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
11989    for all exception catchpoint kinds.  */
11990
11991 static void
11992 print_recreate_exception (struct breakpoint *b, struct ui_file *fp)
11993 {
11994   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11995
11996   switch (c->m_kind)
11997     {
11998       case ada_catch_exception:
11999         fprintf_filtered (fp, "catch exception");
12000         if (!c->excep_string.empty ())
12001           fprintf_filtered (fp, " %s", c->excep_string.c_str ());
12002         break;
12003
12004       case ada_catch_exception_unhandled:
12005         fprintf_filtered (fp, "catch exception unhandled");
12006         break;
12007
12008       case ada_catch_handlers:
12009         fprintf_filtered (fp, "catch handlers");
12010         break;
12011
12012       case ada_catch_assert:
12013         fprintf_filtered (fp, "catch assert");
12014         break;
12015
12016       default:
12017         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12018     }
12019   print_recreate_thread (b, fp);
12020 }
12021
12022 /* Virtual tables for various breakpoint types.  */
12023 static struct breakpoint_ops catch_exception_breakpoint_ops;
12024 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
12025 static struct breakpoint_ops catch_assert_breakpoint_ops;
12026 static struct breakpoint_ops catch_handlers_breakpoint_ops;
12027
12028 /* See ada-lang.h.  */
12029
12030 bool
12031 is_ada_exception_catchpoint (breakpoint *bp)
12032 {
12033   return (bp->ops == &catch_exception_breakpoint_ops
12034           || bp->ops == &catch_exception_unhandled_breakpoint_ops
12035           || bp->ops == &catch_assert_breakpoint_ops
12036           || bp->ops == &catch_handlers_breakpoint_ops);
12037 }
12038
12039 /* Split the arguments specified in a "catch exception" command.  
12040    Set EX to the appropriate catchpoint type.
12041    Set EXCEP_STRING to the name of the specific exception if
12042    specified by the user.
12043    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12044    "catch handlers" command.  False otherwise.
12045    If a condition is found at the end of the arguments, the condition
12046    expression is stored in COND_STRING (memory must be deallocated
12047    after use).  Otherwise COND_STRING is set to NULL.  */
12048
12049 static void
12050 catch_ada_exception_command_split (const char *args,
12051                                    bool is_catch_handlers_cmd,
12052                                    enum ada_exception_catchpoint_kind *ex,
12053                                    std::string *excep_string,
12054                                    std::string *cond_string)
12055 {
12056   std::string exception_name;
12057
12058   exception_name = extract_arg (&args);
12059   if (exception_name == "if")
12060     {
12061       /* This is not an exception name; this is the start of a condition
12062          expression for a catchpoint on all exceptions.  So, "un-get"
12063          this token, and set exception_name to NULL.  */
12064       exception_name.clear ();
12065       args -= 2;
12066     }
12067
12068   /* Check to see if we have a condition.  */
12069
12070   args = skip_spaces (args);
12071   if (startswith (args, "if")
12072       && (isspace (args[2]) || args[2] == '\0'))
12073     {
12074       args += 2;
12075       args = skip_spaces (args);
12076
12077       if (args[0] == '\0')
12078         error (_("Condition missing after `if' keyword"));
12079       *cond_string = args;
12080
12081       args += strlen (args);
12082     }
12083
12084   /* Check that we do not have any more arguments.  Anything else
12085      is unexpected.  */
12086
12087   if (args[0] != '\0')
12088     error (_("Junk at end of expression"));
12089
12090   if (is_catch_handlers_cmd)
12091     {
12092       /* Catch handling of exceptions.  */
12093       *ex = ada_catch_handlers;
12094       *excep_string = exception_name;
12095     }
12096   else if (exception_name.empty ())
12097     {
12098       /* Catch all exceptions.  */
12099       *ex = ada_catch_exception;
12100       excep_string->clear ();
12101     }
12102   else if (exception_name == "unhandled")
12103     {
12104       /* Catch unhandled exceptions.  */
12105       *ex = ada_catch_exception_unhandled;
12106       excep_string->clear ();
12107     }
12108   else
12109     {
12110       /* Catch a specific exception.  */
12111       *ex = ada_catch_exception;
12112       *excep_string = exception_name;
12113     }
12114 }
12115
12116 /* Return the name of the symbol on which we should break in order to
12117    implement a catchpoint of the EX kind.  */
12118
12119 static const char *
12120 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12121 {
12122   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12123
12124   gdb_assert (data->exception_info != NULL);
12125
12126   switch (ex)
12127     {
12128       case ada_catch_exception:
12129         return (data->exception_info->catch_exception_sym);
12130         break;
12131       case ada_catch_exception_unhandled:
12132         return (data->exception_info->catch_exception_unhandled_sym);
12133         break;
12134       case ada_catch_assert:
12135         return (data->exception_info->catch_assert_sym);
12136         break;
12137       case ada_catch_handlers:
12138         return (data->exception_info->catch_handlers_sym);
12139         break;
12140       default:
12141         internal_error (__FILE__, __LINE__,
12142                         _("unexpected catchpoint kind (%d)"), ex);
12143     }
12144 }
12145
12146 /* Return the breakpoint ops "virtual table" used for catchpoints
12147    of the EX kind.  */
12148
12149 static const struct breakpoint_ops *
12150 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
12151 {
12152   switch (ex)
12153     {
12154       case ada_catch_exception:
12155         return (&catch_exception_breakpoint_ops);
12156         break;
12157       case ada_catch_exception_unhandled:
12158         return (&catch_exception_unhandled_breakpoint_ops);
12159         break;
12160       case ada_catch_assert:
12161         return (&catch_assert_breakpoint_ops);
12162         break;
12163       case ada_catch_handlers:
12164         return (&catch_handlers_breakpoint_ops);
12165         break;
12166       default:
12167         internal_error (__FILE__, __LINE__,
12168                         _("unexpected catchpoint kind (%d)"), ex);
12169     }
12170 }
12171
12172 /* Return the condition that will be used to match the current exception
12173    being raised with the exception that the user wants to catch.  This
12174    assumes that this condition is used when the inferior just triggered
12175    an exception catchpoint.
12176    EX: the type of catchpoints used for catching Ada exceptions.  */
12177
12178 static std::string
12179 ada_exception_catchpoint_cond_string (const char *excep_string,
12180                                       enum ada_exception_catchpoint_kind ex)
12181 {
12182   int i;
12183   bool is_standard_exc = false;
12184   std::string result;
12185
12186   if (ex == ada_catch_handlers)
12187     {
12188       /* For exception handlers catchpoints, the condition string does
12189          not use the same parameter as for the other exceptions.  */
12190       result = ("long_integer (GNAT_GCC_exception_Access"
12191                 "(gcc_exception).all.occurrence.id)");
12192     }
12193   else
12194     result = "long_integer (e)";
12195
12196   /* The standard exceptions are a special case.  They are defined in
12197      runtime units that have been compiled without debugging info; if
12198      EXCEP_STRING is the not-fully-qualified name of a standard
12199      exception (e.g. "constraint_error") then, during the evaluation
12200      of the condition expression, the symbol lookup on this name would
12201      *not* return this standard exception.  The catchpoint condition
12202      may then be set only on user-defined exceptions which have the
12203      same not-fully-qualified name (e.g. my_package.constraint_error).
12204
12205      To avoid this unexcepted behavior, these standard exceptions are
12206      systematically prefixed by "standard".  This means that "catch
12207      exception constraint_error" is rewritten into "catch exception
12208      standard.constraint_error".
12209
12210      If an exception named constraint_error is defined in another package of
12211      the inferior program, then the only way to specify this exception as a
12212      breakpoint condition is to use its fully-qualified named:
12213      e.g. my_package.constraint_error.  */
12214
12215   for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12216     {
12217       if (strcmp (standard_exc [i], excep_string) == 0)
12218         {
12219           is_standard_exc = true;
12220           break;
12221         }
12222     }
12223
12224   result += " = ";
12225
12226   if (is_standard_exc)
12227     string_appendf (result, "long_integer (&standard.%s)", excep_string);
12228   else
12229     string_appendf (result, "long_integer (&%s)", excep_string);
12230
12231   return result;
12232 }
12233
12234 /* Return the symtab_and_line that should be used to insert an exception
12235    catchpoint of the TYPE kind.
12236
12237    ADDR_STRING returns the name of the function where the real
12238    breakpoint that implements the catchpoints is set, depending on the
12239    type of catchpoint we need to create.  */
12240
12241 static struct symtab_and_line
12242 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12243                    std::string *addr_string, const struct breakpoint_ops **ops)
12244 {
12245   const char *sym_name;
12246   struct symbol *sym;
12247
12248   /* First, find out which exception support info to use.  */
12249   ada_exception_support_info_sniffer ();
12250
12251   /* Then lookup the function on which we will break in order to catch
12252      the Ada exceptions requested by the user.  */
12253   sym_name = ada_exception_sym_name (ex);
12254   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12255
12256   if (sym == NULL)
12257     error (_("Catchpoint symbol not found: %s"), sym_name);
12258
12259   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12260     error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12261
12262   /* Set ADDR_STRING.  */
12263   *addr_string = sym_name;
12264
12265   /* Set OPS.  */
12266   *ops = ada_exception_breakpoint_ops (ex);
12267
12268   return find_function_start_sal (sym, 1);
12269 }
12270
12271 /* Create an Ada exception catchpoint.
12272
12273    EX_KIND is the kind of exception catchpoint to be created.
12274
12275    If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12276    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
12277    of the exception to which this catchpoint applies.
12278
12279    COND_STRING, if not empty, is the catchpoint condition.
12280
12281    TEMPFLAG, if nonzero, means that the underlying breakpoint
12282    should be temporary.
12283
12284    FROM_TTY is the usual argument passed to all commands implementations.  */
12285
12286 void
12287 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12288                                  enum ada_exception_catchpoint_kind ex_kind,
12289                                  const std::string &excep_string,
12290                                  const std::string &cond_string,
12291                                  int tempflag,
12292                                  int disabled,
12293                                  int from_tty)
12294 {
12295   std::string addr_string;
12296   const struct breakpoint_ops *ops = NULL;
12297   struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
12298
12299   std::unique_ptr<ada_catchpoint> c (new ada_catchpoint (ex_kind));
12300   init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
12301                                  ops, tempflag, disabled, from_tty);
12302   c->excep_string = excep_string;
12303   create_excep_cond_exprs (c.get (), ex_kind);
12304   if (!cond_string.empty ())
12305     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12306   install_breakpoint (0, std::move (c), 1);
12307 }
12308
12309 /* Implement the "catch exception" command.  */
12310
12311 static void
12312 catch_ada_exception_command (const char *arg_entry, int from_tty,
12313                              struct cmd_list_element *command)
12314 {
12315   const char *arg = arg_entry;
12316   struct gdbarch *gdbarch = get_current_arch ();
12317   int tempflag;
12318   enum ada_exception_catchpoint_kind ex_kind;
12319   std::string excep_string;
12320   std::string cond_string;
12321
12322   tempflag = command->context () == CATCH_TEMPORARY;
12323
12324   if (!arg)
12325     arg = "";
12326   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12327                                      &cond_string);
12328   create_ada_exception_catchpoint (gdbarch, ex_kind,
12329                                    excep_string, cond_string,
12330                                    tempflag, 1 /* enabled */,
12331                                    from_tty);
12332 }
12333
12334 /* Implement the "catch handlers" command.  */
12335
12336 static void
12337 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12338                             struct cmd_list_element *command)
12339 {
12340   const char *arg = arg_entry;
12341   struct gdbarch *gdbarch = get_current_arch ();
12342   int tempflag;
12343   enum ada_exception_catchpoint_kind ex_kind;
12344   std::string excep_string;
12345   std::string cond_string;
12346
12347   tempflag = command->context () == CATCH_TEMPORARY;
12348
12349   if (!arg)
12350     arg = "";
12351   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12352                                      &cond_string);
12353   create_ada_exception_catchpoint (gdbarch, ex_kind,
12354                                    excep_string, cond_string,
12355                                    tempflag, 1 /* enabled */,
12356                                    from_tty);
12357 }
12358
12359 /* Completion function for the Ada "catch" commands.  */
12360
12361 static void
12362 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12363                      const char *text, const char *word)
12364 {
12365   std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12366
12367   for (const ada_exc_info &info : exceptions)
12368     {
12369       if (startswith (info.name, word))
12370         tracker.add_completion (make_unique_xstrdup (info.name));
12371     }
12372 }
12373
12374 /* Split the arguments specified in a "catch assert" command.
12375
12376    ARGS contains the command's arguments (or the empty string if
12377    no arguments were passed).
12378
12379    If ARGS contains a condition, set COND_STRING to that condition
12380    (the memory needs to be deallocated after use).  */
12381
12382 static void
12383 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12384 {
12385   args = skip_spaces (args);
12386
12387   /* Check whether a condition was provided.  */
12388   if (startswith (args, "if")
12389       && (isspace (args[2]) || args[2] == '\0'))
12390     {
12391       args += 2;
12392       args = skip_spaces (args);
12393       if (args[0] == '\0')
12394         error (_("condition missing after `if' keyword"));
12395       cond_string.assign (args);
12396     }
12397
12398   /* Otherwise, there should be no other argument at the end of
12399      the command.  */
12400   else if (args[0] != '\0')
12401     error (_("Junk at end of arguments."));
12402 }
12403
12404 /* Implement the "catch assert" command.  */
12405
12406 static void
12407 catch_assert_command (const char *arg_entry, int from_tty,
12408                       struct cmd_list_element *command)
12409 {
12410   const char *arg = arg_entry;
12411   struct gdbarch *gdbarch = get_current_arch ();
12412   int tempflag;
12413   std::string cond_string;
12414
12415   tempflag = command->context () == CATCH_TEMPORARY;
12416
12417   if (!arg)
12418     arg = "";
12419   catch_ada_assert_command_split (arg, cond_string);
12420   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12421                                    "", cond_string,
12422                                    tempflag, 1 /* enabled */,
12423                                    from_tty);
12424 }
12425
12426 /* Return non-zero if the symbol SYM is an Ada exception object.  */
12427
12428 static int
12429 ada_is_exception_sym (struct symbol *sym)
12430 {
12431   const char *type_name = SYMBOL_TYPE (sym)->name ();
12432
12433   return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12434           && SYMBOL_CLASS (sym) != LOC_BLOCK
12435           && SYMBOL_CLASS (sym) != LOC_CONST
12436           && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12437           && type_name != NULL && strcmp (type_name, "exception") == 0);
12438 }
12439
12440 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12441    Ada exception object.  This matches all exceptions except the ones
12442    defined by the Ada language.  */
12443
12444 static int
12445 ada_is_non_standard_exception_sym (struct symbol *sym)
12446 {
12447   int i;
12448
12449   if (!ada_is_exception_sym (sym))
12450     return 0;
12451
12452   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12453     if (strcmp (sym->linkage_name (), standard_exc[i]) == 0)
12454       return 0;  /* A standard exception.  */
12455
12456   /* Numeric_Error is also a standard exception, so exclude it.
12457      See the STANDARD_EXC description for more details as to why
12458      this exception is not listed in that array.  */
12459   if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12460     return 0;
12461
12462   return 1;
12463 }
12464
12465 /* A helper function for std::sort, comparing two struct ada_exc_info
12466    objects.
12467
12468    The comparison is determined first by exception name, and then
12469    by exception address.  */
12470
12471 bool
12472 ada_exc_info::operator< (const ada_exc_info &other) const
12473 {
12474   int result;
12475
12476   result = strcmp (name, other.name);
12477   if (result < 0)
12478     return true;
12479   if (result == 0 && addr < other.addr)
12480     return true;
12481   return false;
12482 }
12483
12484 bool
12485 ada_exc_info::operator== (const ada_exc_info &other) const
12486 {
12487   return addr == other.addr && strcmp (name, other.name) == 0;
12488 }
12489
12490 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12491    routine, but keeping the first SKIP elements untouched.
12492
12493    All duplicates are also removed.  */
12494
12495 static void
12496 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
12497                                       int skip)
12498 {
12499   std::sort (exceptions->begin () + skip, exceptions->end ());
12500   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
12501                      exceptions->end ());
12502 }
12503
12504 /* Add all exceptions defined by the Ada standard whose name match
12505    a regular expression.
12506
12507    If PREG is not NULL, then this regexp_t object is used to
12508    perform the symbol name matching.  Otherwise, no name-based
12509    filtering is performed.
12510
12511    EXCEPTIONS is a vector of exceptions to which matching exceptions
12512    gets pushed.  */
12513
12514 static void
12515 ada_add_standard_exceptions (compiled_regex *preg,
12516                              std::vector<ada_exc_info> *exceptions)
12517 {
12518   int i;
12519
12520   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12521     {
12522       if (preg == NULL
12523           || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
12524         {
12525           struct bound_minimal_symbol msymbol
12526             = ada_lookup_simple_minsym (standard_exc[i]);
12527
12528           if (msymbol.minsym != NULL)
12529             {
12530               struct ada_exc_info info
12531                 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
12532
12533               exceptions->push_back (info);
12534             }
12535         }
12536     }
12537 }
12538
12539 /* Add all Ada exceptions defined locally and accessible from the given
12540    FRAME.
12541
12542    If PREG is not NULL, then this regexp_t object is used to
12543    perform the symbol name matching.  Otherwise, no name-based
12544    filtering is performed.
12545
12546    EXCEPTIONS is a vector of exceptions to which matching exceptions
12547    gets pushed.  */
12548
12549 static void
12550 ada_add_exceptions_from_frame (compiled_regex *preg,
12551                                struct frame_info *frame,
12552                                std::vector<ada_exc_info> *exceptions)
12553 {
12554   const struct block *block = get_frame_block (frame, 0);
12555
12556   while (block != 0)
12557     {
12558       struct block_iterator iter;
12559       struct symbol *sym;
12560
12561       ALL_BLOCK_SYMBOLS (block, iter, sym)
12562         {
12563           switch (SYMBOL_CLASS (sym))
12564             {
12565             case LOC_TYPEDEF:
12566             case LOC_BLOCK:
12567             case LOC_CONST:
12568               break;
12569             default:
12570               if (ada_is_exception_sym (sym))
12571                 {
12572                   struct ada_exc_info info = {sym->print_name (),
12573                                               SYMBOL_VALUE_ADDRESS (sym)};
12574
12575                   exceptions->push_back (info);
12576                 }
12577             }
12578         }
12579       if (BLOCK_FUNCTION (block) != NULL)
12580         break;
12581       block = BLOCK_SUPERBLOCK (block);
12582     }
12583 }
12584
12585 /* Return true if NAME matches PREG or if PREG is NULL.  */
12586
12587 static bool
12588 name_matches_regex (const char *name, compiled_regex *preg)
12589 {
12590   return (preg == NULL
12591           || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
12592 }
12593
12594 /* Add all exceptions defined globally whose name name match
12595    a regular expression, excluding standard exceptions.
12596
12597    The reason we exclude standard exceptions is that they need
12598    to be handled separately: Standard exceptions are defined inside
12599    a runtime unit which is normally not compiled with debugging info,
12600    and thus usually do not show up in our symbol search.  However,
12601    if the unit was in fact built with debugging info, we need to
12602    exclude them because they would duplicate the entry we found
12603    during the special loop that specifically searches for those
12604    standard exceptions.
12605
12606    If PREG is not NULL, then this regexp_t object is used to
12607    perform the symbol name matching.  Otherwise, no name-based
12608    filtering is performed.
12609
12610    EXCEPTIONS is a vector of exceptions to which matching exceptions
12611    gets pushed.  */
12612
12613 static void
12614 ada_add_global_exceptions (compiled_regex *preg,
12615                            std::vector<ada_exc_info> *exceptions)
12616 {
12617   /* In Ada, the symbol "search name" is a linkage name, whereas the
12618      regular expression used to do the matching refers to the natural
12619      name.  So match against the decoded name.  */
12620   expand_symtabs_matching (NULL,
12621                            lookup_name_info::match_any (),
12622                            [&] (const char *search_name)
12623                            {
12624                              std::string decoded = ada_decode (search_name);
12625                              return name_matches_regex (decoded.c_str (), preg);
12626                            },
12627                            NULL,
12628                            SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
12629                            VARIABLES_DOMAIN);
12630
12631   for (objfile *objfile : current_program_space->objfiles ())
12632     {
12633       for (compunit_symtab *s : objfile->compunits ())
12634         {
12635           const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
12636           int i;
12637
12638           for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
12639             {
12640               const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
12641               struct block_iterator iter;
12642               struct symbol *sym;
12643
12644               ALL_BLOCK_SYMBOLS (b, iter, sym)
12645                 if (ada_is_non_standard_exception_sym (sym)
12646                     && name_matches_regex (sym->natural_name (), preg))
12647                   {
12648                     struct ada_exc_info info
12649                       = {sym->print_name (), SYMBOL_VALUE_ADDRESS (sym)};
12650
12651                     exceptions->push_back (info);
12652                   }
12653             }
12654         }
12655     }
12656 }
12657
12658 /* Implements ada_exceptions_list with the regular expression passed
12659    as a regex_t, rather than a string.
12660
12661    If not NULL, PREG is used to filter out exceptions whose names
12662    do not match.  Otherwise, all exceptions are listed.  */
12663
12664 static std::vector<ada_exc_info>
12665 ada_exceptions_list_1 (compiled_regex *preg)
12666 {
12667   std::vector<ada_exc_info> result;
12668   int prev_len;
12669
12670   /* First, list the known standard exceptions.  These exceptions
12671      need to be handled separately, as they are usually defined in
12672      runtime units that have been compiled without debugging info.  */
12673
12674   ada_add_standard_exceptions (preg, &result);
12675
12676   /* Next, find all exceptions whose scope is local and accessible
12677      from the currently selected frame.  */
12678
12679   if (has_stack_frames ())
12680     {
12681       prev_len = result.size ();
12682       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
12683                                      &result);
12684       if (result.size () > prev_len)
12685         sort_remove_dups_ada_exceptions_list (&result, prev_len);
12686     }
12687
12688   /* Add all exceptions whose scope is global.  */
12689
12690   prev_len = result.size ();
12691   ada_add_global_exceptions (preg, &result);
12692   if (result.size () > prev_len)
12693     sort_remove_dups_ada_exceptions_list (&result, prev_len);
12694
12695   return result;
12696 }
12697
12698 /* Return a vector of ada_exc_info.
12699
12700    If REGEXP is NULL, all exceptions are included in the result.
12701    Otherwise, it should contain a valid regular expression,
12702    and only the exceptions whose names match that regular expression
12703    are included in the result.
12704
12705    The exceptions are sorted in the following order:
12706      - Standard exceptions (defined by the Ada language), in
12707        alphabetical order;
12708      - Exceptions only visible from the current frame, in
12709        alphabetical order;
12710      - Exceptions whose scope is global, in alphabetical order.  */
12711
12712 std::vector<ada_exc_info>
12713 ada_exceptions_list (const char *regexp)
12714 {
12715   if (regexp == NULL)
12716     return ada_exceptions_list_1 (NULL);
12717
12718   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
12719   return ada_exceptions_list_1 (&reg);
12720 }
12721
12722 /* Implement the "info exceptions" command.  */
12723
12724 static void
12725 info_exceptions_command (const char *regexp, int from_tty)
12726 {
12727   struct gdbarch *gdbarch = get_current_arch ();
12728
12729   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
12730
12731   if (regexp != NULL)
12732     printf_filtered
12733       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
12734   else
12735     printf_filtered (_("All defined Ada exceptions:\n"));
12736
12737   for (const ada_exc_info &info : exceptions)
12738     printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
12739 }
12740
12741 \f
12742                                 /* Language vector */
12743
12744 /* symbol_name_matcher_ftype adapter for wild_match.  */
12745
12746 static bool
12747 do_wild_match (const char *symbol_search_name,
12748                const lookup_name_info &lookup_name,
12749                completion_match_result *comp_match_res)
12750 {
12751   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
12752 }
12753
12754 /* symbol_name_matcher_ftype adapter for full_match.  */
12755
12756 static bool
12757 do_full_match (const char *symbol_search_name,
12758                const lookup_name_info &lookup_name,
12759                completion_match_result *comp_match_res)
12760 {
12761   const char *lname = lookup_name.ada ().lookup_name ().c_str ();
12762
12763   /* If both symbols start with "_ada_", just let the loop below
12764      handle the comparison.  However, if only the symbol name starts
12765      with "_ada_", skip the prefix and let the match proceed as
12766      usual.  */
12767   if (startswith (symbol_search_name, "_ada_")
12768       && !startswith (lname, "_ada"))
12769     symbol_search_name += 5;
12770
12771   int uscore_count = 0;
12772   while (*lname != '\0')
12773     {
12774       if (*symbol_search_name != *lname)
12775         {
12776           if (*symbol_search_name == 'B' && uscore_count == 2
12777               && symbol_search_name[1] == '_')
12778             {
12779               symbol_search_name += 2;
12780               while (isdigit (*symbol_search_name))
12781                 ++symbol_search_name;
12782               if (symbol_search_name[0] == '_'
12783                   && symbol_search_name[1] == '_')
12784                 {
12785                   symbol_search_name += 2;
12786                   continue;
12787                 }
12788             }
12789           return false;
12790         }
12791
12792       if (*symbol_search_name == '_')
12793         ++uscore_count;
12794       else
12795         uscore_count = 0;
12796
12797       ++symbol_search_name;
12798       ++lname;
12799     }
12800
12801   return is_name_suffix (symbol_search_name);
12802 }
12803
12804 /* symbol_name_matcher_ftype for exact (verbatim) matches.  */
12805
12806 static bool
12807 do_exact_match (const char *symbol_search_name,
12808                 const lookup_name_info &lookup_name,
12809                 completion_match_result *comp_match_res)
12810 {
12811   return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
12812 }
12813
12814 /* Build the Ada lookup name for LOOKUP_NAME.  */
12815
12816 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
12817 {
12818   gdb::string_view user_name = lookup_name.name ();
12819
12820   if (!user_name.empty () && user_name[0] == '<')
12821     {
12822       if (user_name.back () == '>')
12823         m_encoded_name
12824           = gdb::to_string (user_name.substr (1, user_name.size () - 2));
12825       else
12826         m_encoded_name
12827           = gdb::to_string (user_name.substr (1, user_name.size () - 1));
12828       m_encoded_p = true;
12829       m_verbatim_p = true;
12830       m_wild_match_p = false;
12831       m_standard_p = false;
12832     }
12833   else
12834     {
12835       m_verbatim_p = false;
12836
12837       m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
12838
12839       if (!m_encoded_p)
12840         {
12841           const char *folded = ada_fold_name (user_name);
12842           m_encoded_name = ada_encode_1 (folded, false);
12843           if (m_encoded_name.empty ())
12844             m_encoded_name = gdb::to_string (user_name);
12845         }
12846       else
12847         m_encoded_name = gdb::to_string (user_name);
12848
12849       /* Handle the 'package Standard' special case.  See description
12850          of m_standard_p.  */
12851       if (startswith (m_encoded_name.c_str (), "standard__"))
12852         {
12853           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
12854           m_standard_p = true;
12855         }
12856       else
12857         m_standard_p = false;
12858
12859       /* If the name contains a ".", then the user is entering a fully
12860          qualified entity name, and the match must not be done in wild
12861          mode.  Similarly, if the user wants to complete what looks
12862          like an encoded name, the match must not be done in wild
12863          mode.  Also, in the standard__ special case always do
12864          non-wild matching.  */
12865       m_wild_match_p
12866         = (lookup_name.match_type () != symbol_name_match_type::FULL
12867            && !m_encoded_p
12868            && !m_standard_p
12869            && user_name.find ('.') == std::string::npos);
12870     }
12871 }
12872
12873 /* symbol_name_matcher_ftype method for Ada.  This only handles
12874    completion mode.  */
12875
12876 static bool
12877 ada_symbol_name_matches (const char *symbol_search_name,
12878                          const lookup_name_info &lookup_name,
12879                          completion_match_result *comp_match_res)
12880 {
12881   return lookup_name.ada ().matches (symbol_search_name,
12882                                      lookup_name.match_type (),
12883                                      comp_match_res);
12884 }
12885
12886 /* A name matcher that matches the symbol name exactly, with
12887    strcmp.  */
12888
12889 static bool
12890 literal_symbol_name_matcher (const char *symbol_search_name,
12891                              const lookup_name_info &lookup_name,
12892                              completion_match_result *comp_match_res)
12893 {
12894   gdb::string_view name_view = lookup_name.name ();
12895
12896   if (lookup_name.completion_mode ()
12897       ? (strncmp (symbol_search_name, name_view.data (),
12898                   name_view.size ()) == 0)
12899       : symbol_search_name == name_view)
12900     {
12901       if (comp_match_res != NULL)
12902         comp_match_res->set_match (symbol_search_name);
12903       return true;
12904     }
12905   else
12906     return false;
12907 }
12908
12909 /* Implement the "get_symbol_name_matcher" language_defn method for
12910    Ada.  */
12911
12912 static symbol_name_matcher_ftype *
12913 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
12914 {
12915   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
12916     return literal_symbol_name_matcher;
12917
12918   if (lookup_name.completion_mode ())
12919     return ada_symbol_name_matches;
12920   else
12921     {
12922       if (lookup_name.ada ().wild_match_p ())
12923         return do_wild_match;
12924       else if (lookup_name.ada ().verbatim_p ())
12925         return do_exact_match;
12926       else
12927         return do_full_match;
12928     }
12929 }
12930
12931 /* Class representing the Ada language.  */
12932
12933 class ada_language : public language_defn
12934 {
12935 public:
12936   ada_language ()
12937     : language_defn (language_ada)
12938   { /* Nothing.  */ }
12939
12940   /* See language.h.  */
12941
12942   const char *name () const override
12943   { return "ada"; }
12944
12945   /* See language.h.  */
12946
12947   const char *natural_name () const override
12948   { return "Ada"; }
12949
12950   /* See language.h.  */
12951
12952   const std::vector<const char *> &filename_extensions () const override
12953   {
12954     static const std::vector<const char *> extensions
12955       = { ".adb", ".ads", ".a", ".ada", ".dg" };
12956     return extensions;
12957   }
12958
12959   /* Print an array element index using the Ada syntax.  */
12960
12961   void print_array_index (struct type *index_type,
12962                           LONGEST index,
12963                           struct ui_file *stream,
12964                           const value_print_options *options) const override
12965   {
12966     struct value *index_value = val_atr (index_type, index);
12967
12968     value_print (index_value, stream, options);
12969     fprintf_filtered (stream, " => ");
12970   }
12971
12972   /* Implement the "read_var_value" language_defn method for Ada.  */
12973
12974   struct value *read_var_value (struct symbol *var,
12975                                 const struct block *var_block,
12976                                 struct frame_info *frame) const override
12977   {
12978     /* The only case where default_read_var_value is not sufficient
12979        is when VAR is a renaming...  */
12980     if (frame != nullptr)
12981       {
12982         const struct block *frame_block = get_frame_block (frame, NULL);
12983         if (frame_block != nullptr && ada_is_renaming_symbol (var))
12984           return ada_read_renaming_var_value (var, frame_block);
12985       }
12986
12987     /* This is a typical case where we expect the default_read_var_value
12988        function to work.  */
12989     return language_defn::read_var_value (var, var_block, frame);
12990   }
12991
12992   /* See language.h.  */
12993   virtual bool symbol_printing_suppressed (struct symbol *symbol) const override
12994   {
12995     return symbol->artificial;
12996   }
12997
12998   /* See language.h.  */
12999   void language_arch_info (struct gdbarch *gdbarch,
13000                            struct language_arch_info *lai) const override
13001   {
13002     const struct builtin_type *builtin = builtin_type (gdbarch);
13003
13004     /* Helper function to allow shorter lines below.  */
13005     auto add = [&] (struct type *t)
13006     {
13007       lai->add_primitive_type (t);
13008     };
13009
13010     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13011                             0, "integer"));
13012     add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13013                             0, "long_integer"));
13014     add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13015                             0, "short_integer"));
13016     struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
13017                                                   0, "character");
13018     lai->set_string_char_type (char_type);
13019     add (char_type);
13020     add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13021                           "float", gdbarch_float_format (gdbarch)));
13022     add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13023                           "long_float", gdbarch_double_format (gdbarch)));
13024     add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13025                             0, "long_long_integer"));
13026     add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13027                           "long_long_float",
13028                           gdbarch_long_double_format (gdbarch)));
13029     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13030                             0, "natural"));
13031     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13032                             0, "positive"));
13033     add (builtin->builtin_void);
13034
13035     struct type *system_addr_ptr
13036       = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13037                                         "void"));
13038     system_addr_ptr->set_name ("system__address");
13039     add (system_addr_ptr);
13040
13041     /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13042        type.  This is a signed integral type whose size is the same as
13043        the size of addresses.  */
13044     unsigned int addr_length = TYPE_LENGTH (system_addr_ptr);
13045     add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13046                             "storage_offset"));
13047
13048     lai->set_bool_type (builtin->builtin_bool);
13049   }
13050
13051   /* See language.h.  */
13052
13053   bool iterate_over_symbols
13054         (const struct block *block, const lookup_name_info &name,
13055          domain_enum domain,
13056          gdb::function_view<symbol_found_callback_ftype> callback) const override
13057   {
13058     std::vector<struct block_symbol> results
13059       = ada_lookup_symbol_list_worker (name, block, domain, 0);
13060     for (block_symbol &sym : results)
13061       {
13062         if (!callback (&sym))
13063           return false;
13064       }
13065
13066     return true;
13067   }
13068
13069   /* See language.h.  */
13070   bool sniff_from_mangled_name
13071        (const char *mangled,
13072         gdb::unique_xmalloc_ptr<char> *out) const override
13073   {
13074     std::string demangled = ada_decode (mangled);
13075
13076     *out = NULL;
13077
13078     if (demangled != mangled && demangled[0] != '<')
13079       {
13080         /* Set the gsymbol language to Ada, but still return 0.
13081            Two reasons for that:
13082
13083            1. For Ada, we prefer computing the symbol's decoded name
13084            on the fly rather than pre-compute it, in order to save
13085            memory (Ada projects are typically very large).
13086
13087            2. There are some areas in the definition of the GNAT
13088            encoding where, with a bit of bad luck, we might be able
13089            to decode a non-Ada symbol, generating an incorrect
13090            demangled name (Eg: names ending with "TB" for instance
13091            are identified as task bodies and so stripped from
13092            the decoded name returned).
13093
13094            Returning true, here, but not setting *DEMANGLED, helps us get
13095            a little bit of the best of both worlds.  Because we're last,
13096            we should not affect any of the other languages that were
13097            able to demangle the symbol before us; we get to correctly
13098            tag Ada symbols as such; and even if we incorrectly tagged a
13099            non-Ada symbol, which should be rare, any routing through the
13100            Ada language should be transparent (Ada tries to behave much
13101            like C/C++ with non-Ada symbols).  */
13102         return true;
13103       }
13104
13105     return false;
13106   }
13107
13108   /* See language.h.  */
13109
13110   gdb::unique_xmalloc_ptr<char> demangle_symbol (const char *mangled,
13111                                                  int options) const override
13112   {
13113     return make_unique_xstrdup (ada_decode (mangled).c_str ());
13114   }
13115
13116   /* See language.h.  */
13117
13118   void print_type (struct type *type, const char *varstring,
13119                    struct ui_file *stream, int show, int level,
13120                    const struct type_print_options *flags) const override
13121   {
13122     ada_print_type (type, varstring, stream, show, level, flags);
13123   }
13124
13125   /* See language.h.  */
13126
13127   const char *word_break_characters (void) const override
13128   {
13129     return ada_completer_word_break_characters;
13130   }
13131
13132   /* See language.h.  */
13133
13134   void collect_symbol_completion_matches (completion_tracker &tracker,
13135                                           complete_symbol_mode mode,
13136                                           symbol_name_match_type name_match_type,
13137                                           const char *text, const char *word,
13138                                           enum type_code code) const override
13139   {
13140     struct symbol *sym;
13141     const struct block *b, *surrounding_static_block = 0;
13142     struct block_iterator iter;
13143
13144     gdb_assert (code == TYPE_CODE_UNDEF);
13145
13146     lookup_name_info lookup_name (text, name_match_type, true);
13147
13148     /* First, look at the partial symtab symbols.  */
13149     expand_symtabs_matching (NULL,
13150                              lookup_name,
13151                              NULL,
13152                              NULL,
13153                              SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13154                              ALL_DOMAIN);
13155
13156     /* At this point scan through the misc symbol vectors and add each
13157        symbol you find to the list.  Eventually we want to ignore
13158        anything that isn't a text symbol (everything else will be
13159        handled by the psymtab code above).  */
13160
13161     for (objfile *objfile : current_program_space->objfiles ())
13162       {
13163         for (minimal_symbol *msymbol : objfile->msymbols ())
13164           {
13165             QUIT;
13166
13167             if (completion_skip_symbol (mode, msymbol))
13168               continue;
13169
13170             language symbol_language = msymbol->language ();
13171
13172             /* Ada minimal symbols won't have their language set to Ada.  If
13173                we let completion_list_add_name compare using the
13174                default/C-like matcher, then when completing e.g., symbols in a
13175                package named "pck", we'd match internal Ada symbols like
13176                "pckS", which are invalid in an Ada expression, unless you wrap
13177                them in '<' '>' to request a verbatim match.
13178
13179                Unfortunately, some Ada encoded names successfully demangle as
13180                C++ symbols (using an old mangling scheme), such as "name__2Xn"
13181                -> "Xn::name(void)" and thus some Ada minimal symbols end up
13182                with the wrong language set.  Paper over that issue here.  */
13183             if (symbol_language == language_auto
13184                 || symbol_language == language_cplus)
13185               symbol_language = language_ada;
13186
13187             completion_list_add_name (tracker,
13188                                       symbol_language,
13189                                       msymbol->linkage_name (),
13190                                       lookup_name, text, word);
13191           }
13192       }
13193
13194     /* Search upwards from currently selected frame (so that we can
13195        complete on local vars.  */
13196
13197     for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
13198       {
13199         if (!BLOCK_SUPERBLOCK (b))
13200           surrounding_static_block = b;   /* For elmin of dups */
13201
13202         ALL_BLOCK_SYMBOLS (b, iter, sym)
13203           {
13204             if (completion_skip_symbol (mode, sym))
13205               continue;
13206
13207             completion_list_add_name (tracker,
13208                                       sym->language (),
13209                                       sym->linkage_name (),
13210                                       lookup_name, text, word);
13211           }
13212       }
13213
13214     /* Go through the symtabs and check the externs and statics for
13215        symbols which match.  */
13216
13217     for (objfile *objfile : current_program_space->objfiles ())
13218       {
13219         for (compunit_symtab *s : objfile->compunits ())
13220           {
13221             QUIT;
13222             b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
13223             ALL_BLOCK_SYMBOLS (b, iter, sym)
13224               {
13225                 if (completion_skip_symbol (mode, sym))
13226                   continue;
13227
13228                 completion_list_add_name (tracker,
13229                                           sym->language (),
13230                                           sym->linkage_name (),
13231                                           lookup_name, text, word);
13232               }
13233           }
13234       }
13235
13236     for (objfile *objfile : current_program_space->objfiles ())
13237       {
13238         for (compunit_symtab *s : objfile->compunits ())
13239           {
13240             QUIT;
13241             b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
13242             /* Don't do this block twice.  */
13243             if (b == surrounding_static_block)
13244               continue;
13245             ALL_BLOCK_SYMBOLS (b, iter, sym)
13246               {
13247                 if (completion_skip_symbol (mode, sym))
13248                   continue;
13249
13250                 completion_list_add_name (tracker,
13251                                           sym->language (),
13252                                           sym->linkage_name (),
13253                                           lookup_name, text, word);
13254               }
13255           }
13256       }
13257   }
13258
13259   /* See language.h.  */
13260
13261   gdb::unique_xmalloc_ptr<char> watch_location_expression
13262         (struct type *type, CORE_ADDR addr) const override
13263   {
13264     type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
13265     std::string name = type_to_string (type);
13266     return gdb::unique_xmalloc_ptr<char>
13267       (xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr)));
13268   }
13269
13270   /* See language.h.  */
13271
13272   void value_print (struct value *val, struct ui_file *stream,
13273                     const struct value_print_options *options) const override
13274   {
13275     return ada_value_print (val, stream, options);
13276   }
13277
13278   /* See language.h.  */
13279
13280   void value_print_inner
13281         (struct value *val, struct ui_file *stream, int recurse,
13282          const struct value_print_options *options) const override
13283   {
13284     return ada_value_print_inner (val, stream, recurse, options);
13285   }
13286
13287   /* See language.h.  */
13288
13289   struct block_symbol lookup_symbol_nonlocal
13290         (const char *name, const struct block *block,
13291          const domain_enum domain) const override
13292   {
13293     struct block_symbol sym;
13294
13295     sym = ada_lookup_symbol (name, block_static_block (block), domain);
13296     if (sym.symbol != NULL)
13297       return sym;
13298
13299     /* If we haven't found a match at this point, try the primitive
13300        types.  In other languages, this search is performed before
13301        searching for global symbols in order to short-circuit that
13302        global-symbol search if it happens that the name corresponds
13303        to a primitive type.  But we cannot do the same in Ada, because
13304        it is perfectly legitimate for a program to declare a type which
13305        has the same name as a standard type.  If looking up a type in
13306        that situation, we have traditionally ignored the primitive type
13307        in favor of user-defined types.  This is why, unlike most other
13308        languages, we search the primitive types this late and only after
13309        having searched the global symbols without success.  */
13310
13311     if (domain == VAR_DOMAIN)
13312       {
13313         struct gdbarch *gdbarch;
13314
13315         if (block == NULL)
13316           gdbarch = target_gdbarch ();
13317         else
13318           gdbarch = block_gdbarch (block);
13319         sym.symbol
13320           = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13321         if (sym.symbol != NULL)
13322           return sym;
13323       }
13324
13325     return {};
13326   }
13327
13328   /* See language.h.  */
13329
13330   int parser (struct parser_state *ps) const override
13331   {
13332     warnings_issued = 0;
13333     return ada_parse (ps);
13334   }
13335
13336   /* See language.h.  */
13337
13338   void emitchar (int ch, struct type *chtype,
13339                  struct ui_file *stream, int quoter) const override
13340   {
13341     ada_emit_char (ch, chtype, stream, quoter, 1);
13342   }
13343
13344   /* See language.h.  */
13345
13346   void printchar (int ch, struct type *chtype,
13347                   struct ui_file *stream) const override
13348   {
13349     ada_printchar (ch, chtype, stream);
13350   }
13351
13352   /* See language.h.  */
13353
13354   void printstr (struct ui_file *stream, struct type *elttype,
13355                  const gdb_byte *string, unsigned int length,
13356                  const char *encoding, int force_ellipses,
13357                  const struct value_print_options *options) const override
13358   {
13359     ada_printstr (stream, elttype, string, length, encoding,
13360                   force_ellipses, options);
13361   }
13362
13363   /* See language.h.  */
13364
13365   void print_typedef (struct type *type, struct symbol *new_symbol,
13366                       struct ui_file *stream) const override
13367   {
13368     ada_print_typedef (type, new_symbol, stream);
13369   }
13370
13371   /* See language.h.  */
13372
13373   bool is_string_type_p (struct type *type) const override
13374   {
13375     return ada_is_string_type (type);
13376   }
13377
13378   /* See language.h.  */
13379
13380   const char *struct_too_deep_ellipsis () const override
13381   { return "(...)"; }
13382
13383   /* See language.h.  */
13384
13385   bool c_style_arrays_p () const override
13386   { return false; }
13387
13388   /* See language.h.  */
13389
13390   bool store_sym_names_in_linkage_form_p () const override
13391   { return true; }
13392
13393   /* See language.h.  */
13394
13395   const struct lang_varobj_ops *varobj_ops () const override
13396   { return &ada_varobj_ops; }
13397
13398 protected:
13399   /* See language.h.  */
13400
13401   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13402         (const lookup_name_info &lookup_name) const override
13403   {
13404     return ada_get_symbol_name_matcher (lookup_name);
13405   }
13406 };
13407
13408 /* Single instance of the Ada language class.  */
13409
13410 static ada_language ada_language_defn;
13411
13412 /* Command-list for the "set/show ada" prefix command.  */
13413 static struct cmd_list_element *set_ada_list;
13414 static struct cmd_list_element *show_ada_list;
13415
13416 static void
13417 initialize_ada_catchpoint_ops (void)
13418 {
13419   struct breakpoint_ops *ops;
13420
13421   initialize_breakpoint_ops ();
13422
13423   ops = &catch_exception_breakpoint_ops;
13424   *ops = bkpt_breakpoint_ops;
13425   ops->allocate_location = allocate_location_exception;
13426   ops->re_set = re_set_exception;
13427   ops->check_status = check_status_exception;
13428   ops->print_it = print_it_exception;
13429   ops->print_one = print_one_exception;
13430   ops->print_mention = print_mention_exception;
13431   ops->print_recreate = print_recreate_exception;
13432
13433   ops = &catch_exception_unhandled_breakpoint_ops;
13434   *ops = bkpt_breakpoint_ops;
13435   ops->allocate_location = allocate_location_exception;
13436   ops->re_set = re_set_exception;
13437   ops->check_status = check_status_exception;
13438   ops->print_it = print_it_exception;
13439   ops->print_one = print_one_exception;
13440   ops->print_mention = print_mention_exception;
13441   ops->print_recreate = print_recreate_exception;
13442
13443   ops = &catch_assert_breakpoint_ops;
13444   *ops = bkpt_breakpoint_ops;
13445   ops->allocate_location = allocate_location_exception;
13446   ops->re_set = re_set_exception;
13447   ops->check_status = check_status_exception;
13448   ops->print_it = print_it_exception;
13449   ops->print_one = print_one_exception;
13450   ops->print_mention = print_mention_exception;
13451   ops->print_recreate = print_recreate_exception;
13452
13453   ops = &catch_handlers_breakpoint_ops;
13454   *ops = bkpt_breakpoint_ops;
13455   ops->allocate_location = allocate_location_exception;
13456   ops->re_set = re_set_exception;
13457   ops->check_status = check_status_exception;
13458   ops->print_it = print_it_exception;
13459   ops->print_one = print_one_exception;
13460   ops->print_mention = print_mention_exception;
13461   ops->print_recreate = print_recreate_exception;
13462 }
13463
13464 /* This module's 'new_objfile' observer.  */
13465
13466 static void
13467 ada_new_objfile_observer (struct objfile *objfile)
13468 {
13469   ada_clear_symbol_cache ();
13470 }
13471
13472 /* This module's 'free_objfile' observer.  */
13473
13474 static void
13475 ada_free_objfile_observer (struct objfile *objfile)
13476 {
13477   ada_clear_symbol_cache ();
13478 }
13479
13480 void _initialize_ada_language ();
13481 void
13482 _initialize_ada_language ()
13483 {
13484   initialize_ada_catchpoint_ops ();
13485
13486   add_basic_prefix_cmd ("ada", no_class,
13487                         _("Prefix command for changing Ada-specific settings."),
13488                         &set_ada_list, 0, &setlist);
13489
13490   add_show_prefix_cmd ("ada", no_class,
13491                        _("Generic command for showing Ada-specific settings."),
13492                        &show_ada_list, 0, &showlist);
13493
13494   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13495                            &trust_pad_over_xvs, _("\
13496 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13497 Show whether an optimization trusting PAD types over XVS types is activated."),
13498                            _("\
13499 This is related to the encoding used by the GNAT compiler.  The debugger\n\
13500 should normally trust the contents of PAD types, but certain older versions\n\
13501 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13502 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
13503 work around this bug.  It is always safe to turn this option \"off\", but\n\
13504 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13505 this option to \"off\" unless necessary."),
13506                             NULL, NULL, &set_ada_list, &show_ada_list);
13507
13508   add_setshow_boolean_cmd ("print-signatures", class_vars,
13509                            &print_signatures, _("\
13510 Enable or disable the output of formal and return types for functions in the \
13511 overloads selection menu."), _("\
13512 Show whether the output of formal and return types for functions in the \
13513 overloads selection menu is activated."),
13514                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
13515
13516   add_catch_command ("exception", _("\
13517 Catch Ada exceptions, when raised.\n\
13518 Usage: catch exception [ARG] [if CONDITION]\n\
13519 Without any argument, stop when any Ada exception is raised.\n\
13520 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
13521 being raised does not have a handler (and will therefore lead to the task's\n\
13522 termination).\n\
13523 Otherwise, the catchpoint only stops when the name of the exception being\n\
13524 raised is the same as ARG.\n\
13525 CONDITION is a boolean expression that is evaluated to see whether the\n\
13526 exception should cause a stop."),
13527                      catch_ada_exception_command,
13528                      catch_ada_completer,
13529                      CATCH_PERMANENT,
13530                      CATCH_TEMPORARY);
13531
13532   add_catch_command ("handlers", _("\
13533 Catch Ada exceptions, when handled.\n\
13534 Usage: catch handlers [ARG] [if CONDITION]\n\
13535 Without any argument, stop when any Ada exception is handled.\n\
13536 With an argument, catch only exceptions with the given name.\n\
13537 CONDITION is a boolean expression that is evaluated to see whether the\n\
13538 exception should cause a stop."),
13539                      catch_ada_handlers_command,
13540                      catch_ada_completer,
13541                      CATCH_PERMANENT,
13542                      CATCH_TEMPORARY);
13543   add_catch_command ("assert", _("\
13544 Catch failed Ada assertions, when raised.\n\
13545 Usage: catch assert [if CONDITION]\n\
13546 CONDITION is a boolean expression that is evaluated to see whether the\n\
13547 exception should cause a stop."),
13548                      catch_assert_command,
13549                      NULL,
13550                      CATCH_PERMANENT,
13551                      CATCH_TEMPORARY);
13552
13553   add_info ("exceptions", info_exceptions_command,
13554             _("\
13555 List all Ada exception names.\n\
13556 Usage: info exceptions [REGEXP]\n\
13557 If a regular expression is passed as an argument, only those matching\n\
13558 the regular expression are listed."));
13559
13560   add_basic_prefix_cmd ("ada", class_maintenance,
13561                         _("Set Ada maintenance-related variables."),
13562                         &maint_set_ada_cmdlist,
13563                         0/*allow-unknown*/, &maintenance_set_cmdlist);
13564
13565   add_show_prefix_cmd ("ada", class_maintenance,
13566                        _("Show Ada maintenance-related variables."),
13567                        &maint_show_ada_cmdlist,
13568                        0/*allow-unknown*/, &maintenance_show_cmdlist);
13569
13570   add_setshow_boolean_cmd
13571     ("ignore-descriptive-types", class_maintenance,
13572      &ada_ignore_descriptive_types_p,
13573      _("Set whether descriptive types generated by GNAT should be ignored."),
13574      _("Show whether descriptive types generated by GNAT should be ignored."),
13575      _("\
13576 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13577 DWARF attribute."),
13578      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
13579
13580   decoded_names_store = htab_create_alloc (256, htab_hash_string,
13581                                            htab_eq_string,
13582                                            NULL, xcalloc, xfree);
13583
13584   /* The ada-lang observers.  */
13585   gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
13586   gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
13587   gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");
13588 }
This page took 0.807362 seconds and 4 git commands to generate.