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