]> Git Repo - binutils.git/blob - gdb/ada-lang.c
gdb: change functions returning value contents to use gdb::array_view
[binutils.git] / gdb / ada-lang.c
1 /* Ada language support routines for GDB, the GNU debugger.
2
3    Copyright (C) 1992-2021 Free Software Foundation, Inc.
4
5    This file is part of GDB.
6
7    This program is free software; you can redistribute it and/or modify
8    it under the terms of the GNU General Public License as published by
9    the Free Software Foundation; either version 3 of the License, or
10    (at your option) any later version.
11
12    This program is distributed in the hope that it will be useful,
13    but WITHOUT ANY WARRANTY; without even the implied warranty of
14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15    GNU General Public License for more details.
16
17    You should have received a copy of the GNU General Public License
18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
19
20
21 #include "defs.h"
22 #include <ctype.h>
23 #include "gdb_regex.h"
24 #include "frame.h"
25 #include "symtab.h"
26 #include "gdbtypes.h"
27 #include "gdbcmd.h"
28 #include "expression.h"
29 #include "parser-defs.h"
30 #include "language.h"
31 #include "varobj.h"
32 #include "inferior.h"
33 #include "symfile.h"
34 #include "objfiles.h"
35 #include "breakpoint.h"
36 #include "gdbcore.h"
37 #include "hashtab.h"
38 #include "gdb_obstack.h"
39 #include "ada-lang.h"
40 #include "completer.h"
41 #include "ui-out.h"
42 #include "block.h"
43 #include "infcall.h"
44 #include "annotate.h"
45 #include "valprint.h"
46 #include "source.h"
47 #include "observable.h"
48 #include "stack.h"
49 #include "typeprint.h"
50 #include "namespace.h"
51 #include "cli/cli-style.h"
52 #include "cli/cli-decode.h"
53
54 #include "value.h"
55 #include "mi/mi-common.h"
56 #include "arch-utils.h"
57 #include "cli/cli-utils.h"
58 #include "gdbsupport/function-view.h"
59 #include "gdbsupport/byte-vector.h"
60 #include <algorithm>
61 #include "ada-exp.h"
62
63 /* Define whether or not the C operator '/' truncates towards zero for
64    differently signed operands (truncation direction is undefined in C).
65    Copied from valarith.c.  */
66
67 #ifndef TRUNCATION_TOWARDS_ZERO
68 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
69 #endif
70
71 static struct type *desc_base_type (struct type *);
72
73 static struct type *desc_bounds_type (struct type *);
74
75 static struct value *desc_bounds (struct value *);
76
77 static int fat_pntr_bounds_bitpos (struct type *);
78
79 static int fat_pntr_bounds_bitsize (struct type *);
80
81 static struct type *desc_data_target_type (struct type *);
82
83 static struct value *desc_data (struct value *);
84
85 static int fat_pntr_data_bitpos (struct type *);
86
87 static int fat_pntr_data_bitsize (struct type *);
88
89 static struct value *desc_one_bound (struct value *, int, int);
90
91 static int desc_bound_bitpos (struct type *, int, int);
92
93 static int desc_bound_bitsize (struct type *, int, int);
94
95 static struct type *desc_index_type (struct type *, int);
96
97 static int desc_arity (struct type *);
98
99 static int ada_args_match (struct symbol *, struct value **, int);
100
101 static struct value *make_array_descriptor (struct type *, struct value *);
102
103 static void ada_add_block_symbols (std::vector<struct block_symbol> &,
104                                    const struct block *,
105                                    const lookup_name_info &lookup_name,
106                                    domain_enum, struct objfile *);
107
108 static void ada_add_all_symbols (std::vector<struct block_symbol> &,
109                                  const struct block *,
110                                  const lookup_name_info &lookup_name,
111                                  domain_enum, int, int *);
112
113 static int is_nonfunction (const std::vector<struct block_symbol> &);
114
115 static void add_defn_to_vec (std::vector<struct block_symbol> &,
116                              struct symbol *,
117                              const struct block *);
118
119 static int possible_user_operator_p (enum exp_opcode, struct value **);
120
121 static const char *ada_decoded_op_name (enum exp_opcode);
122
123 static int numeric_type_p (struct type *);
124
125 static int integer_type_p (struct type *);
126
127 static int scalar_type_p (struct type *);
128
129 static int discrete_type_p (struct type *);
130
131 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
132                                                 int, int);
133
134 static struct type *ada_find_parallel_type_with_name (struct type *,
135                                                       const char *);
136
137 static int is_dynamic_field (struct type *, int);
138
139 static struct type *to_fixed_variant_branch_type (struct type *,
140                                                   const gdb_byte *,
141                                                   CORE_ADDR, struct value *);
142
143 static struct type *to_fixed_array_type (struct type *, struct value *, int);
144
145 static struct type *to_fixed_range_type (struct type *, struct value *);
146
147 static struct type *to_static_fixed_type (struct type *);
148 static struct type *static_unwrap_type (struct type *type);
149
150 static struct value *unwrap_value (struct value *);
151
152 static struct type *constrained_packed_array_type (struct type *, long *);
153
154 static struct type *decode_constrained_packed_array_type (struct type *);
155
156 static long decode_packed_array_bitsize (struct type *);
157
158 static struct value *decode_constrained_packed_array (struct value *);
159
160 static int ada_is_unconstrained_packed_array_type (struct type *);
161
162 static struct value *value_subscript_packed (struct value *, int,
163                                              struct value **);
164
165 static struct value *coerce_unspec_val_to_type (struct value *,
166                                                 struct type *);
167
168 static int lesseq_defined_than (struct symbol *, struct symbol *);
169
170 static int equiv_types (struct type *, struct type *);
171
172 static int is_name_suffix (const char *);
173
174 static int advance_wild_match (const char **, const char *, char);
175
176 static bool wild_match (const char *name, const char *patn);
177
178 static struct value *ada_coerce_ref (struct value *);
179
180 static LONGEST pos_atr (struct value *);
181
182 static struct value *val_atr (struct type *, LONGEST);
183
184 static struct symbol *standard_lookup (const char *, const struct block *,
185                                        domain_enum);
186
187 static struct value *ada_search_struct_field (const char *, struct value *, int,
188                                               struct type *);
189
190 static int find_struct_field (const char *, struct type *, int,
191                               struct type **, int *, int *, int *, int *);
192
193 static int ada_resolve_function (std::vector<struct block_symbol> &,
194                                  struct value **, int, const char *,
195                                  struct type *, bool);
196
197 static int ada_is_direct_array_type (struct type *);
198
199 static struct value *ada_index_struct_field (int, struct value *, int,
200                                              struct type *);
201
202 static void add_component_interval (LONGEST, LONGEST, std::vector<LONGEST> &);
203
204
205 static struct type *ada_find_any_type (const char *name);
206
207 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
208   (const lookup_name_info &lookup_name);
209
210 \f
211
212 /* The result of a symbol lookup to be stored in our symbol cache.  */
213
214 struct cache_entry
215 {
216   /* The name used to perform the lookup.  */
217   const char *name;
218   /* The namespace used during the lookup.  */
219   domain_enum domain;
220   /* The symbol returned by the lookup, or NULL if no matching symbol
221      was found.  */
222   struct symbol *sym;
223   /* The block where the symbol was found, or NULL if no matching
224      symbol was found.  */
225   const struct block *block;
226   /* A pointer to the next entry with the same hash.  */
227   struct cache_entry *next;
228 };
229
230 /* The Ada symbol cache, used to store the result of Ada-mode symbol
231    lookups in the course of executing the user's commands.
232
233    The cache is implemented using a simple, fixed-sized hash.
234    The size is fixed on the grounds that there are not likely to be
235    all that many symbols looked up during any given session, regardless
236    of the size of the symbol table.  If we decide to go to a resizable
237    table, let's just use the stuff from libiberty instead.  */
238
239 #define HASH_SIZE 1009
240
241 struct ada_symbol_cache
242 {
243   /* An obstack used to store the entries in our cache.  */
244   struct auto_obstack cache_space;
245
246   /* The root of the hash table used to implement our symbol cache.  */
247   struct cache_entry *root[HASH_SIZE] {};
248 };
249
250 static const char ada_completer_word_break_characters[] =
251 #ifdef VMS
252   " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
253 #else
254   " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
255 #endif
256
257 /* The name of the symbol to use to get the name of the main subprogram.  */
258 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
259   = "__gnat_ada_main_program_name";
260
261 /* Limit on the number of warnings to raise per expression evaluation.  */
262 static int warning_limit = 2;
263
264 /* Number of warning messages issued; reset to 0 by cleanups after
265    expression evaluation.  */
266 static int warnings_issued = 0;
267
268 static const char * const known_runtime_file_name_patterns[] = {
269   ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
270 };
271
272 static const char * const known_auxiliary_function_name_patterns[] = {
273   ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
274 };
275
276 /* Maintenance-related settings for this module.  */
277
278 static struct cmd_list_element *maint_set_ada_cmdlist;
279 static struct cmd_list_element *maint_show_ada_cmdlist;
280
281 /* The "maintenance ada set/show ignore-descriptive-type" value.  */
282
283 static bool ada_ignore_descriptive_types_p = false;
284
285                         /* Inferior-specific data.  */
286
287 /* Per-inferior data for this module.  */
288
289 struct ada_inferior_data
290 {
291   /* The ada__tags__type_specific_data type, which is used when decoding
292      tagged types.  With older versions of GNAT, this type was directly
293      accessible through a component ("tsd") in the object tag.  But this
294      is no longer the case, so we cache it for each inferior.  */
295   struct type *tsd_type = nullptr;
296
297   /* The exception_support_info data.  This data is used to determine
298      how to implement support for Ada exception catchpoints in a given
299      inferior.  */
300   const struct exception_support_info *exception_info = nullptr;
301 };
302
303 /* Our key to this module's inferior data.  */
304 static const struct inferior_key<ada_inferior_data> ada_inferior_data;
305
306 /* Return our inferior data for the given inferior (INF).
307
308    This function always returns a valid pointer to an allocated
309    ada_inferior_data structure.  If INF's inferior data has not
310    been previously set, this functions creates a new one with all
311    fields set to zero, sets INF's inferior to it, and then returns
312    a pointer to that newly allocated ada_inferior_data.  */
313
314 static struct ada_inferior_data *
315 get_ada_inferior_data (struct inferior *inf)
316 {
317   struct ada_inferior_data *data;
318
319   data = ada_inferior_data.get (inf);
320   if (data == NULL)
321     data = ada_inferior_data.emplace (inf);
322
323   return data;
324 }
325
326 /* Perform all necessary cleanups regarding our module's inferior data
327    that is required after the inferior INF just exited.  */
328
329 static void
330 ada_inferior_exit (struct inferior *inf)
331 {
332   ada_inferior_data.clear (inf);
333 }
334
335
336                         /* program-space-specific data.  */
337
338 /* This module's per-program-space data.  */
339 struct ada_pspace_data
340 {
341   /* The Ada symbol cache.  */
342   std::unique_ptr<ada_symbol_cache> sym_cache;
343 };
344
345 /* Key to our per-program-space data.  */
346 static const struct program_space_key<ada_pspace_data> ada_pspace_data_handle;
347
348 /* Return this module's data for the given program space (PSPACE).
349    If not is found, add a zero'ed one now.
350
351    This function always returns a valid object.  */
352
353 static struct ada_pspace_data *
354 get_ada_pspace_data (struct program_space *pspace)
355 {
356   struct ada_pspace_data *data;
357
358   data = ada_pspace_data_handle.get (pspace);
359   if (data == NULL)
360     data = ada_pspace_data_handle.emplace (pspace);
361
362   return data;
363 }
364
365                         /* Utilities */
366
367 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
368    all typedef layers have been peeled.  Otherwise, return TYPE.
369
370    Normally, we really expect a typedef type to only have 1 typedef layer.
371    In other words, we really expect the target type of a typedef type to be
372    a non-typedef type.  This is particularly true for Ada units, because
373    the language does not have a typedef vs not-typedef distinction.
374    In that respect, the Ada compiler has been trying to eliminate as many
375    typedef definitions in the debugging information, since they generally
376    do not bring any extra information (we still use typedef under certain
377    circumstances related mostly to the GNAT encoding).
378
379    Unfortunately, we have seen situations where the debugging information
380    generated by the compiler leads to such multiple typedef layers.  For
381    instance, consider the following example with stabs:
382
383      .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
384      .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
385
386    This is an error in the debugging information which causes type
387    pck__float_array___XUP to be defined twice, and the second time,
388    it is defined as a typedef of a typedef.
389
390    This is on the fringe of legality as far as debugging information is
391    concerned, and certainly unexpected.  But it is easy to handle these
392    situations correctly, so we can afford to be lenient in this case.  */
393
394 static struct type *
395 ada_typedef_target_type (struct type *type)
396 {
397   while (type->code () == TYPE_CODE_TYPEDEF)
398     type = TYPE_TARGET_TYPE (type);
399   return type;
400 }
401
402 /* Given DECODED_NAME a string holding a symbol name in its
403    decoded form (ie using the Ada dotted notation), returns
404    its unqualified name.  */
405
406 static const char *
407 ada_unqualified_name (const char *decoded_name)
408 {
409   const char *result;
410   
411   /* If the decoded name starts with '<', it means that the encoded
412      name does not follow standard naming conventions, and thus that
413      it is not your typical Ada symbol name.  Trying to unqualify it
414      is therefore pointless and possibly erroneous.  */
415   if (decoded_name[0] == '<')
416     return decoded_name;
417
418   result = strrchr (decoded_name, '.');
419   if (result != NULL)
420     result++;                   /* Skip the dot...  */
421   else
422     result = decoded_name;
423
424   return result;
425 }
426
427 /* Return a string starting with '<', followed by STR, and '>'.  */
428
429 static std::string
430 add_angle_brackets (const char *str)
431 {
432   return string_printf ("<%s>", str);
433 }
434
435 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
436    suffix of FIELD_NAME beginning "___".  */
437
438 static int
439 field_name_match (const char *field_name, const char *target)
440 {
441   int len = strlen (target);
442
443   return
444     (strncmp (field_name, target, len) == 0
445      && (field_name[len] == '\0'
446          || (startswith (field_name + len, "___")
447              && strcmp (field_name + strlen (field_name) - 6,
448                         "___XVN") != 0)));
449 }
450
451
452 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
453    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
454    and return its index.  This function also handles fields whose name
455    have ___ suffixes because the compiler sometimes alters their name
456    by adding such a suffix to represent fields with certain constraints.
457    If the field could not be found, return a negative number if
458    MAYBE_MISSING is set.  Otherwise raise an error.  */
459
460 int
461 ada_get_field_index (const struct type *type, const char *field_name,
462                      int maybe_missing)
463 {
464   int fieldno;
465   struct type *struct_type = check_typedef ((struct type *) type);
466
467   for (fieldno = 0; fieldno < struct_type->num_fields (); fieldno++)
468     if (field_name_match (struct_type->field (fieldno).name (), field_name))
469       return fieldno;
470
471   if (!maybe_missing)
472     error (_("Unable to find field %s in struct %s.  Aborting"),
473            field_name, struct_type->name ());
474
475   return -1;
476 }
477
478 /* The length of the prefix of NAME prior to any "___" suffix.  */
479
480 int
481 ada_name_prefix_len (const char *name)
482 {
483   if (name == NULL)
484     return 0;
485   else
486     {
487       const char *p = strstr (name, "___");
488
489       if (p == NULL)
490         return strlen (name);
491       else
492         return p - name;
493     }
494 }
495
496 /* Return non-zero if SUFFIX is a suffix of STR.
497    Return zero if STR is null.  */
498
499 static int
500 is_suffix (const char *str, const char *suffix)
501 {
502   int len1, len2;
503
504   if (str == NULL)
505     return 0;
506   len1 = strlen (str);
507   len2 = strlen (suffix);
508   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
509 }
510
511 /* The contents of value VAL, treated as a value of type TYPE.  The
512    result is an lval in memory if VAL is.  */
513
514 static struct value *
515 coerce_unspec_val_to_type (struct value *val, struct type *type)
516 {
517   type = ada_check_typedef (type);
518   if (value_type (val) == type)
519     return val;
520   else
521     {
522       struct value *result;
523
524       if (value_optimized_out (val))
525         result = allocate_optimized_out_value (type);
526       else if (value_lazy (val)
527                /* Be careful not to make a lazy not_lval value.  */
528                || (VALUE_LVAL (val) != not_lval
529                    && TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val))))
530         result = allocate_value_lazy (type);
531       else
532         {
533           result = allocate_value (type);
534           value_contents_copy (result, 0, val, 0, TYPE_LENGTH (type));
535         }
536       set_value_component_location (result, val);
537       set_value_bitsize (result, value_bitsize (val));
538       set_value_bitpos (result, value_bitpos (val));
539       if (VALUE_LVAL (result) == lval_memory)
540         set_value_address (result, value_address (val));
541       return result;
542     }
543 }
544
545 static const gdb_byte *
546 cond_offset_host (const gdb_byte *valaddr, long offset)
547 {
548   if (valaddr == NULL)
549     return NULL;
550   else
551     return valaddr + offset;
552 }
553
554 static CORE_ADDR
555 cond_offset_target (CORE_ADDR address, long offset)
556 {
557   if (address == 0)
558     return 0;
559   else
560     return address + offset;
561 }
562
563 /* Issue a warning (as for the definition of warning in utils.c, but
564    with exactly one argument rather than ...), unless the limit on the
565    number of warnings has passed during the evaluation of the current
566    expression.  */
567
568 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
569    provided by "complaint".  */
570 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
571
572 static void
573 lim_warning (const char *format, ...)
574 {
575   va_list args;
576
577   va_start (args, format);
578   warnings_issued += 1;
579   if (warnings_issued <= warning_limit)
580     vwarning (format, args);
581
582   va_end (args);
583 }
584
585 /* Maximum value of a SIZE-byte signed integer type.  */
586 static LONGEST
587 max_of_size (int size)
588 {
589   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
590
591   return top_bit | (top_bit - 1);
592 }
593
594 /* Minimum value of a SIZE-byte signed integer type.  */
595 static LONGEST
596 min_of_size (int size)
597 {
598   return -max_of_size (size) - 1;
599 }
600
601 /* Maximum value of a SIZE-byte unsigned integer type.  */
602 static ULONGEST
603 umax_of_size (int size)
604 {
605   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
606
607   return top_bit | (top_bit - 1);
608 }
609
610 /* Maximum value of integral type T, as a signed quantity.  */
611 static LONGEST
612 max_of_type (struct type *t)
613 {
614   if (t->is_unsigned ())
615     return (LONGEST) umax_of_size (TYPE_LENGTH (t));
616   else
617     return max_of_size (TYPE_LENGTH (t));
618 }
619
620 /* Minimum value of integral type T, as a signed quantity.  */
621 static LONGEST
622 min_of_type (struct type *t)
623 {
624   if (t->is_unsigned ())
625     return 0;
626   else
627     return min_of_size (TYPE_LENGTH (t));
628 }
629
630 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
631 LONGEST
632 ada_discrete_type_high_bound (struct type *type)
633 {
634   type = resolve_dynamic_type (type, {}, 0);
635   switch (type->code ())
636     {
637     case TYPE_CODE_RANGE:
638       {
639         const dynamic_prop &high = type->bounds ()->high;
640
641         if (high.kind () == PROP_CONST)
642           return high.const_val ();
643         else
644           {
645             gdb_assert (high.kind () == PROP_UNDEFINED);
646
647             /* This happens when trying to evaluate a type's dynamic bound
648                without a live target.  There is nothing relevant for us to
649                return here, so return 0.  */
650             return 0;
651           }
652       }
653     case TYPE_CODE_ENUM:
654       return TYPE_FIELD_ENUMVAL (type, type->num_fields () - 1);
655     case TYPE_CODE_BOOL:
656       return 1;
657     case TYPE_CODE_CHAR:
658     case TYPE_CODE_INT:
659       return max_of_type (type);
660     default:
661       error (_("Unexpected type in ada_discrete_type_high_bound."));
662     }
663 }
664
665 /* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
666 LONGEST
667 ada_discrete_type_low_bound (struct type *type)
668 {
669   type = resolve_dynamic_type (type, {}, 0);
670   switch (type->code ())
671     {
672     case TYPE_CODE_RANGE:
673       {
674         const dynamic_prop &low = type->bounds ()->low;
675
676         if (low.kind () == PROP_CONST)
677           return low.const_val ();
678         else
679           {
680             gdb_assert (low.kind () == PROP_UNDEFINED);
681
682             /* This happens when trying to evaluate a type's dynamic bound
683                without a live target.  There is nothing relevant for us to
684                return here, so return 0.  */
685             return 0;
686           }
687       }
688     case TYPE_CODE_ENUM:
689       return TYPE_FIELD_ENUMVAL (type, 0);
690     case TYPE_CODE_BOOL:
691       return 0;
692     case TYPE_CODE_CHAR:
693     case TYPE_CODE_INT:
694       return min_of_type (type);
695     default:
696       error (_("Unexpected type in ada_discrete_type_low_bound."));
697     }
698 }
699
700 /* The identity on non-range types.  For range types, the underlying
701    non-range scalar type.  */
702
703 static struct type *
704 get_base_type (struct type *type)
705 {
706   while (type != NULL && type->code () == TYPE_CODE_RANGE)
707     {
708       if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
709         return type;
710       type = TYPE_TARGET_TYPE (type);
711     }
712   return type;
713 }
714
715 /* Return a decoded version of the given VALUE.  This means returning
716    a value whose type is obtained by applying all the GNAT-specific
717    encodings, making the resulting type a static but standard description
718    of the initial type.  */
719
720 struct value *
721 ada_get_decoded_value (struct value *value)
722 {
723   struct type *type = ada_check_typedef (value_type (value));
724
725   if (ada_is_array_descriptor_type (type)
726       || (ada_is_constrained_packed_array_type (type)
727           && type->code () != TYPE_CODE_PTR))
728     {
729       if (type->code () == TYPE_CODE_TYPEDEF)  /* array access type.  */
730         value = ada_coerce_to_simple_array_ptr (value);
731       else
732         value = ada_coerce_to_simple_array (value);
733     }
734   else
735     value = ada_to_fixed_value (value);
736
737   return value;
738 }
739
740 /* Same as ada_get_decoded_value, but with the given TYPE.
741    Because there is no associated actual value for this type,
742    the resulting type might be a best-effort approximation in
743    the case of dynamic types.  */
744
745 struct type *
746 ada_get_decoded_type (struct type *type)
747 {
748   type = to_static_fixed_type (type);
749   if (ada_is_constrained_packed_array_type (type))
750     type = ada_coerce_to_simple_array_type (type);
751   return type;
752 }
753
754 \f
755
756                                 /* Language Selection */
757
758 /* If the main program is in Ada, return language_ada, otherwise return LANG
759    (the main program is in Ada iif the adainit symbol is found).  */
760
761 static enum language
762 ada_update_initial_language (enum language lang)
763 {
764   if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
765     return language_ada;
766
767   return lang;
768 }
769
770 /* If the main procedure is written in Ada, then return its name.
771    The result is good until the next call.  Return NULL if the main
772    procedure doesn't appear to be in Ada.  */
773
774 char *
775 ada_main_name (void)
776 {
777   struct bound_minimal_symbol msym;
778   static gdb::unique_xmalloc_ptr<char> main_program_name;
779
780   /* For Ada, the name of the main procedure is stored in a specific
781      string constant, generated by the binder.  Look for that symbol,
782      extract its address, and then read that string.  If we didn't find
783      that string, then most probably the main procedure is not written
784      in Ada.  */
785   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
786
787   if (msym.minsym != NULL)
788     {
789       CORE_ADDR main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
790       if (main_program_name_addr == 0)
791         error (_("Invalid address for Ada main program name."));
792
793       main_program_name = target_read_string (main_program_name_addr, 1024);
794       return main_program_name.get ();
795     }
796
797   /* The main procedure doesn't seem to be in Ada.  */
798   return NULL;
799 }
800 \f
801                                 /* Symbols */
802
803 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
804    of NULLs.  */
805
806 const struct ada_opname_map ada_opname_table[] = {
807   {"Oadd", "\"+\"", BINOP_ADD},
808   {"Osubtract", "\"-\"", BINOP_SUB},
809   {"Omultiply", "\"*\"", BINOP_MUL},
810   {"Odivide", "\"/\"", BINOP_DIV},
811   {"Omod", "\"mod\"", BINOP_MOD},
812   {"Orem", "\"rem\"", BINOP_REM},
813   {"Oexpon", "\"**\"", BINOP_EXP},
814   {"Olt", "\"<\"", BINOP_LESS},
815   {"Ole", "\"<=\"", BINOP_LEQ},
816   {"Ogt", "\">\"", BINOP_GTR},
817   {"Oge", "\">=\"", BINOP_GEQ},
818   {"Oeq", "\"=\"", BINOP_EQUAL},
819   {"One", "\"/=\"", BINOP_NOTEQUAL},
820   {"Oand", "\"and\"", BINOP_BITWISE_AND},
821   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
822   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
823   {"Oconcat", "\"&\"", BINOP_CONCAT},
824   {"Oabs", "\"abs\"", UNOP_ABS},
825   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
826   {"Oadd", "\"+\"", UNOP_PLUS},
827   {"Osubtract", "\"-\"", UNOP_NEG},
828   {NULL, NULL}
829 };
830
831 /* If STR is a decoded version of a compiler-provided suffix (like the
832    "[cold]" in "symbol[cold]"), return true.  Otherwise, return
833    false.  */
834
835 static bool
836 is_compiler_suffix (const char *str)
837 {
838   gdb_assert (*str == '[');
839   ++str;
840   while (*str != '\0' && isalpha (*str))
841     ++str;
842   /* We accept a missing "]" in order to support completion.  */
843   return *str == '\0' || (str[0] == ']' && str[1] == '\0');
844 }
845
846 /* The "encoded" form of DECODED, according to GNAT conventions.  If
847    THROW_ERRORS, throw an error if invalid operator name is found.
848    Otherwise, return the empty string in that case.  */
849
850 static std::string
851 ada_encode_1 (const char *decoded, bool throw_errors)
852 {
853   if (decoded == NULL)
854     return {};
855
856   std::string encoding_buffer;
857   for (const char *p = decoded; *p != '\0'; p += 1)
858     {
859       if (*p == '.')
860         encoding_buffer.append ("__");
861       else if (*p == '[' && is_compiler_suffix (p))
862         {
863           encoding_buffer = encoding_buffer + "." + (p + 1);
864           if (encoding_buffer.back () == ']')
865             encoding_buffer.pop_back ();
866           break;
867         }
868       else if (*p == '"')
869         {
870           const struct ada_opname_map *mapping;
871
872           for (mapping = ada_opname_table;
873                mapping->encoded != NULL
874                && !startswith (p, mapping->decoded); mapping += 1)
875             ;
876           if (mapping->encoded == NULL)
877             {
878               if (throw_errors)
879                 error (_("invalid Ada operator name: %s"), p);
880               else
881                 return {};
882             }
883           encoding_buffer.append (mapping->encoded);
884           break;
885         }
886       else
887         encoding_buffer.push_back (*p);
888     }
889
890   return encoding_buffer;
891 }
892
893 /* The "encoded" form of DECODED, according to GNAT conventions.  */
894
895 std::string
896 ada_encode (const char *decoded)
897 {
898   return ada_encode_1 (decoded, true);
899 }
900
901 /* Return NAME folded to lower case, or, if surrounded by single
902    quotes, unfolded, but with the quotes stripped away.  Result good
903    to next call.  */
904
905 static const char *
906 ada_fold_name (gdb::string_view name)
907 {
908   static std::string fold_storage;
909
910   if (!name.empty () && name[0] == '\'')
911     fold_storage = gdb::to_string (name.substr (1, name.size () - 2));
912   else
913     {
914       fold_storage = gdb::to_string (name);
915       for (int i = 0; i < name.size (); i += 1)
916         fold_storage[i] = tolower (fold_storage[i]);
917     }
918
919   return fold_storage.c_str ();
920 }
921
922 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
923
924 static int
925 is_lower_alphanum (const char c)
926 {
927   return (isdigit (c) || (isalpha (c) && islower (c)));
928 }
929
930 /* ENCODED is the linkage name of a symbol and LEN contains its length.
931    This function saves in LEN the length of that same symbol name but
932    without either of these suffixes:
933      . .{DIGIT}+
934      . ${DIGIT}+
935      . ___{DIGIT}+
936      . __{DIGIT}+.
937
938    These are suffixes introduced by the compiler for entities such as
939    nested subprogram for instance, in order to avoid name clashes.
940    They do not serve any purpose for the debugger.  */
941
942 static void
943 ada_remove_trailing_digits (const char *encoded, int *len)
944 {
945   if (*len > 1 && isdigit (encoded[*len - 1]))
946     {
947       int i = *len - 2;
948
949       while (i > 0 && isdigit (encoded[i]))
950         i--;
951       if (i >= 0 && encoded[i] == '.')
952         *len = i;
953       else if (i >= 0 && encoded[i] == '$')
954         *len = i;
955       else if (i >= 2 && startswith (encoded + i - 2, "___"))
956         *len = i - 2;
957       else if (i >= 1 && startswith (encoded + i - 1, "__"))
958         *len = i - 1;
959     }
960 }
961
962 /* Remove the suffix introduced by the compiler for protected object
963    subprograms.  */
964
965 static void
966 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
967 {
968   /* Remove trailing N.  */
969
970   /* Protected entry subprograms are broken into two
971      separate subprograms: The first one is unprotected, and has
972      a 'N' suffix; the second is the protected version, and has
973      the 'P' suffix.  The second calls the first one after handling
974      the protection.  Since the P subprograms are internally generated,
975      we leave these names undecoded, giving the user a clue that this
976      entity is internal.  */
977
978   if (*len > 1
979       && encoded[*len - 1] == 'N'
980       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
981     *len = *len - 1;
982 }
983
984 /* If ENCODED ends with a compiler-provided suffix (like ".cold"),
985    then update *LEN to remove the suffix and return the offset of the
986    character just past the ".".  Otherwise, return -1.  */
987
988 static int
989 remove_compiler_suffix (const char *encoded, int *len)
990 {
991   int offset = *len - 1;
992   while (offset > 0 && isalpha (encoded[offset]))
993     --offset;
994   if (offset > 0 && encoded[offset] == '.')
995     {
996       *len = offset;
997       return offset + 1;
998     }
999   return -1;
1000 }
1001
1002 /* See ada-lang.h.  */
1003
1004 std::string
1005 ada_decode (const char *encoded, bool wrap)
1006 {
1007   int i, j;
1008   int len0;
1009   const char *p;
1010   int at_start_name;
1011   std::string decoded;
1012   int suffix = -1;
1013
1014   /* With function descriptors on PPC64, the value of a symbol named
1015      ".FN", if it exists, is the entry point of the function "FN".  */
1016   if (encoded[0] == '.')
1017     encoded += 1;
1018
1019   /* The name of the Ada main procedure starts with "_ada_".
1020      This prefix is not part of the decoded name, so skip this part
1021      if we see this prefix.  */
1022   if (startswith (encoded, "_ada_"))
1023     encoded += 5;
1024
1025   /* If the name starts with '_', then it is not a properly encoded
1026      name, so do not attempt to decode it.  Similarly, if the name
1027      starts with '<', the name should not be decoded.  */
1028   if (encoded[0] == '_' || encoded[0] == '<')
1029     goto Suppress;
1030
1031   len0 = strlen (encoded);
1032
1033   suffix = remove_compiler_suffix (encoded, &len0);
1034
1035   ada_remove_trailing_digits (encoded, &len0);
1036   ada_remove_po_subprogram_suffix (encoded, &len0);
1037
1038   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1039      the suffix is located before the current "end" of ENCODED.  We want
1040      to avoid re-matching parts of ENCODED that have previously been
1041      marked as discarded (by decrementing LEN0).  */
1042   p = strstr (encoded, "___");
1043   if (p != NULL && p - encoded < len0 - 3)
1044     {
1045       if (p[3] == 'X')
1046         len0 = p - encoded;
1047       else
1048         goto Suppress;
1049     }
1050
1051   /* Remove any trailing TKB suffix.  It tells us that this symbol
1052      is for the body of a task, but that information does not actually
1053      appear in the decoded name.  */
1054
1055   if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1056     len0 -= 3;
1057
1058   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1059      from the TKB suffix because it is used for non-anonymous task
1060      bodies.  */
1061
1062   if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1063     len0 -= 2;
1064
1065   /* Remove trailing "B" suffixes.  */
1066   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1067
1068   if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1069     len0 -= 1;
1070
1071   /* Make decoded big enough for possible expansion by operator name.  */
1072
1073   decoded.resize (2 * len0 + 1, 'X');
1074
1075   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1076
1077   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1078     {
1079       i = len0 - 2;
1080       while ((i >= 0 && isdigit (encoded[i]))
1081              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1082         i -= 1;
1083       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1084         len0 = i - 1;
1085       else if (encoded[i] == '$')
1086         len0 = i;
1087     }
1088
1089   /* The first few characters that are not alphabetic are not part
1090      of any encoding we use, so we can copy them over verbatim.  */
1091
1092   for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1093     decoded[j] = encoded[i];
1094
1095   at_start_name = 1;
1096   while (i < len0)
1097     {
1098       /* Is this a symbol function?  */
1099       if (at_start_name && encoded[i] == 'O')
1100         {
1101           int k;
1102
1103           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1104             {
1105               int op_len = strlen (ada_opname_table[k].encoded);
1106               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1107                             op_len - 1) == 0)
1108                   && !isalnum (encoded[i + op_len]))
1109                 {
1110                   strcpy (&decoded.front() + j, ada_opname_table[k].decoded);
1111                   at_start_name = 0;
1112                   i += op_len;
1113                   j += strlen (ada_opname_table[k].decoded);
1114                   break;
1115                 }
1116             }
1117           if (ada_opname_table[k].encoded != NULL)
1118             continue;
1119         }
1120       at_start_name = 0;
1121
1122       /* Replace "TK__" with "__", which will eventually be translated
1123          into "." (just below).  */
1124
1125       if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1126         i += 2;
1127
1128       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1129          be translated into "." (just below).  These are internal names
1130          generated for anonymous blocks inside which our symbol is nested.  */
1131
1132       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1133           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1134           && isdigit (encoded [i+4]))
1135         {
1136           int k = i + 5;
1137           
1138           while (k < len0 && isdigit (encoded[k]))
1139             k++;  /* Skip any extra digit.  */
1140
1141           /* Double-check that the "__B_{DIGITS}+" sequence we found
1142              is indeed followed by "__".  */
1143           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1144             i = k;
1145         }
1146
1147       /* Remove _E{DIGITS}+[sb] */
1148
1149       /* Just as for protected object subprograms, there are 2 categories
1150          of subprograms created by the compiler for each entry.  The first
1151          one implements the actual entry code, and has a suffix following
1152          the convention above; the second one implements the barrier and
1153          uses the same convention as above, except that the 'E' is replaced
1154          by a 'B'.
1155
1156          Just as above, we do not decode the name of barrier functions
1157          to give the user a clue that the code he is debugging has been
1158          internally generated.  */
1159
1160       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1161           && isdigit (encoded[i+2]))
1162         {
1163           int k = i + 3;
1164
1165           while (k < len0 && isdigit (encoded[k]))
1166             k++;
1167
1168           if (k < len0
1169               && (encoded[k] == 'b' || encoded[k] == 's'))
1170             {
1171               k++;
1172               /* Just as an extra precaution, make sure that if this
1173                  suffix is followed by anything else, it is a '_'.
1174                  Otherwise, we matched this sequence by accident.  */
1175               if (k == len0
1176                   || (k < len0 && encoded[k] == '_'))
1177                 i = k;
1178             }
1179         }
1180
1181       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1182          the GNAT front-end in protected object subprograms.  */
1183
1184       if (i < len0 + 3
1185           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1186         {
1187           /* Backtrack a bit up until we reach either the begining of
1188              the encoded name, or "__".  Make sure that we only find
1189              digits or lowercase characters.  */
1190           const char *ptr = encoded + i - 1;
1191
1192           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1193             ptr--;
1194           if (ptr < encoded
1195               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1196             i++;
1197         }
1198
1199       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1200         {
1201           /* This is a X[bn]* sequence not separated from the previous
1202              part of the name with a non-alpha-numeric character (in other
1203              words, immediately following an alpha-numeric character), then
1204              verify that it is placed at the end of the encoded name.  If
1205              not, then the encoding is not valid and we should abort the
1206              decoding.  Otherwise, just skip it, it is used in body-nested
1207              package names.  */
1208           do
1209             i += 1;
1210           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1211           if (i < len0)
1212             goto Suppress;
1213         }
1214       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1215         {
1216          /* Replace '__' by '.'.  */
1217           decoded[j] = '.';
1218           at_start_name = 1;
1219           i += 2;
1220           j += 1;
1221         }
1222       else
1223         {
1224           /* It's a character part of the decoded name, so just copy it
1225              over.  */
1226           decoded[j] = encoded[i];
1227           i += 1;
1228           j += 1;
1229         }
1230     }
1231   decoded.resize (j);
1232
1233   /* Decoded names should never contain any uppercase character.
1234      Double-check this, and abort the decoding if we find one.  */
1235
1236   for (i = 0; i < decoded.length(); ++i)
1237     if (isupper (decoded[i]) || decoded[i] == ' ')
1238       goto Suppress;
1239
1240   /* If the compiler added a suffix, append it now.  */
1241   if (suffix >= 0)
1242     decoded = decoded + "[" + &encoded[suffix] + "]";
1243
1244   return decoded;
1245
1246 Suppress:
1247   if (!wrap)
1248     return {};
1249
1250   if (encoded[0] == '<')
1251     decoded = encoded;
1252   else
1253     decoded = '<' + std::string(encoded) + '>';
1254   return decoded;
1255 }
1256
1257 /* Table for keeping permanent unique copies of decoded names.  Once
1258    allocated, names in this table are never released.  While this is a
1259    storage leak, it should not be significant unless there are massive
1260    changes in the set of decoded names in successive versions of a 
1261    symbol table loaded during a single session.  */
1262 static struct htab *decoded_names_store;
1263
1264 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1265    in the language-specific part of GSYMBOL, if it has not been
1266    previously computed.  Tries to save the decoded name in the same
1267    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1268    in any case, the decoded symbol has a lifetime at least that of
1269    GSYMBOL).
1270    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1271    const, but nevertheless modified to a semantically equivalent form
1272    when a decoded name is cached in it.  */
1273
1274 const char *
1275 ada_decode_symbol (const struct general_symbol_info *arg)
1276 {
1277   struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1278   const char **resultp =
1279     &gsymbol->language_specific.demangled_name;
1280
1281   if (!gsymbol->ada_mangled)
1282     {
1283       std::string decoded = ada_decode (gsymbol->linkage_name ());
1284       struct obstack *obstack = gsymbol->language_specific.obstack;
1285
1286       gsymbol->ada_mangled = 1;
1287
1288       if (obstack != NULL)
1289         *resultp = obstack_strdup (obstack, decoded.c_str ());
1290       else
1291         {
1292           /* Sometimes, we can't find a corresponding objfile, in
1293              which case, we put the result on the heap.  Since we only
1294              decode when needed, we hope this usually does not cause a
1295              significant memory leak (FIXME).  */
1296
1297           char **slot = (char **) htab_find_slot (decoded_names_store,
1298                                                   decoded.c_str (), INSERT);
1299
1300           if (*slot == NULL)
1301             *slot = xstrdup (decoded.c_str ());
1302           *resultp = *slot;
1303         }
1304     }
1305
1306   return *resultp;
1307 }
1308
1309 \f
1310
1311                                 /* Arrays */
1312
1313 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1314    generated by the GNAT compiler to describe the index type used
1315    for each dimension of an array, check whether it follows the latest
1316    known encoding.  If not, fix it up to conform to the latest encoding.
1317    Otherwise, do nothing.  This function also does nothing if
1318    INDEX_DESC_TYPE is NULL.
1319
1320    The GNAT encoding used to describe the array index type evolved a bit.
1321    Initially, the information would be provided through the name of each
1322    field of the structure type only, while the type of these fields was
1323    described as unspecified and irrelevant.  The debugger was then expected
1324    to perform a global type lookup using the name of that field in order
1325    to get access to the full index type description.  Because these global
1326    lookups can be very expensive, the encoding was later enhanced to make
1327    the global lookup unnecessary by defining the field type as being
1328    the full index type description.
1329
1330    The purpose of this routine is to allow us to support older versions
1331    of the compiler by detecting the use of the older encoding, and by
1332    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1333    we essentially replace each field's meaningless type by the associated
1334    index subtype).  */
1335
1336 void
1337 ada_fixup_array_indexes_type (struct type *index_desc_type)
1338 {
1339   int i;
1340
1341   if (index_desc_type == NULL)
1342     return;
1343   gdb_assert (index_desc_type->num_fields () > 0);
1344
1345   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1346      to check one field only, no need to check them all).  If not, return
1347      now.
1348
1349      If our INDEX_DESC_TYPE was generated using the older encoding,
1350      the field type should be a meaningless integer type whose name
1351      is not equal to the field name.  */
1352   if (index_desc_type->field (0).type ()->name () != NULL
1353       && strcmp (index_desc_type->field (0).type ()->name (),
1354                  index_desc_type->field (0).name ()) == 0)
1355     return;
1356
1357   /* Fixup each field of INDEX_DESC_TYPE.  */
1358   for (i = 0; i < index_desc_type->num_fields (); i++)
1359    {
1360      const char *name = index_desc_type->field (i).name ();
1361      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1362
1363      if (raw_type)
1364        index_desc_type->field (i).set_type (raw_type);
1365    }
1366 }
1367
1368 /* The desc_* routines return primitive portions of array descriptors
1369    (fat pointers).  */
1370
1371 /* The descriptor or array type, if any, indicated by TYPE; removes
1372    level of indirection, if needed.  */
1373
1374 static struct type *
1375 desc_base_type (struct type *type)
1376 {
1377   if (type == NULL)
1378     return NULL;
1379   type = ada_check_typedef (type);
1380   if (type->code () == TYPE_CODE_TYPEDEF)
1381     type = ada_typedef_target_type (type);
1382
1383   if (type != NULL
1384       && (type->code () == TYPE_CODE_PTR
1385           || type->code () == TYPE_CODE_REF))
1386     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1387   else
1388     return type;
1389 }
1390
1391 /* True iff TYPE indicates a "thin" array pointer type.  */
1392
1393 static int
1394 is_thin_pntr (struct type *type)
1395 {
1396   return
1397     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1398     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1399 }
1400
1401 /* The descriptor type for thin pointer type TYPE.  */
1402
1403 static struct type *
1404 thin_descriptor_type (struct type *type)
1405 {
1406   struct type *base_type = desc_base_type (type);
1407
1408   if (base_type == NULL)
1409     return NULL;
1410   if (is_suffix (ada_type_name (base_type), "___XVE"))
1411     return base_type;
1412   else
1413     {
1414       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1415
1416       if (alt_type == NULL)
1417         return base_type;
1418       else
1419         return alt_type;
1420     }
1421 }
1422
1423 /* A pointer to the array data for thin-pointer value VAL.  */
1424
1425 static struct value *
1426 thin_data_pntr (struct value *val)
1427 {
1428   struct type *type = ada_check_typedef (value_type (val));
1429   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1430
1431   data_type = lookup_pointer_type (data_type);
1432
1433   if (type->code () == TYPE_CODE_PTR)
1434     return value_cast (data_type, value_copy (val));
1435   else
1436     return value_from_longest (data_type, value_address (val));
1437 }
1438
1439 /* True iff TYPE indicates a "thick" array pointer type.  */
1440
1441 static int
1442 is_thick_pntr (struct type *type)
1443 {
1444   type = desc_base_type (type);
1445   return (type != NULL && type->code () == TYPE_CODE_STRUCT
1446           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1447 }
1448
1449 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1450    pointer to one, the type of its bounds data; otherwise, NULL.  */
1451
1452 static struct type *
1453 desc_bounds_type (struct type *type)
1454 {
1455   struct type *r;
1456
1457   type = desc_base_type (type);
1458
1459   if (type == NULL)
1460     return NULL;
1461   else if (is_thin_pntr (type))
1462     {
1463       type = thin_descriptor_type (type);
1464       if (type == NULL)
1465         return NULL;
1466       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1467       if (r != NULL)
1468         return ada_check_typedef (r);
1469     }
1470   else if (type->code () == TYPE_CODE_STRUCT)
1471     {
1472       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1473       if (r != NULL)
1474         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1475     }
1476   return NULL;
1477 }
1478
1479 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1480    one, a pointer to its bounds data.   Otherwise NULL.  */
1481
1482 static struct value *
1483 desc_bounds (struct value *arr)
1484 {
1485   struct type *type = ada_check_typedef (value_type (arr));
1486
1487   if (is_thin_pntr (type))
1488     {
1489       struct type *bounds_type =
1490         desc_bounds_type (thin_descriptor_type (type));
1491       LONGEST addr;
1492
1493       if (bounds_type == NULL)
1494         error (_("Bad GNAT array descriptor"));
1495
1496       /* NOTE: The following calculation is not really kosher, but
1497          since desc_type is an XVE-encoded type (and shouldn't be),
1498          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1499       if (type->code () == TYPE_CODE_PTR)
1500         addr = value_as_long (arr);
1501       else
1502         addr = value_address (arr);
1503
1504       return
1505         value_from_longest (lookup_pointer_type (bounds_type),
1506                             addr - TYPE_LENGTH (bounds_type));
1507     }
1508
1509   else if (is_thick_pntr (type))
1510     {
1511       struct value *p_bounds = value_struct_elt (&arr, {}, "P_BOUNDS", NULL,
1512                                                _("Bad GNAT array descriptor"));
1513       struct type *p_bounds_type = value_type (p_bounds);
1514
1515       if (p_bounds_type
1516           && p_bounds_type->code () == TYPE_CODE_PTR)
1517         {
1518           struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1519
1520           if (target_type->is_stub ())
1521             p_bounds = value_cast (lookup_pointer_type
1522                                    (ada_check_typedef (target_type)),
1523                                    p_bounds);
1524         }
1525       else
1526         error (_("Bad GNAT array descriptor"));
1527
1528       return p_bounds;
1529     }
1530   else
1531     return NULL;
1532 }
1533
1534 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1535    position of the field containing the address of the bounds data.  */
1536
1537 static int
1538 fat_pntr_bounds_bitpos (struct type *type)
1539 {
1540   return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1541 }
1542
1543 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1544    size of the field containing the address of the bounds data.  */
1545
1546 static int
1547 fat_pntr_bounds_bitsize (struct type *type)
1548 {
1549   type = desc_base_type (type);
1550
1551   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1552     return TYPE_FIELD_BITSIZE (type, 1);
1553   else
1554     return 8 * TYPE_LENGTH (ada_check_typedef (type->field (1).type ()));
1555 }
1556
1557 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1558    pointer to one, the type of its array data (a array-with-no-bounds type);
1559    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1560    data.  */
1561
1562 static struct type *
1563 desc_data_target_type (struct type *type)
1564 {
1565   type = desc_base_type (type);
1566
1567   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1568   if (is_thin_pntr (type))
1569     return desc_base_type (thin_descriptor_type (type)->field (1).type ());
1570   else if (is_thick_pntr (type))
1571     {
1572       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1573
1574       if (data_type
1575           && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
1576         return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1577     }
1578
1579   return NULL;
1580 }
1581
1582 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1583    its array data.  */
1584
1585 static struct value *
1586 desc_data (struct value *arr)
1587 {
1588   struct type *type = value_type (arr);
1589
1590   if (is_thin_pntr (type))
1591     return thin_data_pntr (arr);
1592   else if (is_thick_pntr (type))
1593     return value_struct_elt (&arr, {}, "P_ARRAY", NULL,
1594                              _("Bad GNAT array descriptor"));
1595   else
1596     return NULL;
1597 }
1598
1599
1600 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1601    position of the field containing the address of the data.  */
1602
1603 static int
1604 fat_pntr_data_bitpos (struct type *type)
1605 {
1606   return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1607 }
1608
1609 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1610    size of the field containing the address of the data.  */
1611
1612 static int
1613 fat_pntr_data_bitsize (struct type *type)
1614 {
1615   type = desc_base_type (type);
1616
1617   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1618     return TYPE_FIELD_BITSIZE (type, 0);
1619   else
1620     return TARGET_CHAR_BIT * TYPE_LENGTH (type->field (0).type ());
1621 }
1622
1623 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1624    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1625    bound, if WHICH is 1.  The first bound is I=1.  */
1626
1627 static struct value *
1628 desc_one_bound (struct value *bounds, int i, int which)
1629 {
1630   char bound_name[20];
1631   xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
1632              which ? 'U' : 'L', i - 1);
1633   return value_struct_elt (&bounds, {}, bound_name, NULL,
1634                            _("Bad GNAT array descriptor bounds"));
1635 }
1636
1637 /* If BOUNDS is an array-bounds structure type, return the bit position
1638    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1639    bound, if WHICH is 1.  The first bound is I=1.  */
1640
1641 static int
1642 desc_bound_bitpos (struct type *type, int i, int which)
1643 {
1644   return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1645 }
1646
1647 /* If BOUNDS is an array-bounds structure type, return the bit field size
1648    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1649    bound, if WHICH is 1.  The first bound is I=1.  */
1650
1651 static int
1652 desc_bound_bitsize (struct type *type, int i, int which)
1653 {
1654   type = desc_base_type (type);
1655
1656   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1657     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1658   else
1659     return 8 * TYPE_LENGTH (type->field (2 * i + which - 2).type ());
1660 }
1661
1662 /* If TYPE is the type of an array-bounds structure, the type of its
1663    Ith bound (numbering from 1).  Otherwise, NULL.  */
1664
1665 static struct type *
1666 desc_index_type (struct type *type, int i)
1667 {
1668   type = desc_base_type (type);
1669
1670   if (type->code () == TYPE_CODE_STRUCT)
1671     {
1672       char bound_name[20];
1673       xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
1674       return lookup_struct_elt_type (type, bound_name, 1);
1675     }
1676   else
1677     return NULL;
1678 }
1679
1680 /* The number of index positions in the array-bounds type TYPE.
1681    Return 0 if TYPE is NULL.  */
1682
1683 static int
1684 desc_arity (struct type *type)
1685 {
1686   type = desc_base_type (type);
1687
1688   if (type != NULL)
1689     return type->num_fields () / 2;
1690   return 0;
1691 }
1692
1693 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
1694    an array descriptor type (representing an unconstrained array
1695    type).  */
1696
1697 static int
1698 ada_is_direct_array_type (struct type *type)
1699 {
1700   if (type == NULL)
1701     return 0;
1702   type = ada_check_typedef (type);
1703   return (type->code () == TYPE_CODE_ARRAY
1704           || ada_is_array_descriptor_type (type));
1705 }
1706
1707 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1708  * to one.  */
1709
1710 static int
1711 ada_is_array_type (struct type *type)
1712 {
1713   while (type != NULL
1714          && (type->code () == TYPE_CODE_PTR
1715              || type->code () == TYPE_CODE_REF))
1716     type = TYPE_TARGET_TYPE (type);
1717   return ada_is_direct_array_type (type);
1718 }
1719
1720 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
1721
1722 int
1723 ada_is_simple_array_type (struct type *type)
1724 {
1725   if (type == NULL)
1726     return 0;
1727   type = ada_check_typedef (type);
1728   return (type->code () == TYPE_CODE_ARRAY
1729           || (type->code () == TYPE_CODE_PTR
1730               && (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ()
1731                   == TYPE_CODE_ARRAY)));
1732 }
1733
1734 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
1735
1736 int
1737 ada_is_array_descriptor_type (struct type *type)
1738 {
1739   struct type *data_type = desc_data_target_type (type);
1740
1741   if (type == NULL)
1742     return 0;
1743   type = ada_check_typedef (type);
1744   return (data_type != NULL
1745           && data_type->code () == TYPE_CODE_ARRAY
1746           && desc_arity (desc_bounds_type (type)) > 0);
1747 }
1748
1749 /* Non-zero iff type is a partially mal-formed GNAT array
1750    descriptor.  FIXME: This is to compensate for some problems with
1751    debugging output from GNAT.  Re-examine periodically to see if it
1752    is still needed.  */
1753
1754 int
1755 ada_is_bogus_array_descriptor (struct type *type)
1756 {
1757   return
1758     type != NULL
1759     && type->code () == TYPE_CODE_STRUCT
1760     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1761         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1762     && !ada_is_array_descriptor_type (type);
1763 }
1764
1765
1766 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1767    (fat pointer) returns the type of the array data described---specifically,
1768    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
1769    in from the descriptor; otherwise, they are left unspecified.  If
1770    the ARR denotes a null array descriptor and BOUNDS is non-zero,
1771    returns NULL.  The result is simply the type of ARR if ARR is not
1772    a descriptor.  */
1773
1774 static struct type *
1775 ada_type_of_array (struct value *arr, int bounds)
1776 {
1777   if (ada_is_constrained_packed_array_type (value_type (arr)))
1778     return decode_constrained_packed_array_type (value_type (arr));
1779
1780   if (!ada_is_array_descriptor_type (value_type (arr)))
1781     return value_type (arr);
1782
1783   if (!bounds)
1784     {
1785       struct type *array_type =
1786         ada_check_typedef (desc_data_target_type (value_type (arr)));
1787
1788       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1789         TYPE_FIELD_BITSIZE (array_type, 0) =
1790           decode_packed_array_bitsize (value_type (arr));
1791       
1792       return array_type;
1793     }
1794   else
1795     {
1796       struct type *elt_type;
1797       int arity;
1798       struct value *descriptor;
1799
1800       elt_type = ada_array_element_type (value_type (arr), -1);
1801       arity = ada_array_arity (value_type (arr));
1802
1803       if (elt_type == NULL || arity == 0)
1804         return ada_check_typedef (value_type (arr));
1805
1806       descriptor = desc_bounds (arr);
1807       if (value_as_long (descriptor) == 0)
1808         return NULL;
1809       while (arity > 0)
1810         {
1811           struct type *range_type = alloc_type_copy (value_type (arr));
1812           struct type *array_type = alloc_type_copy (value_type (arr));
1813           struct value *low = desc_one_bound (descriptor, arity, 0);
1814           struct value *high = desc_one_bound (descriptor, arity, 1);
1815
1816           arity -= 1;
1817           create_static_range_type (range_type, value_type (low),
1818                                     longest_to_int (value_as_long (low)),
1819                                     longest_to_int (value_as_long (high)));
1820           elt_type = create_array_type (array_type, elt_type, range_type);
1821
1822           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1823             {
1824               /* We need to store the element packed bitsize, as well as
1825                  recompute the array size, because it was previously
1826                  computed based on the unpacked element size.  */
1827               LONGEST lo = value_as_long (low);
1828               LONGEST hi = value_as_long (high);
1829
1830               TYPE_FIELD_BITSIZE (elt_type, 0) =
1831                 decode_packed_array_bitsize (value_type (arr));
1832               /* If the array has no element, then the size is already
1833                  zero, and does not need to be recomputed.  */
1834               if (lo < hi)
1835                 {
1836                   int array_bitsize =
1837                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1838
1839                   TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1840                 }
1841             }
1842         }
1843
1844       return lookup_pointer_type (elt_type);
1845     }
1846 }
1847
1848 /* If ARR does not represent an array, returns ARR unchanged.
1849    Otherwise, returns either a standard GDB array with bounds set
1850    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1851    GDB array.  Returns NULL if ARR is a null fat pointer.  */
1852
1853 struct value *
1854 ada_coerce_to_simple_array_ptr (struct value *arr)
1855 {
1856   if (ada_is_array_descriptor_type (value_type (arr)))
1857     {
1858       struct type *arrType = ada_type_of_array (arr, 1);
1859
1860       if (arrType == NULL)
1861         return NULL;
1862       return value_cast (arrType, value_copy (desc_data (arr)));
1863     }
1864   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1865     return decode_constrained_packed_array (arr);
1866   else
1867     return arr;
1868 }
1869
1870 /* If ARR does not represent an array, returns ARR unchanged.
1871    Otherwise, returns a standard GDB array describing ARR (which may
1872    be ARR itself if it already is in the proper form).  */
1873
1874 struct value *
1875 ada_coerce_to_simple_array (struct value *arr)
1876 {
1877   if (ada_is_array_descriptor_type (value_type (arr)))
1878     {
1879       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1880
1881       if (arrVal == NULL)
1882         error (_("Bounds unavailable for null array pointer."));
1883       return value_ind (arrVal);
1884     }
1885   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1886     return decode_constrained_packed_array (arr);
1887   else
1888     return arr;
1889 }
1890
1891 /* If TYPE represents a GNAT array type, return it translated to an
1892    ordinary GDB array type (possibly with BITSIZE fields indicating
1893    packing).  For other types, is the identity.  */
1894
1895 struct type *
1896 ada_coerce_to_simple_array_type (struct type *type)
1897 {
1898   if (ada_is_constrained_packed_array_type (type))
1899     return decode_constrained_packed_array_type (type);
1900
1901   if (ada_is_array_descriptor_type (type))
1902     return ada_check_typedef (desc_data_target_type (type));
1903
1904   return type;
1905 }
1906
1907 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
1908
1909 static int
1910 ada_is_gnat_encoded_packed_array_type  (struct type *type)
1911 {
1912   if (type == NULL)
1913     return 0;
1914   type = desc_base_type (type);
1915   type = ada_check_typedef (type);
1916   return
1917     ada_type_name (type) != NULL
1918     && strstr (ada_type_name (type), "___XP") != NULL;
1919 }
1920
1921 /* Non-zero iff TYPE represents a standard GNAT constrained
1922    packed-array type.  */
1923
1924 int
1925 ada_is_constrained_packed_array_type (struct type *type)
1926 {
1927   return ada_is_gnat_encoded_packed_array_type (type)
1928     && !ada_is_array_descriptor_type (type);
1929 }
1930
1931 /* Non-zero iff TYPE represents an array descriptor for a
1932    unconstrained packed-array type.  */
1933
1934 static int
1935 ada_is_unconstrained_packed_array_type (struct type *type)
1936 {
1937   if (!ada_is_array_descriptor_type (type))
1938     return 0;
1939
1940   if (ada_is_gnat_encoded_packed_array_type (type))
1941     return 1;
1942
1943   /* If we saw GNAT encodings, then the above code is sufficient.
1944      However, with minimal encodings, we will just have a thick
1945      pointer instead.  */
1946   if (is_thick_pntr (type))
1947     {
1948       type = desc_base_type (type);
1949       /* The structure's first field is a pointer to an array, so this
1950          fetches the array type.  */
1951       type = TYPE_TARGET_TYPE (type->field (0).type ());
1952       /* Now we can see if the array elements are packed.  */
1953       return TYPE_FIELD_BITSIZE (type, 0) > 0;
1954     }
1955
1956   return 0;
1957 }
1958
1959 /* Return true if TYPE is a (Gnat-encoded) constrained packed array
1960    type, or if it is an ordinary (non-Gnat-encoded) packed array.  */
1961
1962 static bool
1963 ada_is_any_packed_array_type (struct type *type)
1964 {
1965   return (ada_is_constrained_packed_array_type (type)
1966           || (type->code () == TYPE_CODE_ARRAY
1967               && TYPE_FIELD_BITSIZE (type, 0) % 8 != 0));
1968 }
1969
1970 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
1971    return the size of its elements in bits.  */
1972
1973 static long
1974 decode_packed_array_bitsize (struct type *type)
1975 {
1976   const char *raw_name;
1977   const char *tail;
1978   long bits;
1979
1980   /* Access to arrays implemented as fat pointers are encoded as a typedef
1981      of the fat pointer type.  We need the name of the fat pointer type
1982      to do the decoding, so strip the typedef layer.  */
1983   if (type->code () == TYPE_CODE_TYPEDEF)
1984     type = ada_typedef_target_type (type);
1985
1986   raw_name = ada_type_name (ada_check_typedef (type));
1987   if (!raw_name)
1988     raw_name = ada_type_name (desc_base_type (type));
1989
1990   if (!raw_name)
1991     return 0;
1992
1993   tail = strstr (raw_name, "___XP");
1994   if (tail == nullptr)
1995     {
1996       gdb_assert (is_thick_pntr (type));
1997       /* The structure's first field is a pointer to an array, so this
1998          fetches the array type.  */
1999       type = TYPE_TARGET_TYPE (type->field (0).type ());
2000       /* Now we can see if the array elements are packed.  */
2001       return TYPE_FIELD_BITSIZE (type, 0);
2002     }
2003
2004   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2005     {
2006       lim_warning
2007         (_("could not understand bit size information on packed array"));
2008       return 0;
2009     }
2010
2011   return bits;
2012 }
2013
2014 /* Given that TYPE is a standard GDB array type with all bounds filled
2015    in, and that the element size of its ultimate scalar constituents
2016    (that is, either its elements, or, if it is an array of arrays, its
2017    elements' elements, etc.) is *ELT_BITS, return an identical type,
2018    but with the bit sizes of its elements (and those of any
2019    constituent arrays) recorded in the BITSIZE components of its
2020    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2021    in bits.
2022
2023    Note that, for arrays whose index type has an XA encoding where
2024    a bound references a record discriminant, getting that discriminant,
2025    and therefore the actual value of that bound, is not possible
2026    because none of the given parameters gives us access to the record.
2027    This function assumes that it is OK in the context where it is being
2028    used to return an array whose bounds are still dynamic and where
2029    the length is arbitrary.  */
2030
2031 static struct type *
2032 constrained_packed_array_type (struct type *type, long *elt_bits)
2033 {
2034   struct type *new_elt_type;
2035   struct type *new_type;
2036   struct type *index_type_desc;
2037   struct type *index_type;
2038   LONGEST low_bound, high_bound;
2039
2040   type = ada_check_typedef (type);
2041   if (type->code () != TYPE_CODE_ARRAY)
2042     return type;
2043
2044   index_type_desc = ada_find_parallel_type (type, "___XA");
2045   if (index_type_desc)
2046     index_type = to_fixed_range_type (index_type_desc->field (0).type (),
2047                                       NULL);
2048   else
2049     index_type = type->index_type ();
2050
2051   new_type = alloc_type_copy (type);
2052   new_elt_type =
2053     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2054                                    elt_bits);
2055   create_array_type (new_type, new_elt_type, index_type);
2056   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2057   new_type->set_name (ada_type_name (type));
2058
2059   if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
2060        && is_dynamic_type (check_typedef (index_type)))
2061       || !get_discrete_bounds (index_type, &low_bound, &high_bound))
2062     low_bound = high_bound = 0;
2063   if (high_bound < low_bound)
2064     *elt_bits = TYPE_LENGTH (new_type) = 0;
2065   else
2066     {
2067       *elt_bits *= (high_bound - low_bound + 1);
2068       TYPE_LENGTH (new_type) =
2069         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2070     }
2071
2072   new_type->set_is_fixed_instance (true);
2073   return new_type;
2074 }
2075
2076 /* The array type encoded by TYPE, where
2077    ada_is_constrained_packed_array_type (TYPE).  */
2078
2079 static struct type *
2080 decode_constrained_packed_array_type (struct type *type)
2081 {
2082   const char *raw_name = ada_type_name (ada_check_typedef (type));
2083   char *name;
2084   const char *tail;
2085   struct type *shadow_type;
2086   long bits;
2087
2088   if (!raw_name)
2089     raw_name = ada_type_name (desc_base_type (type));
2090
2091   if (!raw_name)
2092     return NULL;
2093
2094   name = (char *) alloca (strlen (raw_name) + 1);
2095   tail = strstr (raw_name, "___XP");
2096   type = desc_base_type (type);
2097
2098   memcpy (name, raw_name, tail - raw_name);
2099   name[tail - raw_name] = '\000';
2100
2101   shadow_type = ada_find_parallel_type_with_name (type, name);
2102
2103   if (shadow_type == NULL)
2104     {
2105       lim_warning (_("could not find bounds information on packed array"));
2106       return NULL;
2107     }
2108   shadow_type = check_typedef (shadow_type);
2109
2110   if (shadow_type->code () != TYPE_CODE_ARRAY)
2111     {
2112       lim_warning (_("could not understand bounds "
2113                      "information on packed array"));
2114       return NULL;
2115     }
2116
2117   bits = decode_packed_array_bitsize (type);
2118   return constrained_packed_array_type (shadow_type, &bits);
2119 }
2120
2121 /* Helper function for decode_constrained_packed_array.  Set the field
2122    bitsize on a series of packed arrays.  Returns the number of
2123    elements in TYPE.  */
2124
2125 static LONGEST
2126 recursively_update_array_bitsize (struct type *type)
2127 {
2128   gdb_assert (type->code () == TYPE_CODE_ARRAY);
2129
2130   LONGEST low, high;
2131   if (!get_discrete_bounds (type->index_type (), &low, &high)
2132       || low > high)
2133     return 0;
2134   LONGEST our_len = high - low + 1;
2135
2136   struct type *elt_type = TYPE_TARGET_TYPE (type);
2137   if (elt_type->code () == TYPE_CODE_ARRAY)
2138     {
2139       LONGEST elt_len = recursively_update_array_bitsize (elt_type);
2140       LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
2141       TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
2142
2143       TYPE_LENGTH (type) = ((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
2144                             / HOST_CHAR_BIT);
2145     }
2146
2147   return our_len;
2148 }
2149
2150 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2151    array, returns a simple array that denotes that array.  Its type is a
2152    standard GDB array type except that the BITSIZEs of the array
2153    target types are set to the number of bits in each element, and the
2154    type length is set appropriately.  */
2155
2156 static struct value *
2157 decode_constrained_packed_array (struct value *arr)
2158 {
2159   struct type *type;
2160
2161   /* If our value is a pointer, then dereference it. Likewise if
2162      the value is a reference.  Make sure that this operation does not
2163      cause the target type to be fixed, as this would indirectly cause
2164      this array to be decoded.  The rest of the routine assumes that
2165      the array hasn't been decoded yet, so we use the basic "coerce_ref"
2166      and "value_ind" routines to perform the dereferencing, as opposed
2167      to using "ada_coerce_ref" or "ada_value_ind".  */
2168   arr = coerce_ref (arr);
2169   if (ada_check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2170     arr = value_ind (arr);
2171
2172   type = decode_constrained_packed_array_type (value_type (arr));
2173   if (type == NULL)
2174     {
2175       error (_("can't unpack array"));
2176       return NULL;
2177     }
2178
2179   /* Decoding the packed array type could not correctly set the field
2180      bitsizes for any dimension except the innermost, because the
2181      bounds may be variable and were not passed to that function.  So,
2182      we further resolve the array bounds here and then update the
2183      sizes.  */
2184   const gdb_byte *valaddr = value_contents_for_printing (arr).data ();
2185   CORE_ADDR address = value_address (arr);
2186   gdb::array_view<const gdb_byte> view
2187     = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
2188   type = resolve_dynamic_type (type, view, address);
2189   recursively_update_array_bitsize (type);
2190
2191   if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2192       && ada_is_modular_type (value_type (arr)))
2193     {
2194        /* This is a (right-justified) modular type representing a packed
2195           array with no wrapper.  In order to interpret the value through
2196           the (left-justified) packed array type we just built, we must
2197           first left-justify it.  */
2198       int bit_size, bit_pos;
2199       ULONGEST mod;
2200
2201       mod = ada_modulus (value_type (arr)) - 1;
2202       bit_size = 0;
2203       while (mod > 0)
2204         {
2205           bit_size += 1;
2206           mod >>= 1;
2207         }
2208       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2209       arr = ada_value_primitive_packed_val (arr, NULL,
2210                                             bit_pos / HOST_CHAR_BIT,
2211                                             bit_pos % HOST_CHAR_BIT,
2212                                             bit_size,
2213                                             type);
2214     }
2215
2216   return coerce_unspec_val_to_type (arr, type);
2217 }
2218
2219
2220 /* The value of the element of packed array ARR at the ARITY indices
2221    given in IND.   ARR must be a simple array.  */
2222
2223 static struct value *
2224 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2225 {
2226   int i;
2227   int bits, elt_off, bit_off;
2228   long elt_total_bit_offset;
2229   struct type *elt_type;
2230   struct value *v;
2231
2232   bits = 0;
2233   elt_total_bit_offset = 0;
2234   elt_type = ada_check_typedef (value_type (arr));
2235   for (i = 0; i < arity; i += 1)
2236     {
2237       if (elt_type->code () != TYPE_CODE_ARRAY
2238           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2239         error
2240           (_("attempt to do packed indexing of "
2241              "something other than a packed array"));
2242       else
2243         {
2244           struct type *range_type = elt_type->index_type ();
2245           LONGEST lowerbound, upperbound;
2246           LONGEST idx;
2247
2248           if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
2249             {
2250               lim_warning (_("don't know bounds of array"));
2251               lowerbound = upperbound = 0;
2252             }
2253
2254           idx = pos_atr (ind[i]);
2255           if (idx < lowerbound || idx > upperbound)
2256             lim_warning (_("packed array index %ld out of bounds"),
2257                          (long) idx);
2258           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2259           elt_total_bit_offset += (idx - lowerbound) * bits;
2260           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2261         }
2262     }
2263   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2264   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2265
2266   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2267                                       bits, elt_type);
2268   return v;
2269 }
2270
2271 /* Non-zero iff TYPE includes negative integer values.  */
2272
2273 static int
2274 has_negatives (struct type *type)
2275 {
2276   switch (type->code ())
2277     {
2278     default:
2279       return 0;
2280     case TYPE_CODE_INT:
2281       return !type->is_unsigned ();
2282     case TYPE_CODE_RANGE:
2283       return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
2284     }
2285 }
2286
2287 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2288    unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
2289    the unpacked buffer.
2290
2291    The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2292    enough to contain at least BIT_OFFSET bits.  If not, an error is raised.
2293
2294    IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2295    zero otherwise.
2296
2297    IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2298
2299    IS_SCALAR is nonzero if the data corresponds to a signed type.  */
2300
2301 static void
2302 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2303                           gdb_byte *unpacked, int unpacked_len,
2304                           int is_big_endian, int is_signed_type,
2305                           int is_scalar)
2306 {
2307   int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2308   int src_idx;                  /* Index into the source area */
2309   int src_bytes_left;           /* Number of source bytes left to process.  */
2310   int srcBitsLeft;              /* Number of source bits left to move */
2311   int unusedLS;                 /* Number of bits in next significant
2312                                    byte of source that are unused */
2313
2314   int unpacked_idx;             /* Index into the unpacked buffer */
2315   int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */
2316
2317   unsigned long accum;          /* Staging area for bits being transferred */
2318   int accumSize;                /* Number of meaningful bits in accum */
2319   unsigned char sign;
2320
2321   /* Transmit bytes from least to most significant; delta is the direction
2322      the indices move.  */
2323   int delta = is_big_endian ? -1 : 1;
2324
2325   /* Make sure that unpacked is large enough to receive the BIT_SIZE
2326      bits from SRC.  .*/
2327   if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2328     error (_("Cannot unpack %d bits into buffer of %d bytes"),
2329            bit_size, unpacked_len);
2330
2331   srcBitsLeft = bit_size;
2332   src_bytes_left = src_len;
2333   unpacked_bytes_left = unpacked_len;
2334   sign = 0;
2335
2336   if (is_big_endian)
2337     {
2338       src_idx = src_len - 1;
2339       if (is_signed_type
2340           && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2341         sign = ~0;
2342
2343       unusedLS =
2344         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2345         % HOST_CHAR_BIT;
2346
2347       if (is_scalar)
2348         {
2349           accumSize = 0;
2350           unpacked_idx = unpacked_len - 1;
2351         }
2352       else
2353         {
2354           /* Non-scalar values must be aligned at a byte boundary...  */
2355           accumSize =
2356             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2357           /* ... And are placed at the beginning (most-significant) bytes
2358              of the target.  */
2359           unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2360           unpacked_bytes_left = unpacked_idx + 1;
2361         }
2362     }
2363   else
2364     {
2365       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2366
2367       src_idx = unpacked_idx = 0;
2368       unusedLS = bit_offset;
2369       accumSize = 0;
2370
2371       if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2372         sign = ~0;
2373     }
2374
2375   accum = 0;
2376   while (src_bytes_left > 0)
2377     {
2378       /* Mask for removing bits of the next source byte that are not
2379          part of the value.  */
2380       unsigned int unusedMSMask =
2381         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2382         1;
2383       /* Sign-extend bits for this byte.  */
2384       unsigned int signMask = sign & ~unusedMSMask;
2385
2386       accum |=
2387         (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2388       accumSize += HOST_CHAR_BIT - unusedLS;
2389       if (accumSize >= HOST_CHAR_BIT)
2390         {
2391           unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2392           accumSize -= HOST_CHAR_BIT;
2393           accum >>= HOST_CHAR_BIT;
2394           unpacked_bytes_left -= 1;
2395           unpacked_idx += delta;
2396         }
2397       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2398       unusedLS = 0;
2399       src_bytes_left -= 1;
2400       src_idx += delta;
2401     }
2402   while (unpacked_bytes_left > 0)
2403     {
2404       accum |= sign << accumSize;
2405       unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2406       accumSize -= HOST_CHAR_BIT;
2407       if (accumSize < 0)
2408         accumSize = 0;
2409       accum >>= HOST_CHAR_BIT;
2410       unpacked_bytes_left -= 1;
2411       unpacked_idx += delta;
2412     }
2413 }
2414
2415 /* Create a new value of type TYPE from the contents of OBJ starting
2416    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2417    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2418    assigning through the result will set the field fetched from.
2419    VALADDR is ignored unless OBJ is NULL, in which case,
2420    VALADDR+OFFSET must address the start of storage containing the 
2421    packed value.  The value returned  in this case is never an lval.
2422    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2423
2424 struct value *
2425 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2426                                 long offset, int bit_offset, int bit_size,
2427                                 struct type *type)
2428 {
2429   struct value *v;
2430   const gdb_byte *src;                /* First byte containing data to unpack */
2431   gdb_byte *unpacked;
2432   const int is_scalar = is_scalar_type (type);
2433   const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2434   gdb::byte_vector staging;
2435
2436   type = ada_check_typedef (type);
2437
2438   if (obj == NULL)
2439     src = valaddr + offset;
2440   else
2441     src = value_contents (obj).data () + offset;
2442
2443   if (is_dynamic_type (type))
2444     {
2445       /* The length of TYPE might by dynamic, so we need to resolve
2446          TYPE in order to know its actual size, which we then use
2447          to create the contents buffer of the value we return.
2448          The difficulty is that the data containing our object is
2449          packed, and therefore maybe not at a byte boundary.  So, what
2450          we do, is unpack the data into a byte-aligned buffer, and then
2451          use that buffer as our object's value for resolving the type.  */
2452       int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2453       staging.resize (staging_len);
2454
2455       ada_unpack_from_contents (src, bit_offset, bit_size,
2456                                 staging.data (), staging.size (),
2457                                 is_big_endian, has_negatives (type),
2458                                 is_scalar);
2459       type = resolve_dynamic_type (type, staging, 0);
2460       if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2461         {
2462           /* This happens when the length of the object is dynamic,
2463              and is actually smaller than the space reserved for it.
2464              For instance, in an array of variant records, the bit_size
2465              we're given is the array stride, which is constant and
2466              normally equal to the maximum size of its element.
2467              But, in reality, each element only actually spans a portion
2468              of that stride.  */
2469           bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2470         }
2471     }
2472
2473   if (obj == NULL)
2474     {
2475       v = allocate_value (type);
2476       src = valaddr + offset;
2477     }
2478   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2479     {
2480       int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2481       gdb_byte *buf;
2482
2483       v = value_at (type, value_address (obj) + offset);
2484       buf = (gdb_byte *) alloca (src_len);
2485       read_memory (value_address (v), buf, src_len);
2486       src = buf;
2487     }
2488   else
2489     {
2490       v = allocate_value (type);
2491       src = value_contents (obj).data () + offset;
2492     }
2493
2494   if (obj != NULL)
2495     {
2496       long new_offset = offset;
2497
2498       set_value_component_location (v, obj);
2499       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2500       set_value_bitsize (v, bit_size);
2501       if (value_bitpos (v) >= HOST_CHAR_BIT)
2502         {
2503           ++new_offset;
2504           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2505         }
2506       set_value_offset (v, new_offset);
2507
2508       /* Also set the parent value.  This is needed when trying to
2509          assign a new value (in inferior memory).  */
2510       set_value_parent (v, obj);
2511     }
2512   else
2513     set_value_bitsize (v, bit_size);
2514   unpacked = value_contents_writeable (v).data ();
2515
2516   if (bit_size == 0)
2517     {
2518       memset (unpacked, 0, TYPE_LENGTH (type));
2519       return v;
2520     }
2521
2522   if (staging.size () == TYPE_LENGTH (type))
2523     {
2524       /* Small short-cut: If we've unpacked the data into a buffer
2525          of the same size as TYPE's length, then we can reuse that,
2526          instead of doing the unpacking again.  */
2527       memcpy (unpacked, staging.data (), staging.size ());
2528     }
2529   else
2530     ada_unpack_from_contents (src, bit_offset, bit_size,
2531                               unpacked, TYPE_LENGTH (type),
2532                               is_big_endian, has_negatives (type), is_scalar);
2533
2534   return v;
2535 }
2536
2537 /* Store the contents of FROMVAL into the location of TOVAL.
2538    Return a new value with the location of TOVAL and contents of
2539    FROMVAL.   Handles assignment into packed fields that have
2540    floating-point or non-scalar types.  */
2541
2542 static struct value *
2543 ada_value_assign (struct value *toval, struct value *fromval)
2544 {
2545   struct type *type = value_type (toval);
2546   int bits = value_bitsize (toval);
2547
2548   toval = ada_coerce_ref (toval);
2549   fromval = ada_coerce_ref (fromval);
2550
2551   if (ada_is_direct_array_type (value_type (toval)))
2552     toval = ada_coerce_to_simple_array (toval);
2553   if (ada_is_direct_array_type (value_type (fromval)))
2554     fromval = ada_coerce_to_simple_array (fromval);
2555
2556   if (!deprecated_value_modifiable (toval))
2557     error (_("Left operand of assignment is not a modifiable lvalue."));
2558
2559   if (VALUE_LVAL (toval) == lval_memory
2560       && bits > 0
2561       && (type->code () == TYPE_CODE_FLT
2562           || type->code () == TYPE_CODE_STRUCT))
2563     {
2564       int len = (value_bitpos (toval)
2565                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2566       int from_size;
2567       gdb_byte *buffer = (gdb_byte *) alloca (len);
2568       struct value *val;
2569       CORE_ADDR to_addr = value_address (toval);
2570
2571       if (type->code () == TYPE_CODE_FLT)
2572         fromval = value_cast (type, fromval);
2573
2574       read_memory (to_addr, buffer, len);
2575       from_size = value_bitsize (fromval);
2576       if (from_size == 0)
2577         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2578
2579       const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2580       ULONGEST from_offset = 0;
2581       if (is_big_endian && is_scalar_type (value_type (fromval)))
2582         from_offset = from_size - bits;
2583       copy_bitwise (buffer, value_bitpos (toval),
2584                     value_contents (fromval).data (), from_offset,
2585                     bits, is_big_endian);
2586       write_memory_with_notification (to_addr, buffer, len);
2587
2588       val = value_copy (toval);
2589       memcpy (value_contents_raw (val).data (),
2590               value_contents (fromval).data (),
2591               TYPE_LENGTH (type));
2592       deprecated_set_value_type (val, type);
2593
2594       return val;
2595     }
2596
2597   return value_assign (toval, fromval);
2598 }
2599
2600
2601 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2602    CONTAINER, assign the contents of VAL to COMPONENTS's place in
2603    CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2604    COMPONENT, and not the inferior's memory.  The current contents
2605    of COMPONENT are ignored.
2606
2607    Although not part of the initial design, this function also works
2608    when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2609    had a null address, and COMPONENT had an address which is equal to
2610    its offset inside CONTAINER.  */
2611
2612 static void
2613 value_assign_to_component (struct value *container, struct value *component,
2614                            struct value *val)
2615 {
2616   LONGEST offset_in_container =
2617     (LONGEST)  (value_address (component) - value_address (container));
2618   int bit_offset_in_container =
2619     value_bitpos (component) - value_bitpos (container);
2620   int bits;
2621
2622   val = value_cast (value_type (component), val);
2623
2624   if (value_bitsize (component) == 0)
2625     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2626   else
2627     bits = value_bitsize (component);
2628
2629   if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2630     {
2631       int src_offset;
2632
2633       if (is_scalar_type (check_typedef (value_type (component))))
2634         src_offset
2635           = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2636       else
2637         src_offset = 0;
2638       copy_bitwise ((value_contents_writeable (container).data ()
2639                      + offset_in_container),
2640                     value_bitpos (container) + bit_offset_in_container,
2641                     value_contents (val).data (), src_offset, bits, 1);
2642     }
2643   else
2644     copy_bitwise ((value_contents_writeable (container).data ()
2645                    + offset_in_container),
2646                   value_bitpos (container) + bit_offset_in_container,
2647                   value_contents (val).data (), 0, bits, 0);
2648 }
2649
2650 /* Determine if TYPE is an access to an unconstrained array.  */
2651
2652 bool
2653 ada_is_access_to_unconstrained_array (struct type *type)
2654 {
2655   return (type->code () == TYPE_CODE_TYPEDEF
2656           && is_thick_pntr (ada_typedef_target_type (type)));
2657 }
2658
2659 /* The value of the element of array ARR at the ARITY indices given in IND.
2660    ARR may be either a simple array, GNAT array descriptor, or pointer
2661    thereto.  */
2662
2663 struct value *
2664 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2665 {
2666   int k;
2667   struct value *elt;
2668   struct type *elt_type;
2669
2670   elt = ada_coerce_to_simple_array (arr);
2671
2672   elt_type = ada_check_typedef (value_type (elt));
2673   if (elt_type->code () == TYPE_CODE_ARRAY
2674       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2675     return value_subscript_packed (elt, arity, ind);
2676
2677   for (k = 0; k < arity; k += 1)
2678     {
2679       struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
2680
2681       if (elt_type->code () != TYPE_CODE_ARRAY)
2682         error (_("too many subscripts (%d expected)"), k);
2683
2684       elt = value_subscript (elt, pos_atr (ind[k]));
2685
2686       if (ada_is_access_to_unconstrained_array (saved_elt_type)
2687           && value_type (elt)->code () != TYPE_CODE_TYPEDEF)
2688         {
2689           /* The element is a typedef to an unconstrained array,
2690              except that the value_subscript call stripped the
2691              typedef layer.  The typedef layer is GNAT's way to
2692              specify that the element is, at the source level, an
2693              access to the unconstrained array, rather than the
2694              unconstrained array.  So, we need to restore that
2695              typedef layer, which we can do by forcing the element's
2696              type back to its original type. Otherwise, the returned
2697              value is going to be printed as the array, rather
2698              than as an access.  Another symptom of the same issue
2699              would be that an expression trying to dereference the
2700              element would also be improperly rejected.  */
2701           deprecated_set_value_type (elt, saved_elt_type);
2702         }
2703
2704       elt_type = ada_check_typedef (value_type (elt));
2705     }
2706
2707   return elt;
2708 }
2709
2710 /* Assuming ARR is a pointer to a GDB array, the value of the element
2711    of *ARR at the ARITY indices given in IND.
2712    Does not read the entire array into memory.
2713
2714    Note: Unlike what one would expect, this function is used instead of
2715    ada_value_subscript for basically all non-packed array types.  The reason
2716    for this is that a side effect of doing our own pointer arithmetics instead
2717    of relying on value_subscript is that there is no implicit typedef peeling.
2718    This is important for arrays of array accesses, where it allows us to
2719    preserve the fact that the array's element is an array access, where the
2720    access part os encoded in a typedef layer.  */
2721
2722 static struct value *
2723 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2724 {
2725   int k;
2726   struct value *array_ind = ada_value_ind (arr);
2727   struct type *type
2728     = check_typedef (value_enclosing_type (array_ind));
2729
2730   if (type->code () == TYPE_CODE_ARRAY
2731       && TYPE_FIELD_BITSIZE (type, 0) > 0)
2732     return value_subscript_packed (array_ind, arity, ind);
2733
2734   for (k = 0; k < arity; k += 1)
2735     {
2736       LONGEST lwb, upb;
2737
2738       if (type->code () != TYPE_CODE_ARRAY)
2739         error (_("too many subscripts (%d expected)"), k);
2740       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2741                         value_copy (arr));
2742       get_discrete_bounds (type->index_type (), &lwb, &upb);
2743       arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
2744       type = TYPE_TARGET_TYPE (type);
2745     }
2746
2747   return value_ind (arr);
2748 }
2749
2750 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2751    actual type of ARRAY_PTR is ignored), returns the Ada slice of
2752    HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
2753    this array is LOW, as per Ada rules.  */
2754 static struct value *
2755 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2756                           int low, int high)
2757 {
2758   struct type *type0 = ada_check_typedef (type);
2759   struct type *base_index_type = TYPE_TARGET_TYPE (type0->index_type ());
2760   struct type *index_type
2761     = create_static_range_type (NULL, base_index_type, low, high);
2762   struct type *slice_type = create_array_type_with_stride
2763                               (NULL, TYPE_TARGET_TYPE (type0), index_type,
2764                                type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
2765                                TYPE_FIELD_BITSIZE (type0, 0));
2766   int base_low =  ada_discrete_type_low_bound (type0->index_type ());
2767   gdb::optional<LONGEST> base_low_pos, low_pos;
2768   CORE_ADDR base;
2769
2770   low_pos = discrete_position (base_index_type, low);
2771   base_low_pos = discrete_position (base_index_type, base_low);
2772
2773   if (!low_pos.has_value () || !base_low_pos.has_value ())
2774     {
2775       warning (_("unable to get positions in slice, use bounds instead"));
2776       low_pos = low;
2777       base_low_pos = base_low;
2778     }
2779
2780   ULONGEST stride = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
2781   if (stride == 0)
2782     stride = TYPE_LENGTH (TYPE_TARGET_TYPE (type0));
2783
2784   base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
2785   return value_at_lazy (slice_type, base);
2786 }
2787
2788
2789 static struct value *
2790 ada_value_slice (struct value *array, int low, int high)
2791 {
2792   struct type *type = ada_check_typedef (value_type (array));
2793   struct type *base_index_type = TYPE_TARGET_TYPE (type->index_type ());
2794   struct type *index_type
2795     = create_static_range_type (NULL, type->index_type (), low, high);
2796   struct type *slice_type = create_array_type_with_stride
2797                               (NULL, TYPE_TARGET_TYPE (type), index_type,
2798                                type->dyn_prop (DYN_PROP_BYTE_STRIDE),
2799                                TYPE_FIELD_BITSIZE (type, 0));
2800   gdb::optional<LONGEST> low_pos, high_pos;
2801
2802
2803   low_pos = discrete_position (base_index_type, low);
2804   high_pos = discrete_position (base_index_type, high);
2805
2806   if (!low_pos.has_value () || !high_pos.has_value ())
2807     {
2808       warning (_("unable to get positions in slice, use bounds instead"));
2809       low_pos = low;
2810       high_pos = high;
2811     }
2812
2813   return value_cast (slice_type,
2814                      value_slice (array, low, *high_pos - *low_pos + 1));
2815 }
2816
2817 /* If type is a record type in the form of a standard GNAT array
2818    descriptor, returns the number of dimensions for type.  If arr is a
2819    simple array, returns the number of "array of"s that prefix its
2820    type designation.  Otherwise, returns 0.  */
2821
2822 int
2823 ada_array_arity (struct type *type)
2824 {
2825   int arity;
2826
2827   if (type == NULL)
2828     return 0;
2829
2830   type = desc_base_type (type);
2831
2832   arity = 0;
2833   if (type->code () == TYPE_CODE_STRUCT)
2834     return desc_arity (desc_bounds_type (type));
2835   else
2836     while (type->code () == TYPE_CODE_ARRAY)
2837       {
2838         arity += 1;
2839         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2840       }
2841
2842   return arity;
2843 }
2844
2845 /* If TYPE is a record type in the form of a standard GNAT array
2846    descriptor or a simple array type, returns the element type for
2847    TYPE after indexing by NINDICES indices, or by all indices if
2848    NINDICES is -1.  Otherwise, returns NULL.  */
2849
2850 struct type *
2851 ada_array_element_type (struct type *type, int nindices)
2852 {
2853   type = desc_base_type (type);
2854
2855   if (type->code () == TYPE_CODE_STRUCT)
2856     {
2857       int k;
2858       struct type *p_array_type;
2859
2860       p_array_type = desc_data_target_type (type);
2861
2862       k = ada_array_arity (type);
2863       if (k == 0)
2864         return NULL;
2865
2866       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
2867       if (nindices >= 0 && k > nindices)
2868         k = nindices;
2869       while (k > 0 && p_array_type != NULL)
2870         {
2871           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2872           k -= 1;
2873         }
2874       return p_array_type;
2875     }
2876   else if (type->code () == TYPE_CODE_ARRAY)
2877     {
2878       while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
2879         {
2880           type = TYPE_TARGET_TYPE (type);
2881           nindices -= 1;
2882         }
2883       return type;
2884     }
2885
2886   return NULL;
2887 }
2888
2889 /* See ada-lang.h.  */
2890
2891 struct type *
2892 ada_index_type (struct type *type, int n, const char *name)
2893 {
2894   struct type *result_type;
2895
2896   type = desc_base_type (type);
2897
2898   if (n < 0 || n > ada_array_arity (type))
2899     error (_("invalid dimension number to '%s"), name);
2900
2901   if (ada_is_simple_array_type (type))
2902     {
2903       int i;
2904
2905       for (i = 1; i < n; i += 1)
2906         {
2907           type = ada_check_typedef (type);
2908           type = TYPE_TARGET_TYPE (type);
2909         }
2910       result_type = TYPE_TARGET_TYPE (ada_check_typedef (type)->index_type ());
2911       /* FIXME: The stabs type r(0,0);bound;bound in an array type
2912          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
2913          perhaps stabsread.c would make more sense.  */
2914       if (result_type && result_type->code () == TYPE_CODE_UNDEF)
2915         result_type = NULL;
2916     }
2917   else
2918     {
2919       result_type = desc_index_type (desc_bounds_type (type), n);
2920       if (result_type == NULL)
2921         error (_("attempt to take bound of something that is not an array"));
2922     }
2923
2924   return result_type;
2925 }
2926
2927 /* Given that arr is an array type, returns the lower bound of the
2928    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2929    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
2930    array-descriptor type.  It works for other arrays with bounds supplied
2931    by run-time quantities other than discriminants.  */
2932
2933 static LONGEST
2934 ada_array_bound_from_type (struct type *arr_type, int n, int which)
2935 {
2936   struct type *type, *index_type_desc, *index_type;
2937   int i;
2938
2939   gdb_assert (which == 0 || which == 1);
2940
2941   if (ada_is_constrained_packed_array_type (arr_type))
2942     arr_type = decode_constrained_packed_array_type (arr_type);
2943
2944   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2945     return (LONGEST) - which;
2946
2947   if (arr_type->code () == TYPE_CODE_PTR)
2948     type = TYPE_TARGET_TYPE (arr_type);
2949   else
2950     type = arr_type;
2951
2952   if (type->is_fixed_instance ())
2953     {
2954       /* The array has already been fixed, so we do not need to
2955          check the parallel ___XA type again.  That encoding has
2956          already been applied, so ignore it now.  */
2957       index_type_desc = NULL;
2958     }
2959   else
2960     {
2961       index_type_desc = ada_find_parallel_type (type, "___XA");
2962       ada_fixup_array_indexes_type (index_type_desc);
2963     }
2964
2965   if (index_type_desc != NULL)
2966     index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
2967                                       NULL);
2968   else
2969     {
2970       struct type *elt_type = check_typedef (type);
2971
2972       for (i = 1; i < n; i++)
2973         elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
2974
2975       index_type = elt_type->index_type ();
2976     }
2977
2978   return
2979     (LONGEST) (which == 0
2980                ? ada_discrete_type_low_bound (index_type)
2981                : ada_discrete_type_high_bound (index_type));
2982 }
2983
2984 /* Given that arr is an array value, returns the lower bound of the
2985    nth index (numbering from 1) if WHICH is 0, and the upper bound if
2986    WHICH is 1.  This routine will also work for arrays with bounds
2987    supplied by run-time quantities other than discriminants.  */
2988
2989 static LONGEST
2990 ada_array_bound (struct value *arr, int n, int which)
2991 {
2992   struct type *arr_type;
2993
2994   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
2995     arr = value_ind (arr);
2996   arr_type = value_enclosing_type (arr);
2997
2998   if (ada_is_constrained_packed_array_type (arr_type))
2999     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3000   else if (ada_is_simple_array_type (arr_type))
3001     return ada_array_bound_from_type (arr_type, n, which);
3002   else
3003     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3004 }
3005
3006 /* Given that arr is an array value, returns the length of the
3007    nth index.  This routine will also work for arrays with bounds
3008    supplied by run-time quantities other than discriminants.
3009    Does not work for arrays indexed by enumeration types with representation
3010    clauses at the moment.  */
3011
3012 static LONGEST
3013 ada_array_length (struct value *arr, int n)
3014 {
3015   struct type *arr_type, *index_type;
3016   int low, high;
3017
3018   if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
3019     arr = value_ind (arr);
3020   arr_type = value_enclosing_type (arr);
3021
3022   if (ada_is_constrained_packed_array_type (arr_type))
3023     return ada_array_length (decode_constrained_packed_array (arr), n);
3024
3025   if (ada_is_simple_array_type (arr_type))
3026     {
3027       low = ada_array_bound_from_type (arr_type, n, 0);
3028       high = ada_array_bound_from_type (arr_type, n, 1);
3029     }
3030   else
3031     {
3032       low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3033       high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3034     }
3035
3036   arr_type = check_typedef (arr_type);
3037   index_type = ada_index_type (arr_type, n, "length");
3038   if (index_type != NULL)
3039     {
3040       struct type *base_type;
3041       if (index_type->code () == TYPE_CODE_RANGE)
3042         base_type = TYPE_TARGET_TYPE (index_type);
3043       else
3044         base_type = index_type;
3045
3046       low = pos_atr (value_from_longest (base_type, low));
3047       high = pos_atr (value_from_longest (base_type, high));
3048     }
3049   return high - low + 1;
3050 }
3051
3052 /* An array whose type is that of ARR_TYPE (an array type), with
3053    bounds LOW to HIGH, but whose contents are unimportant.  If HIGH is
3054    less than LOW, then LOW-1 is used.  */
3055
3056 static struct value *
3057 empty_array (struct type *arr_type, int low, int high)
3058 {
3059   struct type *arr_type0 = ada_check_typedef (arr_type);
3060   struct type *index_type
3061     = create_static_range_type
3062         (NULL, TYPE_TARGET_TYPE (arr_type0->index_type ()), low,
3063          high < low ? low - 1 : high);
3064   struct type *elt_type = ada_array_element_type (arr_type0, 1);
3065
3066   return allocate_value (create_array_type (NULL, elt_type, index_type));
3067 }
3068 \f
3069
3070                                 /* Name resolution */
3071
3072 /* The "decoded" name for the user-definable Ada operator corresponding
3073    to OP.  */
3074
3075 static const char *
3076 ada_decoded_op_name (enum exp_opcode op)
3077 {
3078   int i;
3079
3080   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3081     {
3082       if (ada_opname_table[i].op == op)
3083         return ada_opname_table[i].decoded;
3084     }
3085   error (_("Could not find operator name for opcode"));
3086 }
3087
3088 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3089    in a listing of choices during disambiguation (see sort_choices, below).
3090    The idea is that overloadings of a subprogram name from the
3091    same package should sort in their source order.  We settle for ordering
3092    such symbols by their trailing number (__N  or $N).  */
3093
3094 static int
3095 encoded_ordered_before (const char *N0, const char *N1)
3096 {
3097   if (N1 == NULL)
3098     return 0;
3099   else if (N0 == NULL)
3100     return 1;
3101   else
3102     {
3103       int k0, k1;
3104
3105       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3106         ;
3107       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3108         ;
3109       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3110           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3111         {
3112           int n0, n1;
3113
3114           n0 = k0;
3115           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3116             n0 -= 1;
3117           n1 = k1;
3118           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3119             n1 -= 1;
3120           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3121             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3122         }
3123       return (strcmp (N0, N1) < 0);
3124     }
3125 }
3126
3127 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3128    encoded names.  */
3129
3130 static void
3131 sort_choices (struct block_symbol syms[], int nsyms)
3132 {
3133   int i;
3134
3135   for (i = 1; i < nsyms; i += 1)
3136     {
3137       struct block_symbol sym = syms[i];
3138       int j;
3139
3140       for (j = i - 1; j >= 0; j -= 1)
3141         {
3142           if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3143                                       sym.symbol->linkage_name ()))
3144             break;
3145           syms[j + 1] = syms[j];
3146         }
3147       syms[j + 1] = sym;
3148     }
3149 }
3150
3151 /* Whether GDB should display formals and return types for functions in the
3152    overloads selection menu.  */
3153 static bool print_signatures = true;
3154
3155 /* Print the signature for SYM on STREAM according to the FLAGS options.  For
3156    all but functions, the signature is just the name of the symbol.  For
3157    functions, this is the name of the function, the list of types for formals
3158    and the return type (if any).  */
3159
3160 static void
3161 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3162                             const struct type_print_options *flags)
3163 {
3164   struct type *type = SYMBOL_TYPE (sym);
3165
3166   fprintf_filtered (stream, "%s", sym->print_name ());
3167   if (!print_signatures
3168       || type == NULL
3169       || type->code () != TYPE_CODE_FUNC)
3170     return;
3171
3172   if (type->num_fields () > 0)
3173     {
3174       int i;
3175
3176       fprintf_filtered (stream, " (");
3177       for (i = 0; i < type->num_fields (); ++i)
3178         {
3179           if (i > 0)
3180             fprintf_filtered (stream, "; ");
3181           ada_print_type (type->field (i).type (), NULL, stream, -1, 0,
3182                           flags);
3183         }
3184       fprintf_filtered (stream, ")");
3185     }
3186   if (TYPE_TARGET_TYPE (type) != NULL
3187       && TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_VOID)
3188     {
3189       fprintf_filtered (stream, " return ");
3190       ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3191     }
3192 }
3193
3194 /* Read and validate a set of numeric choices from the user in the
3195    range 0 .. N_CHOICES-1.  Place the results in increasing
3196    order in CHOICES[0 .. N-1], and return N.
3197
3198    The user types choices as a sequence of numbers on one line
3199    separated by blanks, encoding them as follows:
3200
3201      + A choice of 0 means to cancel the selection, throwing an error.
3202      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3203      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3204
3205    The user is not allowed to choose more than MAX_RESULTS values.
3206
3207    ANNOTATION_SUFFIX, if present, is used to annotate the input
3208    prompts (for use with the -f switch).  */
3209
3210 static int
3211 get_selections (int *choices, int n_choices, int max_results,
3212                 int is_all_choice, const char *annotation_suffix)
3213 {
3214   const char *args;
3215   const char *prompt;
3216   int n_chosen;
3217   int first_choice = is_all_choice ? 2 : 1;
3218
3219   prompt = getenv ("PS2");
3220   if (prompt == NULL)
3221     prompt = "> ";
3222
3223   args = command_line_input (prompt, annotation_suffix);
3224
3225   if (args == NULL)
3226     error_no_arg (_("one or more choice numbers"));
3227
3228   n_chosen = 0;
3229
3230   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3231      order, as given in args.  Choices are validated.  */
3232   while (1)
3233     {
3234       char *args2;
3235       int choice, j;
3236
3237       args = skip_spaces (args);
3238       if (*args == '\0' && n_chosen == 0)
3239         error_no_arg (_("one or more choice numbers"));
3240       else if (*args == '\0')
3241         break;
3242
3243       choice = strtol (args, &args2, 10);
3244       if (args == args2 || choice < 0
3245           || choice > n_choices + first_choice - 1)
3246         error (_("Argument must be choice number"));
3247       args = args2;
3248
3249       if (choice == 0)
3250         error (_("cancelled"));
3251
3252       if (choice < first_choice)
3253         {
3254           n_chosen = n_choices;
3255           for (j = 0; j < n_choices; j += 1)
3256             choices[j] = j;
3257           break;
3258         }
3259       choice -= first_choice;
3260
3261       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3262         {
3263         }
3264
3265       if (j < 0 || choice != choices[j])
3266         {
3267           int k;
3268
3269           for (k = n_chosen - 1; k > j; k -= 1)
3270             choices[k + 1] = choices[k];
3271           choices[j + 1] = choice;
3272           n_chosen += 1;
3273         }
3274     }
3275
3276   if (n_chosen > max_results)
3277     error (_("Select no more than %d of the above"), max_results);
3278
3279   return n_chosen;
3280 }
3281
3282 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3283    by asking the user (if necessary), returning the number selected,
3284    and setting the first elements of SYMS items.  Error if no symbols
3285    selected.  */
3286
3287 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3288    to be re-integrated one of these days.  */
3289
3290 static int
3291 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3292 {
3293   int i;
3294   int *chosen = XALLOCAVEC (int , nsyms);
3295   int n_chosen;
3296   int first_choice = (max_results == 1) ? 1 : 2;
3297   const char *select_mode = multiple_symbols_select_mode ();
3298
3299   if (max_results < 1)
3300     error (_("Request to select 0 symbols!"));
3301   if (nsyms <= 1)
3302     return nsyms;
3303
3304   if (select_mode == multiple_symbols_cancel)
3305     error (_("\
3306 canceled because the command is ambiguous\n\
3307 See set/show multiple-symbol."));
3308
3309   /* If select_mode is "all", then return all possible symbols.
3310      Only do that if more than one symbol can be selected, of course.
3311      Otherwise, display the menu as usual.  */
3312   if (select_mode == multiple_symbols_all && max_results > 1)
3313     return nsyms;
3314
3315   printf_filtered (_("[0] cancel\n"));
3316   if (max_results > 1)
3317     printf_filtered (_("[1] all\n"));
3318
3319   sort_choices (syms, nsyms);
3320
3321   for (i = 0; i < nsyms; i += 1)
3322     {
3323       if (syms[i].symbol == NULL)
3324         continue;
3325
3326       if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
3327         {
3328           struct symtab_and_line sal =
3329             find_function_start_sal (syms[i].symbol, 1);
3330
3331           printf_filtered ("[%d] ", i + first_choice);
3332           ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3333                                       &type_print_raw_options);
3334           if (sal.symtab == NULL)
3335             printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3336                              metadata_style.style ().ptr (), nullptr, sal.line);
3337           else
3338             printf_filtered
3339               (_(" at %ps:%d\n"),
3340                styled_string (file_name_style.style (),
3341                               symtab_to_filename_for_display (sal.symtab)),
3342                sal.line);
3343           continue;
3344         }
3345       else
3346         {
3347           int is_enumeral =
3348             (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3349              && SYMBOL_TYPE (syms[i].symbol) != NULL
3350              && SYMBOL_TYPE (syms[i].symbol)->code () == TYPE_CODE_ENUM);
3351           struct symtab *symtab = NULL;
3352
3353           if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3354             symtab = symbol_symtab (syms[i].symbol);
3355
3356           if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
3357             {
3358               printf_filtered ("[%d] ", i + first_choice);
3359               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3360                                           &type_print_raw_options);
3361               printf_filtered (_(" at %s:%d\n"),
3362                                symtab_to_filename_for_display (symtab),
3363                                SYMBOL_LINE (syms[i].symbol));
3364             }
3365           else if (is_enumeral
3366                    && SYMBOL_TYPE (syms[i].symbol)->name () != NULL)
3367             {
3368               printf_filtered (("[%d] "), i + first_choice);
3369               ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
3370                               gdb_stdout, -1, 0, &type_print_raw_options);
3371               printf_filtered (_("'(%s) (enumeral)\n"),
3372                                syms[i].symbol->print_name ());
3373             }
3374           else
3375             {
3376               printf_filtered ("[%d] ", i + first_choice);
3377               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3378                                           &type_print_raw_options);
3379
3380               if (symtab != NULL)
3381                 printf_filtered (is_enumeral
3382                                  ? _(" in %s (enumeral)\n")
3383                                  : _(" at %s:?\n"),
3384                                  symtab_to_filename_for_display (symtab));
3385               else
3386                 printf_filtered (is_enumeral
3387                                  ? _(" (enumeral)\n")
3388                                  : _(" at ?\n"));
3389             }
3390         }
3391     }
3392
3393   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3394                              "overload-choice");
3395
3396   for (i = 0; i < n_chosen; i += 1)
3397     syms[i] = syms[chosen[i]];
3398
3399   return n_chosen;
3400 }
3401
3402 /* See ada-lang.h.  */
3403
3404 block_symbol
3405 ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
3406                           int nargs, value *argvec[])
3407 {
3408   if (possible_user_operator_p (op, argvec))
3409     {
3410       std::vector<struct block_symbol> candidates
3411         = ada_lookup_symbol_list (ada_decoded_op_name (op),
3412                                   NULL, VAR_DOMAIN);
3413
3414       int i = ada_resolve_function (candidates, argvec,
3415                                     nargs, ada_decoded_op_name (op), NULL,
3416                                     parse_completion);
3417       if (i >= 0)
3418         return candidates[i];
3419     }
3420   return {};
3421 }
3422
3423 /* See ada-lang.h.  */
3424
3425 block_symbol
3426 ada_resolve_funcall (struct symbol *sym, const struct block *block,
3427                      struct type *context_type,
3428                      bool parse_completion,
3429                      int nargs, value *argvec[],
3430                      innermost_block_tracker *tracker)
3431 {
3432   std::vector<struct block_symbol> candidates
3433     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3434
3435   int i;
3436   if (candidates.size () == 1)
3437     i = 0;
3438   else
3439     {
3440       i = ada_resolve_function
3441         (candidates,
3442          argvec, nargs,
3443          sym->linkage_name (),
3444          context_type, parse_completion);
3445       if (i < 0)
3446         error (_("Could not find a match for %s"), sym->print_name ());
3447     }
3448
3449   tracker->update (candidates[i]);
3450   return candidates[i];
3451 }
3452
3453 /* Resolve a mention of a name where the context type is an
3454    enumeration type.  */
3455
3456 static int
3457 ada_resolve_enum (std::vector<struct block_symbol> &syms,
3458                   const char *name, struct type *context_type,
3459                   bool parse_completion)
3460 {
3461   gdb_assert (context_type->code () == TYPE_CODE_ENUM);
3462   context_type = ada_check_typedef (context_type);
3463
3464   for (int i = 0; i < syms.size (); ++i)
3465     {
3466       /* We already know the name matches, so we're just looking for
3467          an element of the correct enum type.  */
3468       if (ada_check_typedef (SYMBOL_TYPE (syms[i].symbol)) == context_type)
3469         return i;
3470     }
3471
3472   error (_("No name '%s' in enumeration type '%s'"), name,
3473          ada_type_name (context_type));
3474 }
3475
3476 /* See ada-lang.h.  */
3477
3478 block_symbol
3479 ada_resolve_variable (struct symbol *sym, const struct block *block,
3480                       struct type *context_type,
3481                       bool parse_completion,
3482                       int deprocedure_p,
3483                       innermost_block_tracker *tracker)
3484 {
3485   std::vector<struct block_symbol> candidates
3486     = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
3487
3488   if (std::any_of (candidates.begin (),
3489                    candidates.end (),
3490                    [] (block_symbol &bsym)
3491                    {
3492                      switch (SYMBOL_CLASS (bsym.symbol))
3493                        {
3494                        case LOC_REGISTER:
3495                        case LOC_ARG:
3496                        case LOC_REF_ARG:
3497                        case LOC_REGPARM_ADDR:
3498                        case LOC_LOCAL:
3499                        case LOC_COMPUTED:
3500                          return true;
3501                        default:
3502                          return false;
3503                        }
3504                    }))
3505     {
3506       /* Types tend to get re-introduced locally, so if there
3507          are any local symbols that are not types, first filter
3508          out all types.  */
3509       candidates.erase
3510         (std::remove_if
3511          (candidates.begin (),
3512           candidates.end (),
3513           [] (block_symbol &bsym)
3514           {
3515             return SYMBOL_CLASS (bsym.symbol) == LOC_TYPEDEF;
3516           }),
3517          candidates.end ());
3518     }
3519
3520   /* Filter out artificial symbols.  */
3521   candidates.erase
3522     (std::remove_if
3523      (candidates.begin (),
3524       candidates.end (),
3525       [] (block_symbol &bsym)
3526       {
3527        return bsym.symbol->artificial;
3528       }),
3529      candidates.end ());
3530
3531   int i;
3532   if (candidates.empty ())
3533     error (_("No definition found for %s"), sym->print_name ());
3534   else if (candidates.size () == 1)
3535     i = 0;
3536   else if (context_type != nullptr
3537            && context_type->code () == TYPE_CODE_ENUM)
3538     i = ada_resolve_enum (candidates, sym->linkage_name (), context_type,
3539                           parse_completion);
3540   else if (deprocedure_p && !is_nonfunction (candidates))
3541     {
3542       i = ada_resolve_function
3543         (candidates, NULL, 0,
3544          sym->linkage_name (),
3545          context_type, parse_completion);
3546       if (i < 0)
3547         error (_("Could not find a match for %s"), sym->print_name ());
3548     }
3549   else
3550     {
3551       printf_filtered (_("Multiple matches for %s\n"), sym->print_name ());
3552       user_select_syms (candidates.data (), candidates.size (), 1);
3553       i = 0;
3554     }
3555
3556   tracker->update (candidates[i]);
3557   return candidates[i];
3558 }
3559
3560 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  */
3561 /* The term "match" here is rather loose.  The match is heuristic and
3562    liberal.  */
3563
3564 static int
3565 ada_type_match (struct type *ftype, struct type *atype)
3566 {
3567   ftype = ada_check_typedef (ftype);
3568   atype = ada_check_typedef (atype);
3569
3570   if (ftype->code () == TYPE_CODE_REF)
3571     ftype = TYPE_TARGET_TYPE (ftype);
3572   if (atype->code () == TYPE_CODE_REF)
3573     atype = TYPE_TARGET_TYPE (atype);
3574
3575   switch (ftype->code ())
3576     {
3577     default:
3578       return ftype->code () == atype->code ();
3579     case TYPE_CODE_PTR:
3580       if (atype->code () != TYPE_CODE_PTR)
3581         return 0;
3582       atype = TYPE_TARGET_TYPE (atype);
3583       /* This can only happen if the actual argument is 'null'.  */
3584       if (atype->code () == TYPE_CODE_INT && TYPE_LENGTH (atype) == 0)
3585         return 1;
3586       return ada_type_match (TYPE_TARGET_TYPE (ftype), atype);
3587     case TYPE_CODE_INT:
3588     case TYPE_CODE_ENUM:
3589     case TYPE_CODE_RANGE:
3590       switch (atype->code ())
3591         {
3592         case TYPE_CODE_INT:
3593         case TYPE_CODE_ENUM:
3594         case TYPE_CODE_RANGE:
3595           return 1;
3596         default:
3597           return 0;
3598         }
3599
3600     case TYPE_CODE_ARRAY:
3601       return (atype->code () == TYPE_CODE_ARRAY
3602               || ada_is_array_descriptor_type (atype));
3603
3604     case TYPE_CODE_STRUCT:
3605       if (ada_is_array_descriptor_type (ftype))
3606         return (atype->code () == TYPE_CODE_ARRAY
3607                 || ada_is_array_descriptor_type (atype));
3608       else
3609         return (atype->code () == TYPE_CODE_STRUCT
3610                 && !ada_is_array_descriptor_type (atype));
3611
3612     case TYPE_CODE_UNION:
3613     case TYPE_CODE_FLT:
3614       return (atype->code () == ftype->code ());
3615     }
3616 }
3617
3618 /* Return non-zero if the formals of FUNC "sufficiently match" the
3619    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3620    may also be an enumeral, in which case it is treated as a 0-
3621    argument function.  */
3622
3623 static int
3624 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3625 {
3626   int i;
3627   struct type *func_type = SYMBOL_TYPE (func);
3628
3629   if (SYMBOL_CLASS (func) == LOC_CONST
3630       && func_type->code () == TYPE_CODE_ENUM)
3631     return (n_actuals == 0);
3632   else if (func_type == NULL || func_type->code () != TYPE_CODE_FUNC)
3633     return 0;
3634
3635   if (func_type->num_fields () != n_actuals)
3636     return 0;
3637
3638   for (i = 0; i < n_actuals; i += 1)
3639     {
3640       if (actuals[i] == NULL)
3641         return 0;
3642       else
3643         {
3644           struct type *ftype = ada_check_typedef (func_type->field (i).type ());
3645           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3646
3647           if (!ada_type_match (ftype, atype))
3648             return 0;
3649         }
3650     }
3651   return 1;
3652 }
3653
3654 /* False iff function type FUNC_TYPE definitely does not produce a value
3655    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3656    FUNC_TYPE is not a valid function type with a non-null return type
3657    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3658
3659 static int
3660 return_match (struct type *func_type, struct type *context_type)
3661 {
3662   struct type *return_type;
3663
3664   if (func_type == NULL)
3665     return 1;
3666
3667   if (func_type->code () == TYPE_CODE_FUNC)
3668     return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3669   else
3670     return_type = get_base_type (func_type);
3671   if (return_type == NULL)
3672     return 1;
3673
3674   context_type = get_base_type (context_type);
3675
3676   if (return_type->code () == TYPE_CODE_ENUM)
3677     return context_type == NULL || return_type == context_type;
3678   else if (context_type == NULL)
3679     return return_type->code () != TYPE_CODE_VOID;
3680   else
3681     return return_type->code () == context_type->code ();
3682 }
3683
3684
3685 /* Returns the index in SYMS that contains the symbol for the
3686    function (if any) that matches the types of the NARGS arguments in
3687    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
3688    that returns that type, then eliminate matches that don't.  If
3689    CONTEXT_TYPE is void and there is at least one match that does not
3690    return void, eliminate all matches that do.
3691
3692    Asks the user if there is more than one match remaining.  Returns -1
3693    if there is no such symbol or none is selected.  NAME is used
3694    solely for messages.  May re-arrange and modify SYMS in
3695    the process; the index returned is for the modified vector.  */
3696
3697 static int
3698 ada_resolve_function (std::vector<struct block_symbol> &syms,
3699                       struct value **args, int nargs,
3700                       const char *name, struct type *context_type,
3701                       bool parse_completion)
3702 {
3703   int fallback;
3704   int k;
3705   int m;                        /* Number of hits */
3706
3707   m = 0;
3708   /* In the first pass of the loop, we only accept functions matching
3709      context_type.  If none are found, we add a second pass of the loop
3710      where every function is accepted.  */
3711   for (fallback = 0; m == 0 && fallback < 2; fallback++)
3712     {
3713       for (k = 0; k < syms.size (); k += 1)
3714         {
3715           struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
3716
3717           if (ada_args_match (syms[k].symbol, args, nargs)
3718               && (fallback || return_match (type, context_type)))
3719             {
3720               syms[m] = syms[k];
3721               m += 1;
3722             }
3723         }
3724     }
3725
3726   /* If we got multiple matches, ask the user which one to use.  Don't do this
3727      interactive thing during completion, though, as the purpose of the
3728      completion is providing a list of all possible matches.  Prompting the
3729      user to filter it down would be completely unexpected in this case.  */
3730   if (m == 0)
3731     return -1;
3732   else if (m > 1 && !parse_completion)
3733     {
3734       printf_filtered (_("Multiple matches for %s\n"), name);
3735       user_select_syms (syms.data (), m, 1);
3736       return 0;
3737     }
3738   return 0;
3739 }
3740
3741 /* Type-class predicates */
3742
3743 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3744    or FLOAT).  */
3745
3746 static int
3747 numeric_type_p (struct type *type)
3748 {
3749   if (type == NULL)
3750     return 0;
3751   else
3752     {
3753       switch (type->code ())
3754         {
3755         case TYPE_CODE_INT:
3756         case TYPE_CODE_FLT:
3757         case TYPE_CODE_FIXED_POINT:
3758           return 1;
3759         case TYPE_CODE_RANGE:
3760           return (type == TYPE_TARGET_TYPE (type)
3761                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
3762         default:
3763           return 0;
3764         }
3765     }
3766 }
3767
3768 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
3769
3770 static int
3771 integer_type_p (struct type *type)
3772 {
3773   if (type == NULL)
3774     return 0;
3775   else
3776     {
3777       switch (type->code ())
3778         {
3779         case TYPE_CODE_INT:
3780           return 1;
3781         case TYPE_CODE_RANGE:
3782           return (type == TYPE_TARGET_TYPE (type)
3783                   || integer_type_p (TYPE_TARGET_TYPE (type)));
3784         default:
3785           return 0;
3786         }
3787     }
3788 }
3789
3790 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
3791
3792 static int
3793 scalar_type_p (struct type *type)
3794 {
3795   if (type == NULL)
3796     return 0;
3797   else
3798     {
3799       switch (type->code ())
3800         {
3801         case TYPE_CODE_INT:
3802         case TYPE_CODE_RANGE:
3803         case TYPE_CODE_ENUM:
3804         case TYPE_CODE_FLT:
3805         case TYPE_CODE_FIXED_POINT:
3806           return 1;
3807         default:
3808           return 0;
3809         }
3810     }
3811 }
3812
3813 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
3814
3815 static int
3816 discrete_type_p (struct type *type)
3817 {
3818   if (type == NULL)
3819     return 0;
3820   else
3821     {
3822       switch (type->code ())
3823         {
3824         case TYPE_CODE_INT:
3825         case TYPE_CODE_RANGE:
3826         case TYPE_CODE_ENUM:
3827         case TYPE_CODE_BOOL:
3828           return 1;
3829         default:
3830           return 0;
3831         }
3832     }
3833 }
3834
3835 /* Returns non-zero if OP with operands in the vector ARGS could be
3836    a user-defined function.  Errs on the side of pre-defined operators
3837    (i.e., result 0).  */
3838
3839 static int
3840 possible_user_operator_p (enum exp_opcode op, struct value *args[])
3841 {
3842   struct type *type0 =
3843     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
3844   struct type *type1 =
3845     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
3846
3847   if (type0 == NULL)
3848     return 0;
3849
3850   switch (op)
3851     {
3852     default:
3853       return 0;
3854
3855     case BINOP_ADD:
3856     case BINOP_SUB:
3857     case BINOP_MUL:
3858     case BINOP_DIV:
3859       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
3860
3861     case BINOP_REM:
3862     case BINOP_MOD:
3863     case BINOP_BITWISE_AND:
3864     case BINOP_BITWISE_IOR:
3865     case BINOP_BITWISE_XOR:
3866       return (!(integer_type_p (type0) && integer_type_p (type1)));
3867
3868     case BINOP_EQUAL:
3869     case BINOP_NOTEQUAL:
3870     case BINOP_LESS:
3871     case BINOP_GTR:
3872     case BINOP_LEQ:
3873     case BINOP_GEQ:
3874       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
3875
3876     case BINOP_CONCAT:
3877       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
3878
3879     case BINOP_EXP:
3880       return (!(numeric_type_p (type0) && integer_type_p (type1)));
3881
3882     case UNOP_NEG:
3883     case UNOP_PLUS:
3884     case UNOP_LOGICAL_NOT:
3885     case UNOP_ABS:
3886       return (!numeric_type_p (type0));
3887
3888     }
3889 }
3890 \f
3891                                 /* Renaming */
3892
3893 /* NOTES: 
3894
3895    1. In the following, we assume that a renaming type's name may
3896       have an ___XD suffix.  It would be nice if this went away at some
3897       point.
3898    2. We handle both the (old) purely type-based representation of 
3899       renamings and the (new) variable-based encoding.  At some point,
3900       it is devoutly to be hoped that the former goes away 
3901       (FIXME: hilfinger-2007-07-09).
3902    3. Subprogram renamings are not implemented, although the XRS
3903       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
3904
3905 /* If SYM encodes a renaming, 
3906
3907        <renaming> renames <renamed entity>,
3908
3909    sets *LEN to the length of the renamed entity's name,
3910    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3911    the string describing the subcomponent selected from the renamed
3912    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3913    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3914    are undefined).  Otherwise, returns a value indicating the category
3915    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3916    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3917    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
3918    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3919    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3920    may be NULL, in which case they are not assigned.
3921
3922    [Currently, however, GCC does not generate subprogram renamings.]  */
3923
3924 enum ada_renaming_category
3925 ada_parse_renaming (struct symbol *sym,
3926                     const char **renamed_entity, int *len, 
3927                     const char **renaming_expr)
3928 {
3929   enum ada_renaming_category kind;
3930   const char *info;
3931   const char *suffix;
3932
3933   if (sym == NULL)
3934     return ADA_NOT_RENAMING;
3935   switch (SYMBOL_CLASS (sym)) 
3936     {
3937     default:
3938       return ADA_NOT_RENAMING;
3939     case LOC_LOCAL:
3940     case LOC_STATIC:
3941     case LOC_COMPUTED:
3942     case LOC_OPTIMIZED_OUT:
3943       info = strstr (sym->linkage_name (), "___XR");
3944       if (info == NULL)
3945         return ADA_NOT_RENAMING;
3946       switch (info[5])
3947         {
3948         case '_':
3949           kind = ADA_OBJECT_RENAMING;
3950           info += 6;
3951           break;
3952         case 'E':
3953           kind = ADA_EXCEPTION_RENAMING;
3954           info += 7;
3955           break;
3956         case 'P':
3957           kind = ADA_PACKAGE_RENAMING;
3958           info += 7;
3959           break;
3960         case 'S':
3961           kind = ADA_SUBPROGRAM_RENAMING;
3962           info += 7;
3963           break;
3964         default:
3965           return ADA_NOT_RENAMING;
3966         }
3967     }
3968
3969   if (renamed_entity != NULL)
3970     *renamed_entity = info;
3971   suffix = strstr (info, "___XE");
3972   if (suffix == NULL || suffix == info)
3973     return ADA_NOT_RENAMING;
3974   if (len != NULL)
3975     *len = strlen (info) - strlen (suffix);
3976   suffix += 5;
3977   if (renaming_expr != NULL)
3978     *renaming_expr = suffix;
3979   return kind;
3980 }
3981
3982 /* Compute the value of the given RENAMING_SYM, which is expected to
3983    be a symbol encoding a renaming expression.  BLOCK is the block
3984    used to evaluate the renaming.  */
3985
3986 static struct value *
3987 ada_read_renaming_var_value (struct symbol *renaming_sym,
3988                              const struct block *block)
3989 {
3990   const char *sym_name;
3991
3992   sym_name = renaming_sym->linkage_name ();
3993   expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
3994   return evaluate_expression (expr.get ());
3995 }
3996 \f
3997
3998                                 /* Evaluation: Function Calls */
3999
4000 /* Return an lvalue containing the value VAL.  This is the identity on
4001    lvalues, and otherwise has the side-effect of allocating memory
4002    in the inferior where a copy of the value contents is copied.  */
4003
4004 static struct value *
4005 ensure_lval (struct value *val)
4006 {
4007   if (VALUE_LVAL (val) == not_lval
4008       || VALUE_LVAL (val) == lval_internalvar)
4009     {
4010       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4011       const CORE_ADDR addr =
4012         value_as_long (value_allocate_space_in_inferior (len));
4013
4014       VALUE_LVAL (val) = lval_memory;
4015       set_value_address (val, addr);
4016       write_memory (addr, value_contents (val).data (), len);
4017     }
4018
4019   return val;
4020 }
4021
4022 /* Given ARG, a value of type (pointer or reference to a)*
4023    structure/union, extract the component named NAME from the ultimate
4024    target structure/union and return it as a value with its
4025    appropriate type.
4026
4027    The routine searches for NAME among all members of the structure itself
4028    and (recursively) among all members of any wrapper members
4029    (e.g., '_parent').
4030
4031    If NO_ERR, then simply return NULL in case of error, rather than
4032    calling error.  */
4033
4034 static struct value *
4035 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
4036 {
4037   struct type *t, *t1;
4038   struct value *v;
4039   int check_tag;
4040
4041   v = NULL;
4042   t1 = t = ada_check_typedef (value_type (arg));
4043   if (t->code () == TYPE_CODE_REF)
4044     {
4045       t1 = TYPE_TARGET_TYPE (t);
4046       if (t1 == NULL)
4047         goto BadValue;
4048       t1 = ada_check_typedef (t1);
4049       if (t1->code () == TYPE_CODE_PTR)
4050         {
4051           arg = coerce_ref (arg);
4052           t = t1;
4053         }
4054     }
4055
4056   while (t->code () == TYPE_CODE_PTR)
4057     {
4058       t1 = TYPE_TARGET_TYPE (t);
4059       if (t1 == NULL)
4060         goto BadValue;
4061       t1 = ada_check_typedef (t1);
4062       if (t1->code () == TYPE_CODE_PTR)
4063         {
4064           arg = value_ind (arg);
4065           t = t1;
4066         }
4067       else
4068         break;
4069     }
4070
4071   if (t1->code () != TYPE_CODE_STRUCT && t1->code () != TYPE_CODE_UNION)
4072     goto BadValue;
4073
4074   if (t1 == t)
4075     v = ada_search_struct_field (name, arg, 0, t);
4076   else
4077     {
4078       int bit_offset, bit_size, byte_offset;
4079       struct type *field_type;
4080       CORE_ADDR address;
4081
4082       if (t->code () == TYPE_CODE_PTR)
4083         address = value_address (ada_value_ind (arg));
4084       else
4085         address = value_address (ada_coerce_ref (arg));
4086
4087       /* Check to see if this is a tagged type.  We also need to handle
4088          the case where the type is a reference to a tagged type, but
4089          we have to be careful to exclude pointers to tagged types.
4090          The latter should be shown as usual (as a pointer), whereas
4091          a reference should mostly be transparent to the user.  */
4092
4093       if (ada_is_tagged_type (t1, 0)
4094           || (t1->code () == TYPE_CODE_REF
4095               && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
4096         {
4097           /* We first try to find the searched field in the current type.
4098              If not found then let's look in the fixed type.  */
4099
4100           if (!find_struct_field (name, t1, 0,
4101                                   nullptr, nullptr, nullptr,
4102                                   nullptr, nullptr))
4103             check_tag = 1;
4104           else
4105             check_tag = 0;
4106         }
4107       else
4108         check_tag = 0;
4109
4110       /* Convert to fixed type in all cases, so that we have proper
4111          offsets to each field in unconstrained record types.  */
4112       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4113                               address, NULL, check_tag);
4114
4115       /* Resolve the dynamic type as well.  */
4116       arg = value_from_contents_and_address (t1, nullptr, address);
4117       t1 = value_type (arg);
4118
4119       if (find_struct_field (name, t1, 0,
4120                              &field_type, &byte_offset, &bit_offset,
4121                              &bit_size, NULL))
4122         {
4123           if (bit_size != 0)
4124             {
4125               if (t->code () == TYPE_CODE_REF)
4126                 arg = ada_coerce_ref (arg);
4127               else
4128                 arg = ada_value_ind (arg);
4129               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4130                                                   bit_offset, bit_size,
4131                                                   field_type);
4132             }
4133           else
4134             v = value_at_lazy (field_type, address + byte_offset);
4135         }
4136     }
4137
4138   if (v != NULL || no_err)
4139     return v;
4140   else
4141     error (_("There is no member named %s."), name);
4142
4143  BadValue:
4144   if (no_err)
4145     return NULL;
4146   else
4147     error (_("Attempt to extract a component of "
4148              "a value that is not a record."));
4149 }
4150
4151 /* Return the value ACTUAL, converted to be an appropriate value for a
4152    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4153    allocating any necessary descriptors (fat pointers), or copies of
4154    values not residing in memory, updating it as needed.  */
4155
4156 struct value *
4157 ada_convert_actual (struct value *actual, struct type *formal_type0)
4158 {
4159   struct type *actual_type = ada_check_typedef (value_type (actual));
4160   struct type *formal_type = ada_check_typedef (formal_type0);
4161   struct type *formal_target =
4162     formal_type->code () == TYPE_CODE_PTR
4163     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4164   struct type *actual_target =
4165     actual_type->code () == TYPE_CODE_PTR
4166     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4167
4168   if (ada_is_array_descriptor_type (formal_target)
4169       && actual_target->code () == TYPE_CODE_ARRAY)
4170     return make_array_descriptor (formal_type, actual);
4171   else if (formal_type->code () == TYPE_CODE_PTR
4172            || formal_type->code () == TYPE_CODE_REF)
4173     {
4174       struct value *result;
4175
4176       if (formal_target->code () == TYPE_CODE_ARRAY
4177           && ada_is_array_descriptor_type (actual_target))
4178         result = desc_data (actual);
4179       else if (formal_type->code () != TYPE_CODE_PTR)
4180         {
4181           if (VALUE_LVAL (actual) != lval_memory)
4182             {
4183               struct value *val;
4184
4185               actual_type = ada_check_typedef (value_type (actual));
4186               val = allocate_value (actual_type);
4187               memcpy ((char *) value_contents_raw (val).data (),
4188                       (char *) value_contents (actual).data (),
4189                       TYPE_LENGTH (actual_type));
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 && !SYMBOL_OBJFILE_OWNED (sym))
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 (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4388                             GLOBAL_BLOCK) != block
4389       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
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 (SYMBOL_TYPE (sym.symbol)->code () != TYPE_CODE_FUNC
4445         && (SYMBOL_TYPE (sym.symbol)->code () != TYPE_CODE_ENUM
4446             || SYMBOL_CLASS (sym.symbol) != 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 (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4481       || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4482     return 0;
4483
4484   switch (SYMBOL_CLASS (sym0))
4485     {
4486     case LOC_UNDEF:
4487       return 1;
4488     case LOC_TYPEDEF:
4489       {
4490         struct type *type0 = SYMBOL_TYPE (sym0);
4491         struct type *type1 = SYMBOL_TYPE (sym1);
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 (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
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   memset (&result, 0, sizeof (result));
4566
4567   symbol_name_match_type match_type = name_match_type_from_name (name);
4568   lookup_name_info lookup_name (name, match_type);
4569
4570   symbol_name_matcher_ftype *match_name
4571     = ada_get_symbol_name_matcher (lookup_name);
4572
4573   for (objfile *objfile : current_program_space->objfiles ())
4574     {
4575       for (minimal_symbol *msymbol : objfile->msymbols ())
4576         {
4577           if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4578               && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4579             {
4580               result.minsym = msymbol;
4581               result.objfile = objfile;
4582               break;
4583             }
4584         }
4585     }
4586
4587   return result;
4588 }
4589
4590 /* True if TYPE is definitely an artificial type supplied to a symbol
4591    for which no debugging information was given in the symbol file.  */
4592
4593 static int
4594 is_nondebugging_type (struct type *type)
4595 {
4596   const char *name = ada_type_name (type);
4597
4598   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4599 }
4600
4601 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4602    that are deemed "identical" for practical purposes.
4603
4604    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4605    types and that their number of enumerals is identical (in other
4606    words, type1->num_fields () == type2->num_fields ()).  */
4607
4608 static int
4609 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4610 {
4611   int i;
4612
4613   /* The heuristic we use here is fairly conservative.  We consider
4614      that 2 enumerate types are identical if they have the same
4615      number of enumerals and that all enumerals have the same
4616      underlying value and name.  */
4617
4618   /* All enums in the type should have an identical underlying value.  */
4619   for (i = 0; i < type1->num_fields (); i++)
4620     if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
4621       return 0;
4622
4623   /* All enumerals should also have the same name (modulo any numerical
4624      suffix).  */
4625   for (i = 0; i < type1->num_fields (); i++)
4626     {
4627       const char *name_1 = type1->field (i).name ();
4628       const char *name_2 = type2->field (i).name ();
4629       int len_1 = strlen (name_1);
4630       int len_2 = strlen (name_2);
4631
4632       ada_remove_trailing_digits (type1->field (i).name (), &len_1);
4633       ada_remove_trailing_digits (type2->field (i).name (), &len_2);
4634       if (len_1 != len_2
4635           || strncmp (type1->field (i).name (),
4636                       type2->field (i).name (),
4637                       len_1) != 0)
4638         return 0;
4639     }
4640
4641   return 1;
4642 }
4643
4644 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4645    that are deemed "identical" for practical purposes.  Sometimes,
4646    enumerals are not strictly identical, but their types are so similar
4647    that they can be considered identical.
4648
4649    For instance, consider the following code:
4650
4651       type Color is (Black, Red, Green, Blue, White);
4652       type RGB_Color is new Color range Red .. Blue;
4653
4654    Type RGB_Color is a subrange of an implicit type which is a copy
4655    of type Color. If we call that implicit type RGB_ColorB ("B" is
4656    for "Base Type"), then type RGB_ColorB is a copy of type Color.
4657    As a result, when an expression references any of the enumeral
4658    by name (Eg. "print green"), the expression is technically
4659    ambiguous and the user should be asked to disambiguate. But
4660    doing so would only hinder the user, since it wouldn't matter
4661    what choice he makes, the outcome would always be the same.
4662    So, for practical purposes, we consider them as the same.  */
4663
4664 static int
4665 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
4666 {
4667   int i;
4668
4669   /* Before performing a thorough comparison check of each type,
4670      we perform a series of inexpensive checks.  We expect that these
4671      checks will quickly fail in the vast majority of cases, and thus
4672      help prevent the unnecessary use of a more expensive comparison.
4673      Said comparison also expects us to make some of these checks
4674      (see ada_identical_enum_types_p).  */
4675
4676   /* Quick check: All symbols should have an enum type.  */
4677   for (i = 0; i < syms.size (); i++)
4678     if (SYMBOL_TYPE (syms[i].symbol)->code () != TYPE_CODE_ENUM)
4679       return 0;
4680
4681   /* Quick check: They should all have the same value.  */
4682   for (i = 1; i < syms.size (); i++)
4683     if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
4684       return 0;
4685
4686   /* Quick check: They should all have the same number of enumerals.  */
4687   for (i = 1; i < syms.size (); i++)
4688     if (SYMBOL_TYPE (syms[i].symbol)->num_fields ()
4689         != SYMBOL_TYPE (syms[0].symbol)->num_fields ())
4690       return 0;
4691
4692   /* All the sanity checks passed, so we might have a set of
4693      identical enumeration types.  Perform a more complete
4694      comparison of the type of each symbol.  */
4695   for (i = 1; i < syms.size (); i++)
4696     if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
4697                                      SYMBOL_TYPE (syms[0].symbol)))
4698       return 0;
4699
4700   return 1;
4701 }
4702
4703 /* Remove any non-debugging symbols in SYMS that definitely
4704    duplicate other symbols in the list (The only case I know of where
4705    this happens is when object files containing stabs-in-ecoff are
4706    linked with files containing ordinary ecoff debugging symbols (or no
4707    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.  */
4708
4709 static void
4710 remove_extra_symbols (std::vector<struct block_symbol> *syms)
4711 {
4712   int i, j;
4713
4714   /* We should never be called with less than 2 symbols, as there
4715      cannot be any extra symbol in that case.  But it's easy to
4716      handle, since we have nothing to do in that case.  */
4717   if (syms->size () < 2)
4718     return;
4719
4720   i = 0;
4721   while (i < syms->size ())
4722     {
4723       int remove_p = 0;
4724
4725       /* If two symbols have the same name and one of them is a stub type,
4726          the get rid of the stub.  */
4727
4728       if (SYMBOL_TYPE ((*syms)[i].symbol)->is_stub ()
4729           && (*syms)[i].symbol->linkage_name () != NULL)
4730         {
4731           for (j = 0; j < syms->size (); j++)
4732             {
4733               if (j != i
4734                   && !SYMBOL_TYPE ((*syms)[j].symbol)->is_stub ()
4735                   && (*syms)[j].symbol->linkage_name () != NULL
4736                   && strcmp ((*syms)[i].symbol->linkage_name (),
4737                              (*syms)[j].symbol->linkage_name ()) == 0)
4738                 remove_p = 1;
4739             }
4740         }
4741
4742       /* Two symbols with the same name, same class and same address
4743          should be identical.  */
4744
4745       else if ((*syms)[i].symbol->linkage_name () != NULL
4746           && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
4747           && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
4748         {
4749           for (j = 0; j < syms->size (); j += 1)
4750             {
4751               if (i != j
4752                   && (*syms)[j].symbol->linkage_name () != NULL
4753                   && strcmp ((*syms)[i].symbol->linkage_name (),
4754                              (*syms)[j].symbol->linkage_name ()) == 0
4755                   && SYMBOL_CLASS ((*syms)[i].symbol)
4756                        == SYMBOL_CLASS ((*syms)[j].symbol)
4757                   && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
4758                   == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
4759                 remove_p = 1;
4760             }
4761         }
4762       
4763       if (remove_p)
4764         syms->erase (syms->begin () + i);
4765       else
4766         i += 1;
4767     }
4768
4769   /* If all the remaining symbols are identical enumerals, then
4770      just keep the first one and discard the rest.
4771
4772      Unlike what we did previously, we do not discard any entry
4773      unless they are ALL identical.  This is because the symbol
4774      comparison is not a strict comparison, but rather a practical
4775      comparison.  If all symbols are considered identical, then
4776      we can just go ahead and use the first one and discard the rest.
4777      But if we cannot reduce the list to a single element, we have
4778      to ask the user to disambiguate anyways.  And if we have to
4779      present a multiple-choice menu, it's less confusing if the list
4780      isn't missing some choices that were identical and yet distinct.  */
4781   if (symbols_are_identical_enums (*syms))
4782     syms->resize (1);
4783 }
4784
4785 /* Given a type that corresponds to a renaming entity, use the type name
4786    to extract the scope (package name or function name, fully qualified,
4787    and following the GNAT encoding convention) where this renaming has been
4788    defined.  */
4789
4790 static std::string
4791 xget_renaming_scope (struct type *renaming_type)
4792 {
4793   /* The renaming types adhere to the following convention:
4794      <scope>__<rename>___<XR extension>.
4795      So, to extract the scope, we search for the "___XR" extension,
4796      and then backtrack until we find the first "__".  */
4797
4798   const char *name = renaming_type->name ();
4799   const char *suffix = strstr (name, "___XR");
4800   const char *last;
4801
4802   /* Now, backtrack a bit until we find the first "__".  Start looking
4803      at suffix - 3, as the <rename> part is at least one character long.  */
4804
4805   for (last = suffix - 3; last > name; last--)
4806     if (last[0] == '_' && last[1] == '_')
4807       break;
4808
4809   /* Make a copy of scope and return it.  */
4810   return std::string (name, last);
4811 }
4812
4813 /* Return nonzero if NAME corresponds to a package name.  */
4814
4815 static int
4816 is_package_name (const char *name)
4817 {
4818   /* Here, We take advantage of the fact that no symbols are generated
4819      for packages, while symbols are generated for each function.
4820      So the condition for NAME represent a package becomes equivalent
4821      to NAME not existing in our list of symbols.  There is only one
4822      small complication with library-level functions (see below).  */
4823
4824   /* If it is a function that has not been defined at library level,
4825      then we should be able to look it up in the symbols.  */
4826   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4827     return 0;
4828
4829   /* Library-level function names start with "_ada_".  See if function
4830      "_ada_" followed by NAME can be found.  */
4831
4832   /* Do a quick check that NAME does not contain "__", since library-level
4833      functions names cannot contain "__" in them.  */
4834   if (strstr (name, "__") != NULL)
4835     return 0;
4836
4837   std::string fun_name = string_printf ("_ada_%s", name);
4838
4839   return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
4840 }
4841
4842 /* Return nonzero if SYM corresponds to a renaming entity that is
4843    not visible from FUNCTION_NAME.  */
4844
4845 static int
4846 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
4847 {
4848   if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4849     return 0;
4850
4851   std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
4852
4853   /* If the rename has been defined in a package, then it is visible.  */
4854   if (is_package_name (scope.c_str ()))
4855     return 0;
4856
4857   /* Check that the rename is in the current function scope by checking
4858      that its name starts with SCOPE.  */
4859
4860   /* If the function name starts with "_ada_", it means that it is
4861      a library-level function.  Strip this prefix before doing the
4862      comparison, as the encoding for the renaming does not contain
4863      this prefix.  */
4864   if (startswith (function_name, "_ada_"))
4865     function_name += 5;
4866
4867   return !startswith (function_name, scope.c_str ());
4868 }
4869
4870 /* Remove entries from SYMS that corresponds to a renaming entity that
4871    is not visible from the function associated with CURRENT_BLOCK or
4872    that is superfluous due to the presence of more specific renaming
4873    information.  Places surviving symbols in the initial entries of
4874    SYMS.
4875
4876    Rationale:
4877    First, in cases where an object renaming is implemented as a
4878    reference variable, GNAT may produce both the actual reference
4879    variable and the renaming encoding.  In this case, we discard the
4880    latter.
4881
4882    Second, GNAT emits a type following a specified encoding for each renaming
4883    entity.  Unfortunately, STABS currently does not support the definition
4884    of types that are local to a given lexical block, so all renamings types
4885    are emitted at library level.  As a consequence, if an application
4886    contains two renaming entities using the same name, and a user tries to
4887    print the value of one of these entities, the result of the ada symbol
4888    lookup will also contain the wrong renaming type.
4889
4890    This function partially covers for this limitation by attempting to
4891    remove from the SYMS list renaming symbols that should be visible
4892    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
4893    method with the current information available.  The implementation
4894    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
4895    
4896       - When the user tries to print a rename in a function while there
4897         is another rename entity defined in a package:  Normally, the
4898         rename in the function has precedence over the rename in the
4899         package, so the latter should be removed from the list.  This is
4900         currently not the case.
4901         
4902       - This function will incorrectly remove valid renames if
4903         the CURRENT_BLOCK corresponds to a function which symbol name
4904         has been changed by an "Export" pragma.  As a consequence,
4905         the user will be unable to print such rename entities.  */
4906
4907 static void
4908 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
4909                              const struct block *current_block)
4910 {
4911   struct symbol *current_function;
4912   const char *current_function_name;
4913   int i;
4914   int is_new_style_renaming;
4915
4916   /* If there is both a renaming foo___XR... encoded as a variable and
4917      a simple variable foo in the same block, discard the latter.
4918      First, zero out such symbols, then compress.  */
4919   is_new_style_renaming = 0;
4920   for (i = 0; i < syms->size (); i += 1)
4921     {
4922       struct symbol *sym = (*syms)[i].symbol;
4923       const struct block *block = (*syms)[i].block;
4924       const char *name;
4925       const char *suffix;
4926
4927       if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4928         continue;
4929       name = sym->linkage_name ();
4930       suffix = strstr (name, "___XR");
4931
4932       if (suffix != NULL)
4933         {
4934           int name_len = suffix - name;
4935           int j;
4936
4937           is_new_style_renaming = 1;
4938           for (j = 0; j < syms->size (); j += 1)
4939             if (i != j && (*syms)[j].symbol != NULL
4940                 && strncmp (name, (*syms)[j].symbol->linkage_name (),
4941                             name_len) == 0
4942                 && block == (*syms)[j].block)
4943               (*syms)[j].symbol = NULL;
4944         }
4945     }
4946   if (is_new_style_renaming)
4947     {
4948       int j, k;
4949
4950       for (j = k = 0; j < syms->size (); j += 1)
4951         if ((*syms)[j].symbol != NULL)
4952             {
4953               (*syms)[k] = (*syms)[j];
4954               k += 1;
4955             }
4956       syms->resize (k);
4957       return;
4958     }
4959
4960   /* Extract the function name associated to CURRENT_BLOCK.
4961      Abort if unable to do so.  */
4962
4963   if (current_block == NULL)
4964     return;
4965
4966   current_function = block_linkage_function (current_block);
4967   if (current_function == NULL)
4968     return;
4969
4970   current_function_name = current_function->linkage_name ();
4971   if (current_function_name == NULL)
4972     return;
4973
4974   /* Check each of the symbols, and remove it from the list if it is
4975      a type corresponding to a renaming that is out of the scope of
4976      the current block.  */
4977
4978   i = 0;
4979   while (i < syms->size ())
4980     {
4981       if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
4982           == ADA_OBJECT_RENAMING
4983           && old_renaming_is_invisible ((*syms)[i].symbol,
4984                                         current_function_name))
4985         syms->erase (syms->begin () + i);
4986       else
4987         i += 1;
4988     }
4989 }
4990
4991 /* Add to RESULT all symbols from BLOCK (and its super-blocks)
4992    whose name and domain match LOOKUP_NAME and DOMAIN respectively.
4993
4994    Note: This function assumes that RESULT is empty.  */
4995
4996 static void
4997 ada_add_local_symbols (std::vector<struct block_symbol> &result,
4998                        const lookup_name_info &lookup_name,
4999                        const struct block *block, domain_enum domain)
5000 {
5001   while (block != NULL)
5002     {
5003       ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5004
5005       /* If we found a non-function match, assume that's the one.  We
5006          only check this when finding a function boundary, so that we
5007          can accumulate all results from intervening blocks first.  */
5008       if (BLOCK_FUNCTION (block) != nullptr && is_nonfunction (result))
5009         return;
5010
5011       block = BLOCK_SUPERBLOCK (block);
5012     }
5013 }
5014
5015 /* An object of this type is used as the callback argument when
5016    calling the map_matching_symbols method.  */
5017
5018 struct match_data
5019 {
5020   explicit match_data (std::vector<struct block_symbol> *rp)
5021     : resultp (rp)
5022   {
5023   }
5024   DISABLE_COPY_AND_ASSIGN (match_data);
5025
5026   bool operator() (struct block_symbol *bsym);
5027
5028   struct objfile *objfile = nullptr;
5029   std::vector<struct block_symbol> *resultp;
5030   struct symbol *arg_sym = nullptr;
5031   bool found_sym = false;
5032 };
5033
5034 /* A callback for add_nonlocal_symbols that adds symbol, found in
5035    BSYM, to a list of symbols.  */
5036
5037 bool
5038 match_data::operator() (struct block_symbol *bsym)
5039 {
5040   const struct block *block = bsym->block;
5041   struct symbol *sym = bsym->symbol;
5042
5043   if (sym == NULL)
5044     {
5045       if (!found_sym && arg_sym != NULL)
5046         add_defn_to_vec (*resultp,
5047                          fixup_symbol_section (arg_sym, objfile),
5048                          block);
5049       found_sym = false;
5050       arg_sym = NULL;
5051     }
5052   else 
5053     {
5054       if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5055         return true;
5056       else if (SYMBOL_IS_ARGUMENT (sym))
5057         arg_sym = sym;
5058       else
5059         {
5060           found_sym = true;
5061           add_defn_to_vec (*resultp,
5062                            fixup_symbol_section (sym, objfile),
5063                            block);
5064         }
5065     }
5066   return true;
5067 }
5068
5069 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5070    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5071    symbols to RESULT.  Return whether we found such symbols.  */
5072
5073 static int
5074 ada_add_block_renamings (std::vector<struct block_symbol> &result,
5075                          const struct block *block,
5076                          const lookup_name_info &lookup_name,
5077                          domain_enum domain)
5078 {
5079   struct using_direct *renaming;
5080   int defns_mark = result.size ();
5081
5082   symbol_name_matcher_ftype *name_match
5083     = ada_get_symbol_name_matcher (lookup_name);
5084
5085   for (renaming = block_using (block);
5086        renaming != NULL;
5087        renaming = renaming->next)
5088     {
5089       const char *r_name;
5090
5091       /* Avoid infinite recursions: skip this renaming if we are actually
5092          already traversing it.
5093
5094          Currently, symbol lookup in Ada don't use the namespace machinery from
5095          C++/Fortran support: skip namespace imports that use them.  */
5096       if (renaming->searched
5097           || (renaming->import_src != NULL
5098               && renaming->import_src[0] != '\0')
5099           || (renaming->import_dest != NULL
5100               && renaming->import_dest[0] != '\0'))
5101         continue;
5102       renaming->searched = 1;
5103
5104       /* TODO: here, we perform another name-based symbol lookup, which can
5105          pull its own multiple overloads.  In theory, we should be able to do
5106          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5107          not a simple name.  But in order to do this, we would need to enhance
5108          the DWARF reader to associate a symbol to this renaming, instead of a
5109          name.  So, for now, we do something simpler: re-use the C++/Fortran
5110          namespace machinery.  */
5111       r_name = (renaming->alias != NULL
5112                 ? renaming->alias
5113                 : renaming->declaration);
5114       if (name_match (r_name, lookup_name, NULL))
5115         {
5116           lookup_name_info decl_lookup_name (renaming->declaration,
5117                                              lookup_name.match_type ());
5118           ada_add_all_symbols (result, block, decl_lookup_name, domain,
5119                                1, NULL);
5120         }
5121       renaming->searched = 0;
5122     }
5123   return result.size () != defns_mark;
5124 }
5125
5126 /* Implements compare_names, but only applying the comparision using
5127    the given CASING.  */
5128
5129 static int
5130 compare_names_with_case (const char *string1, const char *string2,
5131                          enum case_sensitivity casing)
5132 {
5133   while (*string1 != '\0' && *string2 != '\0')
5134     {
5135       char c1, c2;
5136
5137       if (isspace (*string1) || isspace (*string2))
5138         return strcmp_iw_ordered (string1, string2);
5139
5140       if (casing == case_sensitive_off)
5141         {
5142           c1 = tolower (*string1);
5143           c2 = tolower (*string2);
5144         }
5145       else
5146         {
5147           c1 = *string1;
5148           c2 = *string2;
5149         }
5150       if (c1 != c2)
5151         break;
5152
5153       string1 += 1;
5154       string2 += 1;
5155     }
5156
5157   switch (*string1)
5158     {
5159     case '(':
5160       return strcmp_iw_ordered (string1, string2);
5161     case '_':
5162       if (*string2 == '\0')
5163         {
5164           if (is_name_suffix (string1))
5165             return 0;
5166           else
5167             return 1;
5168         }
5169       /* FALLTHROUGH */
5170     default:
5171       if (*string2 == '(')
5172         return strcmp_iw_ordered (string1, string2);
5173       else
5174         {
5175           if (casing == case_sensitive_off)
5176             return tolower (*string1) - tolower (*string2);
5177           else
5178             return *string1 - *string2;
5179         }
5180     }
5181 }
5182
5183 /* Compare STRING1 to STRING2, with results as for strcmp.
5184    Compatible with strcmp_iw_ordered in that...
5185
5186        strcmp_iw_ordered (STRING1, STRING2) <= 0
5187
5188    ... implies...
5189
5190        compare_names (STRING1, STRING2) <= 0
5191
5192    (they may differ as to what symbols compare equal).  */
5193
5194 static int
5195 compare_names (const char *string1, const char *string2)
5196 {
5197   int result;
5198
5199   /* Similar to what strcmp_iw_ordered does, we need to perform
5200      a case-insensitive comparison first, and only resort to
5201      a second, case-sensitive, comparison if the first one was
5202      not sufficient to differentiate the two strings.  */
5203
5204   result = compare_names_with_case (string1, string2, case_sensitive_off);
5205   if (result == 0)
5206     result = compare_names_with_case (string1, string2, case_sensitive_on);
5207
5208   return result;
5209 }
5210
5211 /* Convenience function to get at the Ada encoded lookup name for
5212    LOOKUP_NAME, as a C string.  */
5213
5214 static const char *
5215 ada_lookup_name (const lookup_name_info &lookup_name)
5216 {
5217   return lookup_name.ada ().lookup_name ().c_str ();
5218 }
5219
5220 /* A helper for add_nonlocal_symbols.  Call expand_matching_symbols
5221    for OBJFILE, then walk the objfile's symtabs and update the
5222    results.  */
5223
5224 static void
5225 map_matching_symbols (struct objfile *objfile,
5226                       const lookup_name_info &lookup_name,
5227                       bool is_wild_match,
5228                       domain_enum domain,
5229                       int global,
5230                       match_data &data)
5231 {
5232   data.objfile = objfile;
5233   objfile->expand_matching_symbols (lookup_name, domain, global,
5234                                     is_wild_match ? nullptr : compare_names);
5235
5236   const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
5237   for (compunit_symtab *symtab : objfile->compunits ())
5238     {
5239       const struct block *block
5240         = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (symtab), block_kind);
5241       if (!iterate_over_symbols_terminated (block, lookup_name,
5242                                             domain, data))
5243         break;
5244     }
5245 }
5246
5247 /* Add to RESULT all non-local symbols whose name and domain match
5248    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5249    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5250    symbols otherwise.  */
5251
5252 static void
5253 add_nonlocal_symbols (std::vector<struct block_symbol> &result,
5254                       const lookup_name_info &lookup_name,
5255                       domain_enum domain, int global)
5256 {
5257   struct match_data data (&result);
5258
5259   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5260
5261   for (objfile *objfile : current_program_space->objfiles ())
5262     {
5263       map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
5264                             global, data);
5265
5266       for (compunit_symtab *cu : objfile->compunits ())
5267         {
5268           const struct block *global_block
5269             = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5270
5271           if (ada_add_block_renamings (result, global_block, lookup_name,
5272                                        domain))
5273             data.found_sym = true;
5274         }
5275     }
5276
5277   if (result.empty () && global && !is_wild_match)
5278     {
5279       const char *name = ada_lookup_name (lookup_name);
5280       std::string bracket_name = std::string ("<_ada_") + name + '>';
5281       lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
5282
5283       for (objfile *objfile : current_program_space->objfiles ())
5284         map_matching_symbols (objfile, name1, false, domain, global, data);
5285     }
5286 }
5287
5288 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5289    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5290    returning the number of matches.  Add these to RESULT.
5291
5292    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5293    symbol match within the nest of blocks whose innermost member is BLOCK,
5294    is the one match returned (no other matches in that or
5295    enclosing blocks is returned).  If there are any matches in or
5296    surrounding BLOCK, then these alone are returned.
5297
5298    Names prefixed with "standard__" are handled specially:
5299    "standard__" is first stripped off (by the lookup_name
5300    constructor), and only static and global symbols are searched.
5301
5302    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5303    to lookup global symbols.  */
5304
5305 static void
5306 ada_add_all_symbols (std::vector<struct block_symbol> &result,
5307                      const struct block *block,
5308                      const lookup_name_info &lookup_name,
5309                      domain_enum domain,
5310                      int full_search,
5311                      int *made_global_lookup_p)
5312 {
5313   struct symbol *sym;
5314
5315   if (made_global_lookup_p)
5316     *made_global_lookup_p = 0;
5317
5318   /* Special case: If the user specifies a symbol name inside package
5319      Standard, do a non-wild matching of the symbol name without
5320      the "standard__" prefix.  This was primarily introduced in order
5321      to allow the user to specifically access the standard exceptions
5322      using, for instance, Standard.Constraint_Error when Constraint_Error
5323      is ambiguous (due to the user defining its own Constraint_Error
5324      entity inside its program).  */
5325   if (lookup_name.ada ().standard_p ())
5326     block = NULL;
5327
5328   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5329
5330   if (block != NULL)
5331     {
5332       if (full_search)
5333         ada_add_local_symbols (result, lookup_name, block, domain);
5334       else
5335         {
5336           /* In the !full_search case we're are being called by
5337              iterate_over_symbols, and we don't want to search
5338              superblocks.  */
5339           ada_add_block_symbols (result, block, lookup_name, domain, NULL);
5340         }
5341       if (!result.empty () || !full_search)
5342         return;
5343     }
5344
5345   /* No non-global symbols found.  Check our cache to see if we have
5346      already performed this search before.  If we have, then return
5347      the same result.  */
5348
5349   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5350                             domain, &sym, &block))
5351     {
5352       if (sym != NULL)
5353         add_defn_to_vec (result, sym, block);
5354       return;
5355     }
5356
5357   if (made_global_lookup_p)
5358     *made_global_lookup_p = 1;
5359
5360   /* Search symbols from all global blocks.  */
5361  
5362   add_nonlocal_symbols (result, lookup_name, domain, 1);
5363
5364   /* Now add symbols from all per-file blocks if we've gotten no hits
5365      (not strictly correct, but perhaps better than an error).  */
5366
5367   if (result.empty ())
5368     add_nonlocal_symbols (result, lookup_name, domain, 0);
5369 }
5370
5371 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5372    is non-zero, enclosing scope and in global scopes.
5373
5374    Returns (SYM,BLOCK) tuples, indicating the symbols found and the
5375    blocks and symbol tables (if any) in which they were found.
5376
5377    When full_search is non-zero, any non-function/non-enumeral
5378    symbol match within the nest of blocks whose innermost member is BLOCK,
5379    is the one match returned (no other matches in that or
5380    enclosing blocks is returned).  If there are any matches in or
5381    surrounding BLOCK, then these alone are returned.
5382
5383    Names prefixed with "standard__" are handled specially: "standard__"
5384    is first stripped off, and only static and global symbols are searched.  */
5385
5386 static std::vector<struct block_symbol>
5387 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5388                                const struct block *block,
5389                                domain_enum domain,
5390                                int full_search)
5391 {
5392   int syms_from_global_search;
5393   std::vector<struct block_symbol> results;
5394
5395   ada_add_all_symbols (results, block, lookup_name,
5396                        domain, full_search, &syms_from_global_search);
5397
5398   remove_extra_symbols (&results);
5399
5400   if (results.empty () && full_search && syms_from_global_search)
5401     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5402
5403   if (results.size () == 1 && full_search && syms_from_global_search)
5404     cache_symbol (ada_lookup_name (lookup_name), domain,
5405                   results[0].symbol, results[0].block);
5406
5407   remove_irrelevant_renamings (&results, block);
5408   return results;
5409 }
5410
5411 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5412    in global scopes, returning (SYM,BLOCK) tuples.
5413
5414    See ada_lookup_symbol_list_worker for further details.  */
5415
5416 std::vector<struct block_symbol>
5417 ada_lookup_symbol_list (const char *name, const struct block *block,
5418                         domain_enum domain)
5419 {
5420   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5421   lookup_name_info lookup_name (name, name_match_type);
5422
5423   return ada_lookup_symbol_list_worker (lookup_name, block, domain, 1);
5424 }
5425
5426 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5427    to 1, but choosing the first symbol found if there are multiple
5428    choices.
5429
5430    The result is stored in *INFO, which must be non-NULL.
5431    If no match is found, INFO->SYM is set to NULL.  */
5432
5433 void
5434 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5435                            domain_enum domain,
5436                            struct block_symbol *info)
5437 {
5438   /* Since we already have an encoded name, wrap it in '<>' to force a
5439      verbatim match.  Otherwise, if the name happens to not look like
5440      an encoded name (because it doesn't include a "__"),
5441      ada_lookup_name_info would re-encode/fold it again, and that
5442      would e.g., incorrectly lowercase object renaming names like
5443      "R28b" -> "r28b".  */
5444   std::string verbatim = add_angle_brackets (name);
5445
5446   gdb_assert (info != NULL);
5447   *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5448 }
5449
5450 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5451    scope and in global scopes, or NULL if none.  NAME is folded and
5452    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5453    choosing the first symbol if there are multiple choices.  */
5454
5455 struct block_symbol
5456 ada_lookup_symbol (const char *name, const struct block *block0,
5457                    domain_enum domain)
5458 {
5459   std::vector<struct block_symbol> candidates
5460     = ada_lookup_symbol_list (name, block0, domain);
5461
5462   if (candidates.empty ())
5463     return {};
5464
5465   block_symbol info = candidates[0];
5466   info.symbol = fixup_symbol_section (info.symbol, NULL);
5467   return info;
5468 }
5469
5470
5471 /* True iff STR is a possible encoded suffix of a normal Ada name
5472    that is to be ignored for matching purposes.  Suffixes of parallel
5473    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5474    are given by any of the regular expressions:
5475
5476    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5477    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5478    TKB              [subprogram suffix for task bodies]
5479    _E[0-9]+[bs]$    [protected object entry suffixes]
5480    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5481
5482    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5483    match is performed.  This sequence is used to differentiate homonyms,
5484    is an optional part of a valid name suffix.  */
5485
5486 static int
5487 is_name_suffix (const char *str)
5488 {
5489   int k;
5490   const char *matching;
5491   const int len = strlen (str);
5492
5493   /* Skip optional leading __[0-9]+.  */
5494
5495   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5496     {
5497       str += 3;
5498       while (isdigit (str[0]))
5499         str += 1;
5500     }
5501   
5502   /* [.$][0-9]+ */
5503
5504   if (str[0] == '.' || str[0] == '$')
5505     {
5506       matching = str + 1;
5507       while (isdigit (matching[0]))
5508         matching += 1;
5509       if (matching[0] == '\0')
5510         return 1;
5511     }
5512
5513   /* ___[0-9]+ */
5514
5515   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5516     {
5517       matching = str + 3;
5518       while (isdigit (matching[0]))
5519         matching += 1;
5520       if (matching[0] == '\0')
5521         return 1;
5522     }
5523
5524   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
5525
5526   if (strcmp (str, "TKB") == 0)
5527     return 1;
5528
5529 #if 0
5530   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5531      with a N at the end.  Unfortunately, the compiler uses the same
5532      convention for other internal types it creates.  So treating
5533      all entity names that end with an "N" as a name suffix causes
5534      some regressions.  For instance, consider the case of an enumerated
5535      type.  To support the 'Image attribute, it creates an array whose
5536      name ends with N.
5537      Having a single character like this as a suffix carrying some
5538      information is a bit risky.  Perhaps we should change the encoding
5539      to be something like "_N" instead.  In the meantime, do not do
5540      the following check.  */
5541   /* Protected Object Subprograms */
5542   if (len == 1 && str [0] == 'N')
5543     return 1;
5544 #endif
5545
5546   /* _E[0-9]+[bs]$ */
5547   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5548     {
5549       matching = str + 3;
5550       while (isdigit (matching[0]))
5551         matching += 1;
5552       if ((matching[0] == 'b' || matching[0] == 's')
5553           && matching [1] == '\0')
5554         return 1;
5555     }
5556
5557   /* ??? We should not modify STR directly, as we are doing below.  This
5558      is fine in this case, but may become problematic later if we find
5559      that this alternative did not work, and want to try matching
5560      another one from the begining of STR.  Since we modified it, we
5561      won't be able to find the begining of the string anymore!  */
5562   if (str[0] == 'X')
5563     {
5564       str += 1;
5565       while (str[0] != '_' && str[0] != '\0')
5566         {
5567           if (str[0] != 'n' && str[0] != 'b')
5568             return 0;
5569           str += 1;
5570         }
5571     }
5572
5573   if (str[0] == '\000')
5574     return 1;
5575
5576   if (str[0] == '_')
5577     {
5578       if (str[1] != '_' || str[2] == '\000')
5579         return 0;
5580       if (str[2] == '_')
5581         {
5582           if (strcmp (str + 3, "JM") == 0)
5583             return 1;
5584           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5585              the LJM suffix in favor of the JM one.  But we will
5586              still accept LJM as a valid suffix for a reasonable
5587              amount of time, just to allow ourselves to debug programs
5588              compiled using an older version of GNAT.  */
5589           if (strcmp (str + 3, "LJM") == 0)
5590             return 1;
5591           if (str[3] != 'X')
5592             return 0;
5593           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5594               || str[4] == 'U' || str[4] == 'P')
5595             return 1;
5596           if (str[4] == 'R' && str[5] != 'T')
5597             return 1;
5598           return 0;
5599         }
5600       if (!isdigit (str[2]))
5601         return 0;
5602       for (k = 3; str[k] != '\0'; k += 1)
5603         if (!isdigit (str[k]) && str[k] != '_')
5604           return 0;
5605       return 1;
5606     }
5607   if (str[0] == '$' && isdigit (str[1]))
5608     {
5609       for (k = 2; str[k] != '\0'; k += 1)
5610         if (!isdigit (str[k]) && str[k] != '_')
5611           return 0;
5612       return 1;
5613     }
5614   return 0;
5615 }
5616
5617 /* Return non-zero if the string starting at NAME and ending before
5618    NAME_END contains no capital letters.  */
5619
5620 static int
5621 is_valid_name_for_wild_match (const char *name0)
5622 {
5623   std::string decoded_name = ada_decode (name0);
5624   int i;
5625
5626   /* If the decoded name starts with an angle bracket, it means that
5627      NAME0 does not follow the GNAT encoding format.  It should then
5628      not be allowed as a possible wild match.  */
5629   if (decoded_name[0] == '<')
5630     return 0;
5631
5632   for (i=0; decoded_name[i] != '\0'; i++)
5633     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5634       return 0;
5635
5636   return 1;
5637 }
5638
5639 /* Advance *NAMEP to next occurrence in the string NAME0 of the TARGET0
5640    character which could start a simple name.  Assumes that *NAMEP points
5641    somewhere inside the string beginning at NAME0.  */
5642
5643 static int
5644 advance_wild_match (const char **namep, const char *name0, char target0)
5645 {
5646   const char *name = *namep;
5647
5648   while (1)
5649     {
5650       char t0, t1;
5651
5652       t0 = *name;
5653       if (t0 == '_')
5654         {
5655           t1 = name[1];
5656           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5657             {
5658               name += 1;
5659               if (name == name0 + 5 && startswith (name0, "_ada"))
5660                 break;
5661               else
5662                 name += 1;
5663             }
5664           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5665                                  || name[2] == target0))
5666             {
5667               name += 2;
5668               break;
5669             }
5670           else if (t1 == '_' && name[2] == 'B' && name[3] == '_')
5671             {
5672               /* Names like "pkg__B_N__name", where N is a number, are
5673                  block-local.  We can handle these by simply skipping
5674                  the "B_" here.  */
5675               name += 4;
5676             }
5677           else
5678             return 0;
5679         }
5680       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5681         name += 1;
5682       else
5683         return 0;
5684     }
5685
5686   *namep = name;
5687   return 1;
5688 }
5689
5690 /* Return true iff NAME encodes a name of the form prefix.PATN.
5691    Ignores any informational suffixes of NAME (i.e., for which
5692    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
5693    simple name.  */
5694
5695 static bool
5696 wild_match (const char *name, const char *patn)
5697 {
5698   const char *p;
5699   const char *name0 = name;
5700
5701   while (1)
5702     {
5703       const char *match = name;
5704
5705       if (*name == *patn)
5706         {
5707           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5708             if (*p != *name)
5709               break;
5710           if (*p == '\0' && is_name_suffix (name))
5711             return match == name0 || is_valid_name_for_wild_match (name0);
5712
5713           if (name[-1] == '_')
5714             name -= 1;
5715         }
5716       if (!advance_wild_match (&name, name0, *patn))
5717         return false;
5718     }
5719 }
5720
5721 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to RESULT (if
5722    necessary).  OBJFILE is the section containing BLOCK.  */
5723
5724 static void
5725 ada_add_block_symbols (std::vector<struct block_symbol> &result,
5726                        const struct block *block,
5727                        const lookup_name_info &lookup_name,
5728                        domain_enum domain, struct objfile *objfile)
5729 {
5730   struct block_iterator iter;
5731   /* A matching argument symbol, if any.  */
5732   struct symbol *arg_sym;
5733   /* Set true when we find a matching non-argument symbol.  */
5734   bool found_sym;
5735   struct symbol *sym;
5736
5737   arg_sym = NULL;
5738   found_sym = false;
5739   for (sym = block_iter_match_first (block, lookup_name, &iter);
5740        sym != NULL;
5741        sym = block_iter_match_next (lookup_name, &iter))
5742     {
5743       if (symbol_matches_domain (sym->language (), SYMBOL_DOMAIN (sym), domain))
5744         {
5745           if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5746             {
5747               if (SYMBOL_IS_ARGUMENT (sym))
5748                 arg_sym = sym;
5749               else
5750                 {
5751                   found_sym = true;
5752                   add_defn_to_vec (result,
5753                                    fixup_symbol_section (sym, objfile),
5754                                    block);
5755                 }
5756             }
5757         }
5758     }
5759
5760   /* Handle renamings.  */
5761
5762   if (ada_add_block_renamings (result, block, lookup_name, domain))
5763     found_sym = true;
5764
5765   if (!found_sym && arg_sym != NULL)
5766     {
5767       add_defn_to_vec (result,
5768                        fixup_symbol_section (arg_sym, objfile),
5769                        block);
5770     }
5771
5772   if (!lookup_name.ada ().wild_match_p ())
5773     {
5774       arg_sym = NULL;
5775       found_sym = false;
5776       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
5777       const char *name = ada_lookup_name.c_str ();
5778       size_t name_len = ada_lookup_name.size ();
5779
5780       ALL_BLOCK_SYMBOLS (block, iter, sym)
5781       {
5782         if (symbol_matches_domain (sym->language (),
5783                                    SYMBOL_DOMAIN (sym), domain))
5784           {
5785             int cmp;
5786
5787             cmp = (int) '_' - (int) sym->linkage_name ()[0];
5788             if (cmp == 0)
5789               {
5790                 cmp = !startswith (sym->linkage_name (), "_ada_");
5791                 if (cmp == 0)
5792                   cmp = strncmp (name, sym->linkage_name () + 5,
5793                                  name_len);
5794               }
5795
5796             if (cmp == 0
5797                 && is_name_suffix (sym->linkage_name () + name_len + 5))
5798               {
5799                 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5800                   {
5801                     if (SYMBOL_IS_ARGUMENT (sym))
5802                       arg_sym = sym;
5803                     else
5804                       {
5805                         found_sym = true;
5806                         add_defn_to_vec (result,
5807                                          fixup_symbol_section (sym, objfile),
5808                                          block);
5809                       }
5810                   }
5811               }
5812           }
5813       }
5814
5815       /* NOTE: This really shouldn't be needed for _ada_ symbols.
5816          They aren't parameters, right?  */
5817       if (!found_sym && arg_sym != NULL)
5818         {
5819           add_defn_to_vec (result,
5820                            fixup_symbol_section (arg_sym, objfile),
5821                            block);
5822         }
5823     }
5824 }
5825 \f
5826
5827                                 /* Symbol Completion */
5828
5829 /* See symtab.h.  */
5830
5831 bool
5832 ada_lookup_name_info::matches
5833   (const char *sym_name,
5834    symbol_name_match_type match_type,
5835    completion_match_result *comp_match_res) const
5836 {
5837   bool match = false;
5838   const char *text = m_encoded_name.c_str ();
5839   size_t text_len = m_encoded_name.size ();
5840
5841   /* First, test against the fully qualified name of the symbol.  */
5842
5843   if (strncmp (sym_name, text, text_len) == 0)
5844     match = true;
5845
5846   std::string decoded_name = ada_decode (sym_name);
5847   if (match && !m_encoded_p)
5848     {
5849       /* One needed check before declaring a positive match is to verify
5850          that iff we are doing a verbatim match, the decoded version
5851          of the symbol name starts with '<'.  Otherwise, this symbol name
5852          is not a suitable completion.  */
5853
5854       bool has_angle_bracket = (decoded_name[0] == '<');
5855       match = (has_angle_bracket == m_verbatim_p);
5856     }
5857
5858   if (match && !m_verbatim_p)
5859     {
5860       /* When doing non-verbatim match, another check that needs to
5861          be done is to verify that the potentially matching symbol name
5862          does not include capital letters, because the ada-mode would
5863          not be able to understand these symbol names without the
5864          angle bracket notation.  */
5865       const char *tmp;
5866
5867       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5868       if (*tmp != '\0')
5869         match = false;
5870     }
5871
5872   /* Second: Try wild matching...  */
5873
5874   if (!match && m_wild_match_p)
5875     {
5876       /* Since we are doing wild matching, this means that TEXT
5877          may represent an unqualified symbol name.  We therefore must
5878          also compare TEXT against the unqualified name of the symbol.  */
5879       sym_name = ada_unqualified_name (decoded_name.c_str ());
5880
5881       if (strncmp (sym_name, text, text_len) == 0)
5882         match = true;
5883     }
5884
5885   /* Finally: If we found a match, prepare the result to return.  */
5886
5887   if (!match)
5888     return false;
5889
5890   if (comp_match_res != NULL)
5891     {
5892       std::string &match_str = comp_match_res->match.storage ();
5893
5894       if (!m_encoded_p)
5895         match_str = ada_decode (sym_name);
5896       else
5897         {
5898           if (m_verbatim_p)
5899             match_str = add_angle_brackets (sym_name);
5900           else
5901             match_str = sym_name;
5902
5903         }
5904
5905       comp_match_res->set_match (match_str.c_str ());
5906     }
5907
5908   return true;
5909 }
5910
5911                                 /* Field Access */
5912
5913 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5914    for tagged types.  */
5915
5916 static int
5917 ada_is_dispatch_table_ptr_type (struct type *type)
5918 {
5919   const char *name;
5920
5921   if (type->code () != TYPE_CODE_PTR)
5922     return 0;
5923
5924   name = TYPE_TARGET_TYPE (type)->name ();
5925   if (name == NULL)
5926     return 0;
5927
5928   return (strcmp (name, "ada__tags__dispatch_table") == 0);
5929 }
5930
5931 /* Return non-zero if TYPE is an interface tag.  */
5932
5933 static int
5934 ada_is_interface_tag (struct type *type)
5935 {
5936   const char *name = type->name ();
5937
5938   if (name == NULL)
5939     return 0;
5940
5941   return (strcmp (name, "ada__tags__interface_tag") == 0);
5942 }
5943
5944 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5945    to be invisible to users.  */
5946
5947 int
5948 ada_is_ignored_field (struct type *type, int field_num)
5949 {
5950   if (field_num < 0 || field_num > type->num_fields ())
5951     return 1;
5952
5953   /* Check the name of that field.  */
5954   {
5955     const char *name = type->field (field_num).name ();
5956
5957     /* Anonymous field names should not be printed.
5958        brobecker/2007-02-20: I don't think this can actually happen
5959        but we don't want to print the value of anonymous fields anyway.  */
5960     if (name == NULL)
5961       return 1;
5962
5963     /* Normally, fields whose name start with an underscore ("_")
5964        are fields that have been internally generated by the compiler,
5965        and thus should not be printed.  The "_parent" field is special,
5966        however: This is a field internally generated by the compiler
5967        for tagged types, and it contains the components inherited from
5968        the parent type.  This field should not be printed as is, but
5969        should not be ignored either.  */
5970     if (name[0] == '_' && !startswith (name, "_parent"))
5971       return 1;
5972   }
5973
5974   /* If this is the dispatch table of a tagged type or an interface tag,
5975      then ignore.  */
5976   if (ada_is_tagged_type (type, 1)
5977       && (ada_is_dispatch_table_ptr_type (type->field (field_num).type ())
5978           || ada_is_interface_tag (type->field (field_num).type ())))
5979     return 1;
5980
5981   /* Not a special field, so it should not be ignored.  */
5982   return 0;
5983 }
5984
5985 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
5986    pointer or reference type whose ultimate target has a tag field.  */
5987
5988 int
5989 ada_is_tagged_type (struct type *type, int refok)
5990 {
5991   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
5992 }
5993
5994 /* True iff TYPE represents the type of X'Tag */
5995
5996 int
5997 ada_is_tag_type (struct type *type)
5998 {
5999   type = ada_check_typedef (type);
6000
6001   if (type == NULL || type->code () != TYPE_CODE_PTR)
6002     return 0;
6003   else
6004     {
6005       const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6006
6007       return (name != NULL
6008               && strcmp (name, "ada__tags__dispatch_table") == 0);
6009     }
6010 }
6011
6012 /* The type of the tag on VAL.  */
6013
6014 static struct type *
6015 ada_tag_type (struct value *val)
6016 {
6017   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6018 }
6019
6020 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6021    retired at Ada 05).  */
6022
6023 static int
6024 is_ada95_tag (struct value *tag)
6025 {
6026   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6027 }
6028
6029 /* The value of the tag on VAL.  */
6030
6031 static struct value *
6032 ada_value_tag (struct value *val)
6033 {
6034   return ada_value_struct_elt (val, "_tag", 0);
6035 }
6036
6037 /* The value of the tag on the object of type TYPE whose contents are
6038    saved at VALADDR, if it is non-null, or is at memory address
6039    ADDRESS.  */
6040
6041 static struct value *
6042 value_tag_from_contents_and_address (struct type *type,
6043                                      const gdb_byte *valaddr,
6044                                      CORE_ADDR address)
6045 {
6046   int tag_byte_offset;
6047   struct type *tag_type;
6048
6049   gdb::array_view<const gdb_byte> contents;
6050   if (valaddr != nullptr)
6051     contents = gdb::make_array_view (valaddr, TYPE_LENGTH (type));
6052   struct type *resolved_type = resolve_dynamic_type (type, contents, address);
6053   if (find_struct_field ("_tag", resolved_type, 0, &tag_type, &tag_byte_offset,
6054                          NULL, NULL, NULL))
6055     {
6056       const gdb_byte *valaddr1 = ((valaddr == NULL)
6057                                   ? NULL
6058                                   : valaddr + tag_byte_offset);
6059       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6060
6061       return value_from_contents_and_address (tag_type, valaddr1, address1);
6062     }
6063   return NULL;
6064 }
6065
6066 static struct type *
6067 type_from_tag (struct value *tag)
6068 {
6069   gdb::unique_xmalloc_ptr<char> type_name = ada_tag_name (tag);
6070
6071   if (type_name != NULL)
6072     return ada_find_any_type (ada_encode (type_name.get ()).c_str ());
6073   return NULL;
6074 }
6075
6076 /* Given a value OBJ of a tagged type, return a value of this
6077    type at the base address of the object.  The base address, as
6078    defined in Ada.Tags, it is the address of the primary tag of
6079    the object, and therefore where the field values of its full
6080    view can be fetched.  */
6081
6082 struct value *
6083 ada_tag_value_at_base_address (struct value *obj)
6084 {
6085   struct value *val;
6086   LONGEST offset_to_top = 0;
6087   struct type *ptr_type, *obj_type;
6088   struct value *tag;
6089   CORE_ADDR base_address;
6090
6091   obj_type = value_type (obj);
6092
6093   /* It is the responsability of the caller to deref pointers.  */
6094
6095   if (obj_type->code () == TYPE_CODE_PTR || obj_type->code () == TYPE_CODE_REF)
6096     return obj;
6097
6098   tag = ada_value_tag (obj);
6099   if (!tag)
6100     return obj;
6101
6102   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6103
6104   if (is_ada95_tag (tag))
6105     return obj;
6106
6107   ptr_type = language_lookup_primitive_type
6108     (language_def (language_ada), target_gdbarch(), "storage_offset");
6109   ptr_type = lookup_pointer_type (ptr_type);
6110   val = value_cast (ptr_type, tag);
6111   if (!val)
6112     return obj;
6113
6114   /* It is perfectly possible that an exception be raised while
6115      trying to determine the base address, just like for the tag;
6116      see ada_tag_name for more details.  We do not print the error
6117      message for the same reason.  */
6118
6119   try
6120     {
6121       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6122     }
6123
6124   catch (const gdb_exception_error &e)
6125     {
6126       return obj;
6127     }
6128
6129   /* If offset is null, nothing to do.  */
6130
6131   if (offset_to_top == 0)
6132     return obj;
6133
6134   /* -1 is a special case in Ada.Tags; however, what should be done
6135      is not quite clear from the documentation.  So do nothing for
6136      now.  */
6137
6138   if (offset_to_top == -1)
6139     return obj;
6140
6141   /* OFFSET_TO_TOP used to be a positive value to be subtracted
6142      from the base address.  This was however incompatible with
6143      C++ dispatch table: C++ uses a *negative* value to *add*
6144      to the base address.  Ada's convention has therefore been
6145      changed in GNAT 19.0w 20171023: since then, C++ and Ada
6146      use the same convention.  Here, we support both cases by
6147      checking the sign of OFFSET_TO_TOP.  */
6148
6149   if (offset_to_top > 0)
6150     offset_to_top = -offset_to_top;
6151
6152   base_address = value_address (obj) + offset_to_top;
6153   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6154
6155   /* Make sure that we have a proper tag at the new address.
6156      Otherwise, offset_to_top is bogus (which can happen when
6157      the object is not initialized yet).  */
6158
6159   if (!tag)
6160     return obj;
6161
6162   obj_type = type_from_tag (tag);
6163
6164   if (!obj_type)
6165     return obj;
6166
6167   return value_from_contents_and_address (obj_type, NULL, base_address);
6168 }
6169
6170 /* Return the "ada__tags__type_specific_data" type.  */
6171
6172 static struct type *
6173 ada_get_tsd_type (struct inferior *inf)
6174 {
6175   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6176
6177   if (data->tsd_type == 0)
6178     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6179   return data->tsd_type;
6180 }
6181
6182 /* Return the TSD (type-specific data) associated to the given TAG.
6183    TAG is assumed to be the tag of a tagged-type entity.
6184
6185    May return NULL if we are unable to get the TSD.  */
6186
6187 static struct value *
6188 ada_get_tsd_from_tag (struct value *tag)
6189 {
6190   struct value *val;
6191   struct type *type;
6192
6193   /* First option: The TSD is simply stored as a field of our TAG.
6194      Only older versions of GNAT would use this format, but we have
6195      to test it first, because there are no visible markers for
6196      the current approach except the absence of that field.  */
6197
6198   val = ada_value_struct_elt (tag, "tsd", 1);
6199   if (val)
6200     return val;
6201
6202   /* Try the second representation for the dispatch table (in which
6203      there is no explicit 'tsd' field in the referent of the tag pointer,
6204      and instead the tsd pointer is stored just before the dispatch
6205      table.  */
6206
6207   type = ada_get_tsd_type (current_inferior());
6208   if (type == NULL)
6209     return NULL;
6210   type = lookup_pointer_type (lookup_pointer_type (type));
6211   val = value_cast (type, tag);
6212   if (val == NULL)
6213     return NULL;
6214   return value_ind (value_ptradd (val, -1));
6215 }
6216
6217 /* Given the TSD of a tag (type-specific data), return a string
6218    containing the name of the associated type.
6219
6220    May return NULL if we are unable to determine the tag name.  */
6221
6222 static gdb::unique_xmalloc_ptr<char>
6223 ada_tag_name_from_tsd (struct value *tsd)
6224 {
6225   char *p;
6226   struct value *val;
6227
6228   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6229   if (val == NULL)
6230     return NULL;
6231   gdb::unique_xmalloc_ptr<char> buffer
6232     = target_read_string (value_as_address (val), INT_MAX);
6233   if (buffer == nullptr)
6234     return nullptr;
6235
6236   for (p = buffer.get (); *p != '\0'; ++p)
6237     {
6238       if (isalpha (*p))
6239         *p = tolower (*p);
6240     }
6241
6242   return buffer;
6243 }
6244
6245 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6246    a C string.
6247
6248    Return NULL if the TAG is not an Ada tag, or if we were unable to
6249    determine the name of that tag.  */
6250
6251 gdb::unique_xmalloc_ptr<char>
6252 ada_tag_name (struct value *tag)
6253 {
6254   gdb::unique_xmalloc_ptr<char> name;
6255
6256   if (!ada_is_tag_type (value_type (tag)))
6257     return NULL;
6258
6259   /* It is perfectly possible that an exception be raised while trying
6260      to determine the TAG's name, even under normal circumstances:
6261      The associated variable may be uninitialized or corrupted, for
6262      instance. We do not let any exception propagate past this point.
6263      instead we return NULL.
6264
6265      We also do not print the error message either (which often is very
6266      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6267      the caller print a more meaningful message if necessary.  */
6268   try
6269     {
6270       struct value *tsd = ada_get_tsd_from_tag (tag);
6271
6272       if (tsd != NULL)
6273         name = ada_tag_name_from_tsd (tsd);
6274     }
6275   catch (const gdb_exception_error &e)
6276     {
6277     }
6278
6279   return name;
6280 }
6281
6282 /* The parent type of TYPE, or NULL if none.  */
6283
6284 struct type *
6285 ada_parent_type (struct type *type)
6286 {
6287   int i;
6288
6289   type = ada_check_typedef (type);
6290
6291   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
6292     return NULL;
6293
6294   for (i = 0; i < type->num_fields (); i += 1)
6295     if (ada_is_parent_field (type, i))
6296       {
6297         struct type *parent_type = type->field (i).type ();
6298
6299         /* If the _parent field is a pointer, then dereference it.  */
6300         if (parent_type->code () == TYPE_CODE_PTR)
6301           parent_type = TYPE_TARGET_TYPE (parent_type);
6302         /* If there is a parallel XVS type, get the actual base type.  */
6303         parent_type = ada_get_base_type (parent_type);
6304
6305         return ada_check_typedef (parent_type);
6306       }
6307
6308   return NULL;
6309 }
6310
6311 /* True iff field number FIELD_NUM of structure type TYPE contains the
6312    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6313    a structure type with at least FIELD_NUM+1 fields.  */
6314
6315 int
6316 ada_is_parent_field (struct type *type, int field_num)
6317 {
6318   const char *name = ada_check_typedef (type)->field (field_num).name ();
6319
6320   return (name != NULL
6321           && (startswith (name, "PARENT")
6322               || startswith (name, "_parent")));
6323 }
6324
6325 /* True iff field number FIELD_NUM of structure type TYPE is a
6326    transparent wrapper field (which should be silently traversed when doing
6327    field selection and flattened when printing).  Assumes TYPE is a
6328    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6329    structures.  */
6330
6331 int
6332 ada_is_wrapper_field (struct type *type, int field_num)
6333 {
6334   const char *name = type->field (field_num).name ();
6335
6336   if (name != NULL && strcmp (name, "RETVAL") == 0)
6337     {
6338       /* This happens in functions with "out" or "in out" parameters
6339          which are passed by copy.  For such functions, GNAT describes
6340          the function's return type as being a struct where the return
6341          value is in a field called RETVAL, and where the other "out"
6342          or "in out" parameters are fields of that struct.  This is not
6343          a wrapper.  */
6344       return 0;
6345     }
6346
6347   return (name != NULL
6348           && (startswith (name, "PARENT")
6349               || strcmp (name, "REP") == 0
6350               || startswith (name, "_parent")
6351               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6352 }
6353
6354 /* True iff field number FIELD_NUM of structure or union type TYPE
6355    is a variant wrapper.  Assumes TYPE is a structure type with at least
6356    FIELD_NUM+1 fields.  */
6357
6358 int
6359 ada_is_variant_part (struct type *type, int field_num)
6360 {
6361   /* Only Ada types are eligible.  */
6362   if (!ADA_TYPE_P (type))
6363     return 0;
6364
6365   struct type *field_type = type->field (field_num).type ();
6366
6367   return (field_type->code () == TYPE_CODE_UNION
6368           || (is_dynamic_field (type, field_num)
6369               && (TYPE_TARGET_TYPE (field_type)->code ()
6370                   == TYPE_CODE_UNION)));
6371 }
6372
6373 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6374    whose discriminants are contained in the record type OUTER_TYPE,
6375    returns the type of the controlling discriminant for the variant.
6376    May return NULL if the type could not be found.  */
6377
6378 struct type *
6379 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6380 {
6381   const char *name = ada_variant_discrim_name (var_type);
6382
6383   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6384 }
6385
6386 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6387    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6388    represents a 'when others' clause; otherwise 0.  */
6389
6390 static int
6391 ada_is_others_clause (struct type *type, int field_num)
6392 {
6393   const char *name = type->field (field_num).name ();
6394
6395   return (name != NULL && name[0] == 'O');
6396 }
6397
6398 /* Assuming that TYPE0 is the type of the variant part of a record,
6399    returns the name of the discriminant controlling the variant.
6400    The value is valid until the next call to ada_variant_discrim_name.  */
6401
6402 const char *
6403 ada_variant_discrim_name (struct type *type0)
6404 {
6405   static std::string result;
6406   struct type *type;
6407   const char *name;
6408   const char *discrim_end;
6409   const char *discrim_start;
6410
6411   if (type0->code () == TYPE_CODE_PTR)
6412     type = TYPE_TARGET_TYPE (type0);
6413   else
6414     type = type0;
6415
6416   name = ada_type_name (type);
6417
6418   if (name == NULL || name[0] == '\000')
6419     return "";
6420
6421   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6422        discrim_end -= 1)
6423     {
6424       if (startswith (discrim_end, "___XVN"))
6425         break;
6426     }
6427   if (discrim_end == name)
6428     return "";
6429
6430   for (discrim_start = discrim_end; discrim_start != name + 3;
6431        discrim_start -= 1)
6432     {
6433       if (discrim_start == name + 1)
6434         return "";
6435       if ((discrim_start > name + 3
6436            && startswith (discrim_start - 3, "___"))
6437           || discrim_start[-1] == '.')
6438         break;
6439     }
6440
6441   result = std::string (discrim_start, discrim_end - discrim_start);
6442   return result.c_str ();
6443 }
6444
6445 /* Scan STR for a subtype-encoded number, beginning at position K.
6446    Put the position of the character just past the number scanned in
6447    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
6448    Return 1 if there was a valid number at the given position, and 0
6449    otherwise.  A "subtype-encoded" number consists of the absolute value
6450    in decimal, followed by the letter 'm' to indicate a negative number.
6451    Assumes 0m does not occur.  */
6452
6453 int
6454 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6455 {
6456   ULONGEST RU;
6457
6458   if (!isdigit (str[k]))
6459     return 0;
6460
6461   /* Do it the hard way so as not to make any assumption about
6462      the relationship of unsigned long (%lu scan format code) and
6463      LONGEST.  */
6464   RU = 0;
6465   while (isdigit (str[k]))
6466     {
6467       RU = RU * 10 + (str[k] - '0');
6468       k += 1;
6469     }
6470
6471   if (str[k] == 'm')
6472     {
6473       if (R != NULL)
6474         *R = (-(LONGEST) (RU - 1)) - 1;
6475       k += 1;
6476     }
6477   else if (R != NULL)
6478     *R = (LONGEST) RU;
6479
6480   /* NOTE on the above: Technically, C does not say what the results of
6481      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6482      number representable as a LONGEST (although either would probably work
6483      in most implementations).  When RU>0, the locution in the then branch
6484      above is always equivalent to the negative of RU.  */
6485
6486   if (new_k != NULL)
6487     *new_k = k;
6488   return 1;
6489 }
6490
6491 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6492    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6493    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
6494
6495 static int
6496 ada_in_variant (LONGEST val, struct type *type, int field_num)
6497 {
6498   const char *name = type->field (field_num).name ();
6499   int p;
6500
6501   p = 0;
6502   while (1)
6503     {
6504       switch (name[p])
6505         {
6506         case '\0':
6507           return 0;
6508         case 'S':
6509           {
6510             LONGEST W;
6511
6512             if (!ada_scan_number (name, p + 1, &W, &p))
6513               return 0;
6514             if (val == W)
6515               return 1;
6516             break;
6517           }
6518         case 'R':
6519           {
6520             LONGEST L, U;
6521
6522             if (!ada_scan_number (name, p + 1, &L, &p)
6523                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6524               return 0;
6525             if (val >= L && val <= U)
6526               return 1;
6527             break;
6528           }
6529         case 'O':
6530           return 1;
6531         default:
6532           return 0;
6533         }
6534     }
6535 }
6536
6537 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
6538
6539 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6540    ARG_TYPE, extract and return the value of one of its (non-static)
6541    fields.  FIELDNO says which field.   Differs from value_primitive_field
6542    only in that it can handle packed values of arbitrary type.  */
6543
6544 struct value *
6545 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6546                            struct type *arg_type)
6547 {
6548   struct type *type;
6549
6550   arg_type = ada_check_typedef (arg_type);
6551   type = arg_type->field (fieldno).type ();
6552
6553   /* Handle packed fields.  It might be that the field is not packed
6554      relative to its containing structure, but the structure itself is
6555      packed; in this case we must take the bit-field path.  */
6556   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
6557     {
6558       int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6559       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6560
6561       return ada_value_primitive_packed_val (arg1,
6562                                              value_contents (arg1).data (),
6563                                              offset + bit_pos / 8,
6564                                              bit_pos % 8, bit_size, type);
6565     }
6566   else
6567     return value_primitive_field (arg1, offset, fieldno, arg_type);
6568 }
6569
6570 /* Find field with name NAME in object of type TYPE.  If found, 
6571    set the following for each argument that is non-null:
6572     - *FIELD_TYPE_P to the field's type; 
6573     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
6574       an object of that type;
6575     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
6576     - *BIT_SIZE_P to its size in bits if the field is packed, and 
6577       0 otherwise;
6578    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6579    fields up to but not including the desired field, or by the total
6580    number of fields if not found.   A NULL value of NAME never
6581    matches; the function just counts visible fields in this case.
6582    
6583    Notice that we need to handle when a tagged record hierarchy
6584    has some components with the same name, like in this scenario:
6585
6586       type Top_T is tagged record
6587          N : Integer := 1;
6588          U : Integer := 974;
6589          A : Integer := 48;
6590       end record;
6591
6592       type Middle_T is new Top.Top_T with record
6593          N : Character := 'a';
6594          C : Integer := 3;
6595       end record;
6596
6597      type Bottom_T is new Middle.Middle_T with record
6598         N : Float := 4.0;
6599         C : Character := '5';
6600         X : Integer := 6;
6601         A : Character := 'J';
6602      end record;
6603
6604    Let's say we now have a variable declared and initialized as follow:
6605
6606      TC : Top_A := new Bottom_T;
6607
6608    And then we use this variable to call this function
6609
6610      procedure Assign (Obj: in out Top_T; TV : Integer);
6611
6612    as follow:
6613
6614       Assign (Top_T (B), 12);
6615
6616    Now, we're in the debugger, and we're inside that procedure
6617    then and we want to print the value of obj.c:
6618
6619    Usually, the tagged record or one of the parent type owns the
6620    component to print and there's no issue but in this particular
6621    case, what does it mean to ask for Obj.C? Since the actual
6622    type for object is type Bottom_T, it could mean two things: type
6623    component C from the Middle_T view, but also component C from
6624    Bottom_T.  So in that "undefined" case, when the component is
6625    not found in the non-resolved type (which includes all the
6626    components of the parent type), then resolve it and see if we
6627    get better luck once expanded.
6628
6629    In the case of homonyms in the derived tagged type, we don't
6630    guaranty anything, and pick the one that's easiest for us
6631    to program.
6632
6633    Returns 1 if found, 0 otherwise.  */
6634
6635 static int
6636 find_struct_field (const char *name, struct type *type, int offset,
6637                    struct type **field_type_p,
6638                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6639                    int *index_p)
6640 {
6641   int i;
6642   int parent_offset = -1;
6643
6644   type = ada_check_typedef (type);
6645
6646   if (field_type_p != NULL)
6647     *field_type_p = NULL;
6648   if (byte_offset_p != NULL)
6649     *byte_offset_p = 0;
6650   if (bit_offset_p != NULL)
6651     *bit_offset_p = 0;
6652   if (bit_size_p != NULL)
6653     *bit_size_p = 0;
6654
6655   for (i = 0; i < type->num_fields (); i += 1)
6656     {
6657       /* These can't be computed using TYPE_FIELD_BITPOS for a dynamic
6658          type.  However, we only need the values to be correct when
6659          the caller asks for them.  */
6660       int bit_pos = 0, fld_offset = 0;
6661       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
6662         {
6663           bit_pos = TYPE_FIELD_BITPOS (type, i);
6664           fld_offset = offset + bit_pos / 8;
6665         }
6666
6667       const char *t_field_name = type->field (i).name ();
6668
6669       if (t_field_name == NULL)
6670         continue;
6671
6672       else if (ada_is_parent_field (type, i))
6673         {
6674           /* This is a field pointing us to the parent type of a tagged
6675              type.  As hinted in this function's documentation, we give
6676              preference to fields in the current record first, so what
6677              we do here is just record the index of this field before
6678              we skip it.  If it turns out we couldn't find our field
6679              in the current record, then we'll get back to it and search
6680              inside it whether the field might exist in the parent.  */
6681
6682           parent_offset = i;
6683           continue;
6684         }
6685
6686       else if (name != NULL && field_name_match (t_field_name, name))
6687         {
6688           int bit_size = TYPE_FIELD_BITSIZE (type, i);
6689
6690           if (field_type_p != NULL)
6691             *field_type_p = type->field (i).type ();
6692           if (byte_offset_p != NULL)
6693             *byte_offset_p = fld_offset;
6694           if (bit_offset_p != NULL)
6695             *bit_offset_p = bit_pos % 8;
6696           if (bit_size_p != NULL)
6697             *bit_size_p = bit_size;
6698           return 1;
6699         }
6700       else if (ada_is_wrapper_field (type, i))
6701         {
6702           if (find_struct_field (name, type->field (i).type (), fld_offset,
6703                                  field_type_p, byte_offset_p, bit_offset_p,
6704                                  bit_size_p, index_p))
6705             return 1;
6706         }
6707       else if (ada_is_variant_part (type, i))
6708         {
6709           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
6710              fixed type?? */
6711           int j;
6712           struct type *field_type
6713             = ada_check_typedef (type->field (i).type ());
6714
6715           for (j = 0; j < field_type->num_fields (); j += 1)
6716             {
6717               if (find_struct_field (name, field_type->field (j).type (),
6718                                      fld_offset
6719                                      + TYPE_FIELD_BITPOS (field_type, j) / 8,
6720                                      field_type_p, byte_offset_p,
6721                                      bit_offset_p, bit_size_p, index_p))
6722                 return 1;
6723             }
6724         }
6725       else if (index_p != NULL)
6726         *index_p += 1;
6727     }
6728
6729   /* Field not found so far.  If this is a tagged type which
6730      has a parent, try finding that field in the parent now.  */
6731
6732   if (parent_offset != -1)
6733     {
6734       /* As above, only compute the offset when truly needed.  */
6735       int fld_offset = offset;
6736       if (byte_offset_p != nullptr || bit_offset_p != nullptr)
6737         {
6738           int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
6739           fld_offset += bit_pos / 8;
6740         }
6741
6742       if (find_struct_field (name, type->field (parent_offset).type (),
6743                              fld_offset, field_type_p, byte_offset_p,
6744                              bit_offset_p, bit_size_p, index_p))
6745         return 1;
6746     }
6747
6748   return 0;
6749 }
6750
6751 /* Number of user-visible fields in record type TYPE.  */
6752
6753 static int
6754 num_visible_fields (struct type *type)
6755 {
6756   int n;
6757
6758   n = 0;
6759   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6760   return n;
6761 }
6762
6763 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
6764    and search in it assuming it has (class) type TYPE.
6765    If found, return value, else return NULL.
6766
6767    Searches recursively through wrapper fields (e.g., '_parent').
6768
6769    In the case of homonyms in the tagged types, please refer to the
6770    long explanation in find_struct_field's function documentation.  */
6771
6772 static struct value *
6773 ada_search_struct_field (const char *name, struct value *arg, int offset,
6774                          struct type *type)
6775 {
6776   int i;
6777   int parent_offset = -1;
6778
6779   type = ada_check_typedef (type);
6780   for (i = 0; i < type->num_fields (); i += 1)
6781     {
6782       const char *t_field_name = type->field (i).name ();
6783
6784       if (t_field_name == NULL)
6785         continue;
6786
6787       else if (ada_is_parent_field (type, i))
6788         {
6789           /* This is a field pointing us to the parent type of a tagged
6790              type.  As hinted in this function's documentation, we give
6791              preference to fields in the current record first, so what
6792              we do here is just record the index of this field before
6793              we skip it.  If it turns out we couldn't find our field
6794              in the current record, then we'll get back to it and search
6795              inside it whether the field might exist in the parent.  */
6796
6797           parent_offset = i;
6798           continue;
6799         }
6800
6801       else if (field_name_match (t_field_name, name))
6802         return ada_value_primitive_field (arg, offset, i, type);
6803
6804       else if (ada_is_wrapper_field (type, i))
6805         {
6806           struct value *v =     /* Do not let indent join lines here.  */
6807             ada_search_struct_field (name, arg,
6808                                      offset + TYPE_FIELD_BITPOS (type, i) / 8,
6809                                      type->field (i).type ());
6810
6811           if (v != NULL)
6812             return v;
6813         }
6814
6815       else if (ada_is_variant_part (type, i))
6816         {
6817           /* PNH: Do we ever get here?  See find_struct_field.  */
6818           int j;
6819           struct type *field_type = ada_check_typedef (type->field (i).type ());
6820           int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6821
6822           for (j = 0; j < field_type->num_fields (); j += 1)
6823             {
6824               struct value *v = ada_search_struct_field /* Force line
6825                                                            break.  */
6826                 (name, arg,
6827                  var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6828                  field_type->field (j).type ());
6829
6830               if (v != NULL)
6831                 return v;
6832             }
6833         }
6834     }
6835
6836   /* Field not found so far.  If this is a tagged type which
6837      has a parent, try finding that field in the parent now.  */
6838
6839   if (parent_offset != -1)
6840     {
6841       struct value *v = ada_search_struct_field (
6842         name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
6843         type->field (parent_offset).type ());
6844
6845       if (v != NULL)
6846         return v;
6847     }
6848
6849   return NULL;
6850 }
6851
6852 static struct value *ada_index_struct_field_1 (int *, struct value *,
6853                                                int, struct type *);
6854
6855
6856 /* Return field #INDEX in ARG, where the index is that returned by
6857  * find_struct_field through its INDEX_P argument.  Adjust the address
6858  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6859  * If found, return value, else return NULL.  */
6860
6861 static struct value *
6862 ada_index_struct_field (int index, struct value *arg, int offset,
6863                         struct type *type)
6864 {
6865   return ada_index_struct_field_1 (&index, arg, offset, type);
6866 }
6867
6868
6869 /* Auxiliary function for ada_index_struct_field.  Like
6870  * ada_index_struct_field, but takes index from *INDEX_P and modifies
6871  * *INDEX_P.  */
6872
6873 static struct value *
6874 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6875                           struct type *type)
6876 {
6877   int i;
6878   type = ada_check_typedef (type);
6879
6880   for (i = 0; i < type->num_fields (); i += 1)
6881     {
6882       if (type->field (i).name () == NULL)
6883         continue;
6884       else if (ada_is_wrapper_field (type, i))
6885         {
6886           struct value *v =     /* Do not let indent join lines here.  */
6887             ada_index_struct_field_1 (index_p, arg,
6888                                       offset + TYPE_FIELD_BITPOS (type, i) / 8,
6889                                       type->field (i).type ());
6890
6891           if (v != NULL)
6892             return v;
6893         }
6894
6895       else if (ada_is_variant_part (type, i))
6896         {
6897           /* PNH: Do we ever get here?  See ada_search_struct_field,
6898              find_struct_field.  */
6899           error (_("Cannot assign this kind of variant record"));
6900         }
6901       else if (*index_p == 0)
6902         return ada_value_primitive_field (arg, offset, i, type);
6903       else
6904         *index_p -= 1;
6905     }
6906   return NULL;
6907 }
6908
6909 /* Return a string representation of type TYPE.  */
6910
6911 static std::string
6912 type_as_string (struct type *type)
6913 {
6914   string_file tmp_stream;
6915
6916   type_print (type, "", &tmp_stream, -1);
6917
6918   return std::move (tmp_stream.string ());
6919 }
6920
6921 /* Given a type TYPE, look up the type of the component of type named NAME.
6922    If DISPP is non-null, add its byte displacement from the beginning of a
6923    structure (pointed to by a value) of type TYPE to *DISPP (does not
6924    work for packed fields).
6925
6926    Matches any field whose name has NAME as a prefix, possibly
6927    followed by "___".
6928
6929    TYPE can be either a struct or union.  If REFOK, TYPE may also 
6930    be a (pointer or reference)+ to a struct or union, and the
6931    ultimate target type will be searched.
6932
6933    Looks recursively into variant clauses and parent types.
6934
6935    In the case of homonyms in the tagged types, please refer to the
6936    long explanation in find_struct_field's function documentation.
6937
6938    If NOERR is nonzero, return NULL if NAME is not suitably defined or
6939    TYPE is not a type of the right kind.  */
6940
6941 static struct type *
6942 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
6943                             int noerr)
6944 {
6945   int i;
6946   int parent_offset = -1;
6947
6948   if (name == NULL)
6949     goto BadName;
6950
6951   if (refok && type != NULL)
6952     while (1)
6953       {
6954         type = ada_check_typedef (type);
6955         if (type->code () != TYPE_CODE_PTR && type->code () != TYPE_CODE_REF)
6956           break;
6957         type = TYPE_TARGET_TYPE (type);
6958       }
6959
6960   if (type == NULL
6961       || (type->code () != TYPE_CODE_STRUCT
6962           && type->code () != TYPE_CODE_UNION))
6963     {
6964       if (noerr)
6965         return NULL;
6966
6967       error (_("Type %s is not a structure or union type"),
6968              type != NULL ? type_as_string (type).c_str () : _("(null)"));
6969     }
6970
6971   type = to_static_fixed_type (type);
6972
6973   for (i = 0; i < type->num_fields (); i += 1)
6974     {
6975       const char *t_field_name = type->field (i).name ();
6976       struct type *t;
6977
6978       if (t_field_name == NULL)
6979         continue;
6980
6981       else if (ada_is_parent_field (type, i))
6982         {
6983           /* This is a field pointing us to the parent type of a tagged
6984              type.  As hinted in this function's documentation, we give
6985              preference to fields in the current record first, so what
6986              we do here is just record the index of this field before
6987              we skip it.  If it turns out we couldn't find our field
6988              in the current record, then we'll get back to it and search
6989              inside it whether the field might exist in the parent.  */
6990
6991           parent_offset = i;
6992           continue;
6993         }
6994
6995       else if (field_name_match (t_field_name, name))
6996         return type->field (i).type ();
6997
6998       else if (ada_is_wrapper_field (type, i))
6999         {
7000           t = ada_lookup_struct_elt_type (type->field (i).type (), name,
7001                                           0, 1);
7002           if (t != NULL)
7003             return t;
7004         }
7005
7006       else if (ada_is_variant_part (type, i))
7007         {
7008           int j;
7009           struct type *field_type = ada_check_typedef (type->field (i).type ());
7010
7011           for (j = field_type->num_fields () - 1; j >= 0; j -= 1)
7012             {
7013               /* FIXME pnh 2008/01/26: We check for a field that is
7014                  NOT wrapped in a struct, since the compiler sometimes
7015                  generates these for unchecked variant types.  Revisit
7016                  if the compiler changes this practice.  */
7017               const char *v_field_name = field_type->field (j).name ();
7018
7019               if (v_field_name != NULL 
7020                   && field_name_match (v_field_name, name))
7021                 t = field_type->field (j).type ();
7022               else
7023                 t = ada_lookup_struct_elt_type (field_type->field (j).type (),
7024                                                 name, 0, 1);
7025
7026               if (t != NULL)
7027                 return t;
7028             }
7029         }
7030
7031     }
7032
7033     /* Field not found so far.  If this is a tagged type which
7034        has a parent, try finding that field in the parent now.  */
7035
7036     if (parent_offset != -1)
7037       {
7038         struct type *t;
7039
7040         t = ada_lookup_struct_elt_type (type->field (parent_offset).type (),
7041                                         name, 0, 1);
7042         if (t != NULL)
7043           return t;
7044       }
7045
7046 BadName:
7047   if (!noerr)
7048     {
7049       const char *name_str = name != NULL ? name : _("<null>");
7050
7051       error (_("Type %s has no component named %s"),
7052              type_as_string (type).c_str (), name_str);
7053     }
7054
7055   return NULL;
7056 }
7057
7058 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7059    within a value of type OUTER_TYPE, return true iff VAR_TYPE
7060    represents an unchecked union (that is, the variant part of a
7061    record that is named in an Unchecked_Union pragma).  */
7062
7063 static int
7064 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7065 {
7066   const char *discrim_name = ada_variant_discrim_name (var_type);
7067
7068   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7069 }
7070
7071
7072 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7073    within OUTER, determine which variant clause (field number in VAR_TYPE,
7074    numbering from 0) is applicable.  Returns -1 if none are.  */
7075
7076 int
7077 ada_which_variant_applies (struct type *var_type, struct value *outer)
7078 {
7079   int others_clause;
7080   int i;
7081   const char *discrim_name = ada_variant_discrim_name (var_type);
7082   struct value *discrim;
7083   LONGEST discrim_val;
7084
7085   /* Using plain value_from_contents_and_address here causes problems
7086      because we will end up trying to resolve a type that is currently
7087      being constructed.  */
7088   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7089   if (discrim == NULL)
7090     return -1;
7091   discrim_val = value_as_long (discrim);
7092
7093   others_clause = -1;
7094   for (i = 0; i < var_type->num_fields (); i += 1)
7095     {
7096       if (ada_is_others_clause (var_type, i))
7097         others_clause = i;
7098       else if (ada_in_variant (discrim_val, var_type, i))
7099         return i;
7100     }
7101
7102   return others_clause;
7103 }
7104 \f
7105
7106
7107                                 /* Dynamic-Sized Records */
7108
7109 /* Strategy: The type ostensibly attached to a value with dynamic size
7110    (i.e., a size that is not statically recorded in the debugging
7111    data) does not accurately reflect the size or layout of the value.
7112    Our strategy is to convert these values to values with accurate,
7113    conventional types that are constructed on the fly.  */
7114
7115 /* There is a subtle and tricky problem here.  In general, we cannot
7116    determine the size of dynamic records without its data.  However,
7117    the 'struct value' data structure, which GDB uses to represent
7118    quantities in the inferior process (the target), requires the size
7119    of the type at the time of its allocation in order to reserve space
7120    for GDB's internal copy of the data.  That's why the
7121    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7122    rather than struct value*s.
7123
7124    However, GDB's internal history variables ($1, $2, etc.) are
7125    struct value*s containing internal copies of the data that are not, in
7126    general, the same as the data at their corresponding addresses in
7127    the target.  Fortunately, the types we give to these values are all
7128    conventional, fixed-size types (as per the strategy described
7129    above), so that we don't usually have to perform the
7130    'to_fixed_xxx_type' conversions to look at their values.
7131    Unfortunately, there is one exception: if one of the internal
7132    history variables is an array whose elements are unconstrained
7133    records, then we will need to create distinct fixed types for each
7134    element selected.  */
7135
7136 /* The upshot of all of this is that many routines take a (type, host
7137    address, target address) triple as arguments to represent a value.
7138    The host address, if non-null, is supposed to contain an internal
7139    copy of the relevant data; otherwise, the program is to consult the
7140    target at the target address.  */
7141
7142 /* Assuming that VAL0 represents a pointer value, the result of
7143    dereferencing it.  Differs from value_ind in its treatment of
7144    dynamic-sized types.  */
7145
7146 struct value *
7147 ada_value_ind (struct value *val0)
7148 {
7149   struct value *val = value_ind (val0);
7150
7151   if (ada_is_tagged_type (value_type (val), 0))
7152     val = ada_tag_value_at_base_address (val);
7153
7154   return ada_to_fixed_value (val);
7155 }
7156
7157 /* The value resulting from dereferencing any "reference to"
7158    qualifiers on VAL0.  */
7159
7160 static struct value *
7161 ada_coerce_ref (struct value *val0)
7162 {
7163   if (value_type (val0)->code () == TYPE_CODE_REF)
7164     {
7165       struct value *val = val0;
7166
7167       val = coerce_ref (val);
7168
7169       if (ada_is_tagged_type (value_type (val), 0))
7170         val = ada_tag_value_at_base_address (val);
7171
7172       return ada_to_fixed_value (val);
7173     }
7174   else
7175     return val0;
7176 }
7177
7178 /* Return the bit alignment required for field #F of template type TYPE.  */
7179
7180 static unsigned int
7181 field_alignment (struct type *type, int f)
7182 {
7183   const char *name = type->field (f).name ();
7184   int len;
7185   int align_offset;
7186
7187   /* The field name should never be null, unless the debugging information
7188      is somehow malformed.  In this case, we assume the field does not
7189      require any alignment.  */
7190   if (name == NULL)
7191     return 1;
7192
7193   len = strlen (name);
7194
7195   if (!isdigit (name[len - 1]))
7196     return 1;
7197
7198   if (isdigit (name[len - 2]))
7199     align_offset = len - 2;
7200   else
7201     align_offset = len - 1;
7202
7203   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7204     return TARGET_CHAR_BIT;
7205
7206   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7207 }
7208
7209 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7210
7211 static struct symbol *
7212 ada_find_any_type_symbol (const char *name)
7213 {
7214   struct symbol *sym;
7215
7216   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7217   if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7218     return sym;
7219
7220   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7221   return sym;
7222 }
7223
7224 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7225    solely for types defined by debug info, it will not search the GDB
7226    primitive types.  */
7227
7228 static struct type *
7229 ada_find_any_type (const char *name)
7230 {
7231   struct symbol *sym = ada_find_any_type_symbol (name);
7232
7233   if (sym != NULL)
7234     return SYMBOL_TYPE (sym);
7235
7236   return NULL;
7237 }
7238
7239 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7240    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
7241    symbol, in which case it is returned.  Otherwise, this looks for
7242    symbols whose name is that of NAME_SYM suffixed with  "___XR".
7243    Return symbol if found, and NULL otherwise.  */
7244
7245 static bool
7246 ada_is_renaming_symbol (struct symbol *name_sym)
7247 {
7248   const char *name = name_sym->linkage_name ();
7249   return strstr (name, "___XR") != NULL;
7250 }
7251
7252 /* Because of GNAT encoding conventions, several GDB symbols may match a
7253    given type name.  If the type denoted by TYPE0 is to be preferred to
7254    that of TYPE1 for purposes of type printing, return non-zero;
7255    otherwise return 0.  */
7256
7257 int
7258 ada_prefer_type (struct type *type0, struct type *type1)
7259 {
7260   if (type1 == NULL)
7261     return 1;
7262   else if (type0 == NULL)
7263     return 0;
7264   else if (type1->code () == TYPE_CODE_VOID)
7265     return 1;
7266   else if (type0->code () == TYPE_CODE_VOID)
7267     return 0;
7268   else if (type1->name () == NULL && type0->name () != NULL)
7269     return 1;
7270   else if (ada_is_constrained_packed_array_type (type0))
7271     return 1;
7272   else if (ada_is_array_descriptor_type (type0)
7273            && !ada_is_array_descriptor_type (type1))
7274     return 1;
7275   else
7276     {
7277       const char *type0_name = type0->name ();
7278       const char *type1_name = type1->name ();
7279
7280       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7281           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7282         return 1;
7283     }
7284   return 0;
7285 }
7286
7287 /* The name of TYPE, which is its TYPE_NAME.  Null if TYPE is
7288    null.  */
7289
7290 const char *
7291 ada_type_name (struct type *type)
7292 {
7293   if (type == NULL)
7294     return NULL;
7295   return type->name ();
7296 }
7297
7298 /* Search the list of "descriptive" types associated to TYPE for a type
7299    whose name is NAME.  */
7300
7301 static struct type *
7302 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7303 {
7304   struct type *result, *tmp;
7305
7306   if (ada_ignore_descriptive_types_p)
7307     return NULL;
7308
7309   /* If there no descriptive-type info, then there is no parallel type
7310      to be found.  */
7311   if (!HAVE_GNAT_AUX_INFO (type))
7312     return NULL;
7313
7314   result = TYPE_DESCRIPTIVE_TYPE (type);
7315   while (result != NULL)
7316     {
7317       const char *result_name = ada_type_name (result);
7318
7319       if (result_name == NULL)
7320         {
7321           warning (_("unexpected null name on descriptive type"));
7322           return NULL;
7323         }
7324
7325       /* If the names match, stop.  */
7326       if (strcmp (result_name, name) == 0)
7327         break;
7328
7329       /* Otherwise, look at the next item on the list, if any.  */
7330       if (HAVE_GNAT_AUX_INFO (result))
7331         tmp = TYPE_DESCRIPTIVE_TYPE (result);
7332       else
7333         tmp = NULL;
7334
7335       /* If not found either, try after having resolved the typedef.  */
7336       if (tmp != NULL)
7337         result = tmp;
7338       else
7339         {
7340           result = check_typedef (result);
7341           if (HAVE_GNAT_AUX_INFO (result))
7342             result = TYPE_DESCRIPTIVE_TYPE (result);
7343           else
7344             result = NULL;
7345         }
7346     }
7347
7348   /* If we didn't find a match, see whether this is a packed array.  With
7349      older compilers, the descriptive type information is either absent or
7350      irrelevant when it comes to packed arrays so the above lookup fails.
7351      Fall back to using a parallel lookup by name in this case.  */
7352   if (result == NULL && ada_is_constrained_packed_array_type (type))
7353     return ada_find_any_type (name);
7354
7355   return result;
7356 }
7357
7358 /* Find a parallel type to TYPE with the specified NAME, using the
7359    descriptive type taken from the debugging information, if available,
7360    and otherwise using the (slower) name-based method.  */
7361
7362 static struct type *
7363 ada_find_parallel_type_with_name (struct type *type, const char *name)
7364 {
7365   struct type *result = NULL;
7366
7367   if (HAVE_GNAT_AUX_INFO (type))
7368     result = find_parallel_type_by_descriptive_type (type, name);
7369   else
7370     result = ada_find_any_type (name);
7371
7372   return result;
7373 }
7374
7375 /* Same as above, but specify the name of the parallel type by appending
7376    SUFFIX to the name of TYPE.  */
7377
7378 struct type *
7379 ada_find_parallel_type (struct type *type, const char *suffix)
7380 {
7381   char *name;
7382   const char *type_name = ada_type_name (type);
7383   int len;
7384
7385   if (type_name == NULL)
7386     return NULL;
7387
7388   len = strlen (type_name);
7389
7390   name = (char *) alloca (len + strlen (suffix) + 1);
7391
7392   strcpy (name, type_name);
7393   strcpy (name + len, suffix);
7394
7395   return ada_find_parallel_type_with_name (type, name);
7396 }
7397
7398 /* If TYPE is a variable-size record type, return the corresponding template
7399    type describing its fields.  Otherwise, return NULL.  */
7400
7401 static struct type *
7402 dynamic_template_type (struct type *type)
7403 {
7404   type = ada_check_typedef (type);
7405
7406   if (type == NULL || type->code () != TYPE_CODE_STRUCT
7407       || ada_type_name (type) == NULL)
7408     return NULL;
7409   else
7410     {
7411       int len = strlen (ada_type_name (type));
7412
7413       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7414         return type;
7415       else
7416         return ada_find_parallel_type (type, "___XVE");
7417     }
7418 }
7419
7420 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7421    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
7422
7423 static int
7424 is_dynamic_field (struct type *templ_type, int field_num)
7425 {
7426   const char *name = templ_type->field (field_num).name ();
7427
7428   return name != NULL
7429     && templ_type->field (field_num).type ()->code () == TYPE_CODE_PTR
7430     && strstr (name, "___XVL") != NULL;
7431 }
7432
7433 /* The index of the variant field of TYPE, or -1 if TYPE does not
7434    represent a variant record type.  */
7435
7436 static int
7437 variant_field_index (struct type *type)
7438 {
7439   int f;
7440
7441   if (type == NULL || type->code () != TYPE_CODE_STRUCT)
7442     return -1;
7443
7444   for (f = 0; f < type->num_fields (); f += 1)
7445     {
7446       if (ada_is_variant_part (type, f))
7447         return f;
7448     }
7449   return -1;
7450 }
7451
7452 /* A record type with no fields.  */
7453
7454 static struct type *
7455 empty_record (struct type *templ)
7456 {
7457   struct type *type = alloc_type_copy (templ);
7458
7459   type->set_code (TYPE_CODE_STRUCT);
7460   INIT_NONE_SPECIFIC (type);
7461   type->set_name ("<empty>");
7462   TYPE_LENGTH (type) = 0;
7463   return type;
7464 }
7465
7466 /* An ordinary record type (with fixed-length fields) that describes
7467    the value of type TYPE at VALADDR or ADDRESS (see comments at
7468    the beginning of this section) VAL according to GNAT conventions.
7469    DVAL0 should describe the (portion of a) record that contains any
7470    necessary discriminants.  It should be NULL if value_type (VAL) is
7471    an outer-level type (i.e., as opposed to a branch of a variant.)  A
7472    variant field (unless unchecked) is replaced by a particular branch
7473    of the variant.
7474
7475    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7476    length are not statically known are discarded.  As a consequence,
7477    VALADDR, ADDRESS and DVAL0 are ignored.
7478
7479    NOTE: Limitations: For now, we assume that dynamic fields and
7480    variants occupy whole numbers of bytes.  However, they need not be
7481    byte-aligned.  */
7482
7483 struct type *
7484 ada_template_to_fixed_record_type_1 (struct type *type,
7485                                      const gdb_byte *valaddr,
7486                                      CORE_ADDR address, struct value *dval0,
7487                                      int keep_dynamic_fields)
7488 {
7489   struct value *mark = value_mark ();
7490   struct value *dval;
7491   struct type *rtype;
7492   int nfields, bit_len;
7493   int variant_field;
7494   long off;
7495   int fld_bit_len;
7496   int f;
7497
7498   /* Compute the number of fields in this record type that are going
7499      to be processed: unless keep_dynamic_fields, this includes only
7500      fields whose position and length are static will be processed.  */
7501   if (keep_dynamic_fields)
7502     nfields = type->num_fields ();
7503   else
7504     {
7505       nfields = 0;
7506       while (nfields < type->num_fields ()
7507              && !ada_is_variant_part (type, nfields)
7508              && !is_dynamic_field (type, nfields))
7509         nfields++;
7510     }
7511
7512   rtype = alloc_type_copy (type);
7513   rtype->set_code (TYPE_CODE_STRUCT);
7514   INIT_NONE_SPECIFIC (rtype);
7515   rtype->set_num_fields (nfields);
7516   rtype->set_fields
7517    ((struct field *) TYPE_ZALLOC (rtype, nfields * sizeof (struct field)));
7518   rtype->set_name (ada_type_name (type));
7519   rtype->set_is_fixed_instance (true);
7520
7521   off = 0;
7522   bit_len = 0;
7523   variant_field = -1;
7524
7525   for (f = 0; f < nfields; f += 1)
7526     {
7527       off = align_up (off, field_alignment (type, f))
7528         + TYPE_FIELD_BITPOS (type, f);
7529       rtype->field (f).set_loc_bitpos (off);
7530       TYPE_FIELD_BITSIZE (rtype, f) = 0;
7531
7532       if (ada_is_variant_part (type, f))
7533         {
7534           variant_field = f;
7535           fld_bit_len = 0;
7536         }
7537       else if (is_dynamic_field (type, f))
7538         {
7539           const gdb_byte *field_valaddr = valaddr;
7540           CORE_ADDR field_address = address;
7541           struct type *field_type =
7542             TYPE_TARGET_TYPE (type->field (f).type ());
7543
7544           if (dval0 == NULL)
7545             {
7546               /* Using plain value_from_contents_and_address here
7547                  causes problems because we will end up trying to
7548                  resolve a type that is currently being
7549                  constructed.  */
7550               dval = value_from_contents_and_address_unresolved (rtype,
7551                                                                  valaddr,
7552                                                                  address);
7553               rtype = value_type (dval);
7554             }
7555           else
7556             dval = dval0;
7557
7558           /* If the type referenced by this field is an aligner type, we need
7559              to unwrap that aligner type, because its size might not be set.
7560              Keeping the aligner type would cause us to compute the wrong
7561              size for this field, impacting the offset of the all the fields
7562              that follow this one.  */
7563           if (ada_is_aligner_type (field_type))
7564             {
7565               long field_offset = TYPE_FIELD_BITPOS (type, f);
7566
7567               field_valaddr = cond_offset_host (field_valaddr, field_offset);
7568               field_address = cond_offset_target (field_address, field_offset);
7569               field_type = ada_aligned_type (field_type);
7570             }
7571
7572           field_valaddr = cond_offset_host (field_valaddr,
7573                                             off / TARGET_CHAR_BIT);
7574           field_address = cond_offset_target (field_address,
7575                                               off / TARGET_CHAR_BIT);
7576
7577           /* Get the fixed type of the field.  Note that, in this case,
7578              we do not want to get the real type out of the tag: if
7579              the current field is the parent part of a tagged record,
7580              we will get the tag of the object.  Clearly wrong: the real
7581              type of the parent is not the real type of the child.  We
7582              would end up in an infinite loop.  */
7583           field_type = ada_get_base_type (field_type);
7584           field_type = ada_to_fixed_type (field_type, field_valaddr,
7585                                           field_address, dval, 0);
7586
7587           rtype->field (f).set_type (field_type);
7588           rtype->field (f).set_name (type->field (f).name ());
7589           /* The multiplication can potentially overflow.  But because
7590              the field length has been size-checked just above, and
7591              assuming that the maximum size is a reasonable value,
7592              an overflow should not happen in practice.  So rather than
7593              adding overflow recovery code to this already complex code,
7594              we just assume that it's not going to happen.  */
7595           fld_bit_len =
7596             TYPE_LENGTH (rtype->field (f).type ()) * TARGET_CHAR_BIT;
7597         }
7598       else
7599         {
7600           /* Note: If this field's type is a typedef, it is important
7601              to preserve the typedef layer.
7602
7603              Otherwise, we might be transforming a typedef to a fat
7604              pointer (encoding a pointer to an unconstrained array),
7605              into a basic fat pointer (encoding an unconstrained
7606              array).  As both types are implemented using the same
7607              structure, the typedef is the only clue which allows us
7608              to distinguish between the two options.  Stripping it
7609              would prevent us from printing this field appropriately.  */
7610           rtype->field (f).set_type (type->field (f).type ());
7611           rtype->field (f).set_name (type->field (f).name ());
7612           if (TYPE_FIELD_BITSIZE (type, f) > 0)
7613             fld_bit_len =
7614               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7615           else
7616             {
7617               struct type *field_type = type->field (f).type ();
7618
7619               /* We need to be careful of typedefs when computing
7620                  the length of our field.  If this is a typedef,
7621                  get the length of the target type, not the length
7622                  of the typedef.  */
7623               if (field_type->code () == TYPE_CODE_TYPEDEF)
7624                 field_type = ada_typedef_target_type (field_type);
7625
7626               fld_bit_len =
7627                 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7628             }
7629         }
7630       if (off + fld_bit_len > bit_len)
7631         bit_len = off + fld_bit_len;
7632       off += fld_bit_len;
7633       TYPE_LENGTH (rtype) =
7634         align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7635     }
7636
7637   /* We handle the variant part, if any, at the end because of certain
7638      odd cases in which it is re-ordered so as NOT to be the last field of
7639      the record.  This can happen in the presence of representation
7640      clauses.  */
7641   if (variant_field >= 0)
7642     {
7643       struct type *branch_type;
7644
7645       off = TYPE_FIELD_BITPOS (rtype, variant_field);
7646
7647       if (dval0 == NULL)
7648         {
7649           /* Using plain value_from_contents_and_address here causes
7650              problems because we will end up trying to resolve a type
7651              that is currently being constructed.  */
7652           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
7653                                                              address);
7654           rtype = value_type (dval);
7655         }
7656       else
7657         dval = dval0;
7658
7659       branch_type =
7660         to_fixed_variant_branch_type
7661         (type->field (variant_field).type (),
7662          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7663          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7664       if (branch_type == NULL)
7665         {
7666           for (f = variant_field + 1; f < rtype->num_fields (); f += 1)
7667             rtype->field (f - 1) = rtype->field (f);
7668           rtype->set_num_fields (rtype->num_fields () - 1);
7669         }
7670       else
7671         {
7672           rtype->field (variant_field).set_type (branch_type);
7673           rtype->field (variant_field).set_name ("S");
7674           fld_bit_len =
7675             TYPE_LENGTH (rtype->field (variant_field).type ()) *
7676             TARGET_CHAR_BIT;
7677           if (off + fld_bit_len > bit_len)
7678             bit_len = off + fld_bit_len;
7679           TYPE_LENGTH (rtype) =
7680             align_up (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7681         }
7682     }
7683
7684   /* According to exp_dbug.ads, the size of TYPE for variable-size records
7685      should contain the alignment of that record, which should be a strictly
7686      positive value.  If null or negative, then something is wrong, most
7687      probably in the debug info.  In that case, we don't round up the size
7688      of the resulting type.  If this record is not part of another structure,
7689      the current RTYPE length might be good enough for our purposes.  */
7690   if (TYPE_LENGTH (type) <= 0)
7691     {
7692       if (rtype->name ())
7693         warning (_("Invalid type size for `%s' detected: %s."),
7694                  rtype->name (), pulongest (TYPE_LENGTH (type)));
7695       else
7696         warning (_("Invalid type size for <unnamed> detected: %s."),
7697                  pulongest (TYPE_LENGTH (type)));
7698     }
7699   else
7700     {
7701       TYPE_LENGTH (rtype) = align_up (TYPE_LENGTH (rtype),
7702                                       TYPE_LENGTH (type));
7703     }
7704
7705   value_free_to_mark (mark);
7706   return rtype;
7707 }
7708
7709 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7710    of 1.  */
7711
7712 static struct type *
7713 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
7714                                CORE_ADDR address, struct value *dval0)
7715 {
7716   return ada_template_to_fixed_record_type_1 (type, valaddr,
7717                                               address, dval0, 1);
7718 }
7719
7720 /* An ordinary record type in which ___XVL-convention fields and
7721    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7722    static approximations, containing all possible fields.  Uses
7723    no runtime values.  Useless for use in values, but that's OK,
7724    since the results are used only for type determinations.   Works on both
7725    structs and unions.  Representation note: to save space, we memorize
7726    the result of this function in the TYPE_TARGET_TYPE of the
7727    template type.  */
7728
7729 static struct type *
7730 template_to_static_fixed_type (struct type *type0)
7731 {
7732   struct type *type;
7733   int nfields;
7734   int f;
7735
7736   /* No need no do anything if the input type is already fixed.  */
7737   if (type0->is_fixed_instance ())
7738     return type0;
7739
7740   /* Likewise if we already have computed the static approximation.  */
7741   if (TYPE_TARGET_TYPE (type0) != NULL)
7742     return TYPE_TARGET_TYPE (type0);
7743
7744   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
7745   type = type0;
7746   nfields = type0->num_fields ();
7747
7748   /* Whether or not we cloned TYPE0, cache the result so that we don't do
7749      recompute all over next time.  */
7750   TYPE_TARGET_TYPE (type0) = type;
7751
7752   for (f = 0; f < nfields; f += 1)
7753     {
7754       struct type *field_type = type0->field (f).type ();
7755       struct type *new_type;
7756
7757       if (is_dynamic_field (type0, f))
7758         {
7759           field_type = ada_check_typedef (field_type);
7760           new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
7761         }
7762       else
7763         new_type = static_unwrap_type (field_type);
7764
7765       if (new_type != field_type)
7766         {
7767           /* Clone TYPE0 only the first time we get a new field type.  */
7768           if (type == type0)
7769             {
7770               TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
7771               type->set_code (type0->code ());
7772               INIT_NONE_SPECIFIC (type);
7773               type->set_num_fields (nfields);
7774
7775               field *fields =
7776                 ((struct field *)
7777                  TYPE_ALLOC (type, nfields * sizeof (struct field)));
7778               memcpy (fields, type0->fields (),
7779                       sizeof (struct field) * nfields);
7780               type->set_fields (fields);
7781
7782               type->set_name (ada_type_name (type0));
7783               type->set_is_fixed_instance (true);
7784               TYPE_LENGTH (type) = 0;
7785             }
7786           type->field (f).set_type (new_type);
7787           type->field (f).set_name (type0->field (f).name ());
7788         }
7789     }
7790
7791   return type;
7792 }
7793
7794 /* Given an object of type TYPE whose contents are at VALADDR and
7795    whose address in memory is ADDRESS, returns a revision of TYPE,
7796    which should be a non-dynamic-sized record, in which the variant
7797    part, if any, is replaced with the appropriate branch.  Looks
7798    for discriminant values in DVAL0, which can be NULL if the record
7799    contains the necessary discriminant values.  */
7800
7801 static struct type *
7802 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
7803                                    CORE_ADDR address, struct value *dval0)
7804 {
7805   struct value *mark = value_mark ();
7806   struct value *dval;
7807   struct type *rtype;
7808   struct type *branch_type;
7809   int nfields = type->num_fields ();
7810   int variant_field = variant_field_index (type);
7811
7812   if (variant_field == -1)
7813     return type;
7814
7815   if (dval0 == NULL)
7816     {
7817       dval = value_from_contents_and_address (type, valaddr, address);
7818       type = value_type (dval);
7819     }
7820   else
7821     dval = dval0;
7822
7823   rtype = alloc_type_copy (type);
7824   rtype->set_code (TYPE_CODE_STRUCT);
7825   INIT_NONE_SPECIFIC (rtype);
7826   rtype->set_num_fields (nfields);
7827
7828   field *fields =
7829     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7830   memcpy (fields, type->fields (), sizeof (struct field) * nfields);
7831   rtype->set_fields (fields);
7832
7833   rtype->set_name (ada_type_name (type));
7834   rtype->set_is_fixed_instance (true);
7835   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7836
7837   branch_type = to_fixed_variant_branch_type
7838     (type->field (variant_field).type (),
7839      cond_offset_host (valaddr,
7840                        TYPE_FIELD_BITPOS (type, variant_field)
7841                        / TARGET_CHAR_BIT),
7842      cond_offset_target (address,
7843                          TYPE_FIELD_BITPOS (type, variant_field)
7844                          / TARGET_CHAR_BIT), dval);
7845   if (branch_type == NULL)
7846     {
7847       int f;
7848
7849       for (f = variant_field + 1; f < nfields; f += 1)
7850         rtype->field (f - 1) = rtype->field (f);
7851       rtype->set_num_fields (rtype->num_fields () - 1);
7852     }
7853   else
7854     {
7855       rtype->field (variant_field).set_type (branch_type);
7856       rtype->field (variant_field).set_name ("S");
7857       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
7858       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
7859     }
7860   TYPE_LENGTH (rtype) -= TYPE_LENGTH (type->field (variant_field).type ());
7861
7862   value_free_to_mark (mark);
7863   return rtype;
7864 }
7865
7866 /* An ordinary record type (with fixed-length fields) that describes
7867    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7868    beginning of this section].   Any necessary discriminants' values
7869    should be in DVAL, a record value; it may be NULL if the object
7870    at ADDR itself contains any necessary discriminant values.
7871    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7872    values from the record are needed.  Except in the case that DVAL,
7873    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7874    unchecked) is replaced by a particular branch of the variant.
7875
7876    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7877    is questionable and may be removed.  It can arise during the
7878    processing of an unconstrained-array-of-record type where all the
7879    variant branches have exactly the same size.  This is because in
7880    such cases, the compiler does not bother to use the XVS convention
7881    when encoding the record.  I am currently dubious of this
7882    shortcut and suspect the compiler should be altered.  FIXME.  */
7883
7884 static struct type *
7885 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
7886                       CORE_ADDR address, struct value *dval)
7887 {
7888   struct type *templ_type;
7889
7890   if (type0->is_fixed_instance ())
7891     return type0;
7892
7893   templ_type = dynamic_template_type (type0);
7894
7895   if (templ_type != NULL)
7896     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
7897   else if (variant_field_index (type0) >= 0)
7898     {
7899       if (dval == NULL && valaddr == NULL && address == 0)
7900         return type0;
7901       return to_record_with_fixed_variant_part (type0, valaddr, address,
7902                                                 dval);
7903     }
7904   else
7905     {
7906       type0->set_is_fixed_instance (true);
7907       return type0;
7908     }
7909
7910 }
7911
7912 /* An ordinary record type (with fixed-length fields) that describes
7913    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7914    union type.  Any necessary discriminants' values should be in DVAL,
7915    a record value.  That is, this routine selects the appropriate
7916    branch of the union at ADDR according to the discriminant value
7917    indicated in the union's type name.  Returns VAR_TYPE0 itself if
7918    it represents a variant subject to a pragma Unchecked_Union.  */
7919
7920 static struct type *
7921 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
7922                               CORE_ADDR address, struct value *dval)
7923 {
7924   int which;
7925   struct type *templ_type;
7926   struct type *var_type;
7927
7928   if (var_type0->code () == TYPE_CODE_PTR)
7929     var_type = TYPE_TARGET_TYPE (var_type0);
7930   else
7931     var_type = var_type0;
7932
7933   templ_type = ada_find_parallel_type (var_type, "___XVU");
7934
7935   if (templ_type != NULL)
7936     var_type = templ_type;
7937
7938   if (is_unchecked_variant (var_type, value_type (dval)))
7939       return var_type0;
7940   which = ada_which_variant_applies (var_type, dval);
7941
7942   if (which < 0)
7943     return empty_record (var_type);
7944   else if (is_dynamic_field (var_type, which))
7945     return to_fixed_record_type
7946       (TYPE_TARGET_TYPE (var_type->field (which).type ()),
7947        valaddr, address, dval);
7948   else if (variant_field_index (var_type->field (which).type ()) >= 0)
7949     return
7950       to_fixed_record_type
7951       (var_type->field (which).type (), valaddr, address, dval);
7952   else
7953     return var_type->field (which).type ();
7954 }
7955
7956 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
7957    ENCODING_TYPE, a type following the GNAT conventions for discrete
7958    type encodings, only carries redundant information.  */
7959
7960 static int
7961 ada_is_redundant_range_encoding (struct type *range_type,
7962                                  struct type *encoding_type)
7963 {
7964   const char *bounds_str;
7965   int n;
7966   LONGEST lo, hi;
7967
7968   gdb_assert (range_type->code () == TYPE_CODE_RANGE);
7969
7970   if (get_base_type (range_type)->code ()
7971       != get_base_type (encoding_type)->code ())
7972     {
7973       /* The compiler probably used a simple base type to describe
7974          the range type instead of the range's actual base type,
7975          expecting us to get the real base type from the encoding
7976          anyway.  In this situation, the encoding cannot be ignored
7977          as redundant.  */
7978       return 0;
7979     }
7980
7981   if (is_dynamic_type (range_type))
7982     return 0;
7983
7984   if (encoding_type->name () == NULL)
7985     return 0;
7986
7987   bounds_str = strstr (encoding_type->name (), "___XDLU_");
7988   if (bounds_str == NULL)
7989     return 0;
7990
7991   n = 8; /* Skip "___XDLU_".  */
7992   if (!ada_scan_number (bounds_str, n, &lo, &n))
7993     return 0;
7994   if (range_type->bounds ()->low.const_val () != lo)
7995     return 0;
7996
7997   n += 2; /* Skip the "__" separator between the two bounds.  */
7998   if (!ada_scan_number (bounds_str, n, &hi, &n))
7999     return 0;
8000   if (range_type->bounds ()->high.const_val () != hi)
8001     return 0;
8002
8003   return 1;
8004 }
8005
8006 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8007    a type following the GNAT encoding for describing array type
8008    indices, only carries redundant information.  */
8009
8010 static int
8011 ada_is_redundant_index_type_desc (struct type *array_type,
8012                                   struct type *desc_type)
8013 {
8014   struct type *this_layer = check_typedef (array_type);
8015   int i;
8016
8017   for (i = 0; i < desc_type->num_fields (); i++)
8018     {
8019       if (!ada_is_redundant_range_encoding (this_layer->index_type (),
8020                                             desc_type->field (i).type ()))
8021         return 0;
8022       this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8023     }
8024
8025   return 1;
8026 }
8027
8028 /* Assuming that TYPE0 is an array type describing the type of a value
8029    at ADDR, and that DVAL describes a record containing any
8030    discriminants used in TYPE0, returns a type for the value that
8031    contains no dynamic components (that is, no components whose sizes
8032    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
8033    true, gives an error message if the resulting type's size is over
8034    varsize_limit.  */
8035
8036 static struct type *
8037 to_fixed_array_type (struct type *type0, struct value *dval,
8038                      int ignore_too_big)
8039 {
8040   struct type *index_type_desc;
8041   struct type *result;
8042   int constrained_packed_array_p;
8043   static const char *xa_suffix = "___XA";
8044
8045   type0 = ada_check_typedef (type0);
8046   if (type0->is_fixed_instance ())
8047     return type0;
8048
8049   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8050   if (constrained_packed_array_p)
8051     {
8052       type0 = decode_constrained_packed_array_type (type0);
8053       if (type0 == nullptr)
8054         error (_("could not decode constrained packed array type"));
8055     }
8056
8057   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8058
8059   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8060      encoding suffixed with 'P' may still be generated.  If so,
8061      it should be used to find the XA type.  */
8062
8063   if (index_type_desc == NULL)
8064     {
8065       const char *type_name = ada_type_name (type0);
8066
8067       if (type_name != NULL)
8068         {
8069           const int len = strlen (type_name);
8070           char *name = (char *) alloca (len + strlen (xa_suffix));
8071
8072           if (type_name[len - 1] == 'P')
8073             {
8074               strcpy (name, type_name);
8075               strcpy (name + len - 1, xa_suffix);
8076               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8077             }
8078         }
8079     }
8080
8081   ada_fixup_array_indexes_type (index_type_desc);
8082   if (index_type_desc != NULL
8083       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8084     {
8085       /* Ignore this ___XA parallel type, as it does not bring any
8086          useful information.  This allows us to avoid creating fixed
8087          versions of the array's index types, which would be identical
8088          to the original ones.  This, in turn, can also help avoid
8089          the creation of fixed versions of the array itself.  */
8090       index_type_desc = NULL;
8091     }
8092
8093   if (index_type_desc == NULL)
8094     {
8095       struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8096
8097       /* NOTE: elt_type---the fixed version of elt_type0---should never
8098          depend on the contents of the array in properly constructed
8099          debugging data.  */
8100       /* Create a fixed version of the array element type.
8101          We're not providing the address of an element here,
8102          and thus the actual object value cannot be inspected to do
8103          the conversion.  This should not be a problem, since arrays of
8104          unconstrained objects are not allowed.  In particular, all
8105          the elements of an array of a tagged type should all be of
8106          the same type specified in the debugging info.  No need to
8107          consult the object tag.  */
8108       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8109
8110       /* Make sure we always create a new array type when dealing with
8111          packed array types, since we're going to fix-up the array
8112          type length and element bitsize a little further down.  */
8113       if (elt_type0 == elt_type && !constrained_packed_array_p)
8114         result = type0;
8115       else
8116         result = create_array_type (alloc_type_copy (type0),
8117                                     elt_type, type0->index_type ());
8118     }
8119   else
8120     {
8121       int i;
8122       struct type *elt_type0;
8123
8124       elt_type0 = type0;
8125       for (i = index_type_desc->num_fields (); i > 0; i -= 1)
8126         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8127
8128       /* NOTE: result---the fixed version of elt_type0---should never
8129          depend on the contents of the array in properly constructed
8130          debugging data.  */
8131       /* Create a fixed version of the array element type.
8132          We're not providing the address of an element here,
8133          and thus the actual object value cannot be inspected to do
8134          the conversion.  This should not be a problem, since arrays of
8135          unconstrained objects are not allowed.  In particular, all
8136          the elements of an array of a tagged type should all be of
8137          the same type specified in the debugging info.  No need to
8138          consult the object tag.  */
8139       result =
8140         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8141
8142       elt_type0 = type0;
8143       for (i = index_type_desc->num_fields () - 1; i >= 0; i -= 1)
8144         {
8145           struct type *range_type =
8146             to_fixed_range_type (index_type_desc->field (i).type (), dval);
8147
8148           result = create_array_type (alloc_type_copy (elt_type0),
8149                                       result, range_type);
8150           elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8151         }
8152     }
8153
8154   /* We want to preserve the type name.  This can be useful when
8155      trying to get the type name of a value that has already been
8156      printed (for instance, if the user did "print VAR; whatis $".  */
8157   result->set_name (type0->name ());
8158
8159   if (constrained_packed_array_p)
8160     {
8161       /* So far, the resulting type has been created as if the original
8162          type was a regular (non-packed) array type.  As a result, the
8163          bitsize of the array elements needs to be set again, and the array
8164          length needs to be recomputed based on that bitsize.  */
8165       int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8166       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8167
8168       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8169       TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8170       if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8171         TYPE_LENGTH (result)++;
8172     }
8173
8174   result->set_is_fixed_instance (true);
8175   return result;
8176 }
8177
8178
8179 /* A standard type (containing no dynamically sized components)
8180    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8181    DVAL describes a record containing any discriminants used in TYPE0,
8182    and may be NULL if there are none, or if the object of type TYPE at
8183    ADDRESS or in VALADDR contains these discriminants.
8184    
8185    If CHECK_TAG is not null, in the case of tagged types, this function
8186    attempts to locate the object's tag and use it to compute the actual
8187    type.  However, when ADDRESS is null, we cannot use it to determine the
8188    location of the tag, and therefore compute the tagged type's actual type.
8189    So we return the tagged type without consulting the tag.  */
8190    
8191 static struct type *
8192 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8193                    CORE_ADDR address, struct value *dval, int check_tag)
8194 {
8195   type = ada_check_typedef (type);
8196
8197   /* Only un-fixed types need to be handled here.  */
8198   if (!HAVE_GNAT_AUX_INFO (type))
8199     return type;
8200
8201   switch (type->code ())
8202     {
8203     default:
8204       return type;
8205     case TYPE_CODE_STRUCT:
8206       {
8207         struct type *static_type = to_static_fixed_type (type);
8208         struct type *fixed_record_type =
8209           to_fixed_record_type (type, valaddr, address, NULL);
8210
8211         /* If STATIC_TYPE is a tagged type and we know the object's address,
8212            then we can determine its tag, and compute the object's actual
8213            type from there.  Note that we have to use the fixed record
8214            type (the parent part of the record may have dynamic fields
8215            and the way the location of _tag is expressed may depend on
8216            them).  */
8217
8218         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8219           {
8220             struct value *tag =
8221               value_tag_from_contents_and_address
8222               (fixed_record_type,
8223                valaddr,
8224                address);
8225             struct type *real_type = type_from_tag (tag);
8226             struct value *obj =
8227               value_from_contents_and_address (fixed_record_type,
8228                                                valaddr,
8229                                                address);
8230             fixed_record_type = value_type (obj);
8231             if (real_type != NULL)
8232               return to_fixed_record_type
8233                 (real_type, NULL,
8234                  value_address (ada_tag_value_at_base_address (obj)), NULL);
8235           }
8236
8237         /* Check to see if there is a parallel ___XVZ variable.
8238            If there is, then it provides the actual size of our type.  */
8239         else if (ada_type_name (fixed_record_type) != NULL)
8240           {
8241             const char *name = ada_type_name (fixed_record_type);
8242             char *xvz_name
8243               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8244             bool xvz_found = false;
8245             LONGEST size;
8246
8247             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8248             try
8249               {
8250                 xvz_found = get_int_var_value (xvz_name, size);
8251               }
8252             catch (const gdb_exception_error &except)
8253               {
8254                 /* We found the variable, but somehow failed to read
8255                    its value.  Rethrow the same error, but with a little
8256                    bit more information, to help the user understand
8257                    what went wrong (Eg: the variable might have been
8258                    optimized out).  */
8259                 throw_error (except.error,
8260                              _("unable to read value of %s (%s)"),
8261                              xvz_name, except.what ());
8262               }
8263
8264             if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8265               {
8266                 fixed_record_type = copy_type (fixed_record_type);
8267                 TYPE_LENGTH (fixed_record_type) = size;
8268
8269                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
8270                    observed this when the debugging info is STABS, and
8271                    apparently it is something that is hard to fix.
8272
8273                    In practice, we don't need the actual type definition
8274                    at all, because the presence of the XVZ variable allows us
8275                    to assume that there must be a XVS type as well, which we
8276                    should be able to use later, when we need the actual type
8277                    definition.
8278
8279                    In the meantime, pretend that the "fixed" type we are
8280                    returning is NOT a stub, because this can cause trouble
8281                    when using this type to create new types targeting it.
8282                    Indeed, the associated creation routines often check
8283                    whether the target type is a stub and will try to replace
8284                    it, thus using a type with the wrong size.  This, in turn,
8285                    might cause the new type to have the wrong size too.
8286                    Consider the case of an array, for instance, where the size
8287                    of the array is computed from the number of elements in
8288                    our array multiplied by the size of its element.  */
8289                 fixed_record_type->set_is_stub (false);
8290               }
8291           }
8292         return fixed_record_type;
8293       }
8294     case TYPE_CODE_ARRAY:
8295       return to_fixed_array_type (type, dval, 1);
8296     case TYPE_CODE_UNION:
8297       if (dval == NULL)
8298         return type;
8299       else
8300         return to_fixed_variant_branch_type (type, valaddr, address, dval);
8301     }
8302 }
8303
8304 /* The same as ada_to_fixed_type_1, except that it preserves the type
8305    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8306
8307    The typedef layer needs be preserved in order to differentiate between
8308    arrays and array pointers when both types are implemented using the same
8309    fat pointer.  In the array pointer case, the pointer is encoded as
8310    a typedef of the pointer type.  For instance, considering:
8311
8312           type String_Access is access String;
8313           S1 : String_Access := null;
8314
8315    To the debugger, S1 is defined as a typedef of type String.  But
8316    to the user, it is a pointer.  So if the user tries to print S1,
8317    we should not dereference the array, but print the array address
8318    instead.
8319
8320    If we didn't preserve the typedef layer, we would lose the fact that
8321    the type is to be presented as a pointer (needs de-reference before
8322    being printed).  And we would also use the source-level type name.  */
8323
8324 struct type *
8325 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8326                    CORE_ADDR address, struct value *dval, int check_tag)
8327
8328 {
8329   struct type *fixed_type =
8330     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8331
8332   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8333       then preserve the typedef layer.
8334
8335       Implementation note: We can only check the main-type portion of
8336       the TYPE and FIXED_TYPE, because eliminating the typedef layer
8337       from TYPE now returns a type that has the same instance flags
8338       as TYPE.  For instance, if TYPE is a "typedef const", and its
8339       target type is a "struct", then the typedef elimination will return
8340       a "const" version of the target type.  See check_typedef for more
8341       details about how the typedef layer elimination is done.
8342
8343       brobecker/2010-11-19: It seems to me that the only case where it is
8344       useful to preserve the typedef layer is when dealing with fat pointers.
8345       Perhaps, we could add a check for that and preserve the typedef layer
8346       only in that situation.  But this seems unnecessary so far, probably
8347       because we call check_typedef/ada_check_typedef pretty much everywhere.
8348       */
8349   if (type->code () == TYPE_CODE_TYPEDEF
8350       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8351           == TYPE_MAIN_TYPE (fixed_type)))
8352     return type;
8353
8354   return fixed_type;
8355 }
8356
8357 /* A standard (static-sized) type corresponding as well as possible to
8358    TYPE0, but based on no runtime data.  */
8359
8360 static struct type *
8361 to_static_fixed_type (struct type *type0)
8362 {
8363   struct type *type;
8364
8365   if (type0 == NULL)
8366     return NULL;
8367
8368   if (type0->is_fixed_instance ())
8369     return type0;
8370
8371   type0 = ada_check_typedef (type0);
8372
8373   switch (type0->code ())
8374     {
8375     default:
8376       return type0;
8377     case TYPE_CODE_STRUCT:
8378       type = dynamic_template_type (type0);
8379       if (type != NULL)
8380         return template_to_static_fixed_type (type);
8381       else
8382         return template_to_static_fixed_type (type0);
8383     case TYPE_CODE_UNION:
8384       type = ada_find_parallel_type (type0, "___XVU");
8385       if (type != NULL)
8386         return template_to_static_fixed_type (type);
8387       else
8388         return template_to_static_fixed_type (type0);
8389     }
8390 }
8391
8392 /* A static approximation of TYPE with all type wrappers removed.  */
8393
8394 static struct type *
8395 static_unwrap_type (struct type *type)
8396 {
8397   if (ada_is_aligner_type (type))
8398     {
8399       struct type *type1 = ada_check_typedef (type)->field (0).type ();
8400       if (ada_type_name (type1) == NULL)
8401         type1->set_name (ada_type_name (type));
8402
8403       return static_unwrap_type (type1);
8404     }
8405   else
8406     {
8407       struct type *raw_real_type = ada_get_base_type (type);
8408
8409       if (raw_real_type == type)
8410         return type;
8411       else
8412         return to_static_fixed_type (raw_real_type);
8413     }
8414 }
8415
8416 /* In some cases, incomplete and private types require
8417    cross-references that are not resolved as records (for example,
8418       type Foo;
8419       type FooP is access Foo;
8420       V: FooP;
8421       type Foo is array ...;
8422    ).  In these cases, since there is no mechanism for producing
8423    cross-references to such types, we instead substitute for FooP a
8424    stub enumeration type that is nowhere resolved, and whose tag is
8425    the name of the actual type.  Call these types "non-record stubs".  */
8426
8427 /* A type equivalent to TYPE that is not a non-record stub, if one
8428    exists, otherwise TYPE.  */
8429
8430 struct type *
8431 ada_check_typedef (struct type *type)
8432 {
8433   if (type == NULL)
8434     return NULL;
8435
8436   /* If our type is an access to an unconstrained array, which is encoded
8437      as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8438      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8439      what allows us to distinguish between fat pointers that represent
8440      array types, and fat pointers that represent array access types
8441      (in both cases, the compiler implements them as fat pointers).  */
8442   if (ada_is_access_to_unconstrained_array (type))
8443     return type;
8444
8445   type = check_typedef (type);
8446   if (type == NULL || type->code () != TYPE_CODE_ENUM
8447       || !type->is_stub ()
8448       || type->name () == NULL)
8449     return type;
8450   else
8451     {
8452       const char *name = type->name ();
8453       struct type *type1 = ada_find_any_type (name);
8454
8455       if (type1 == NULL)
8456         return type;
8457
8458       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8459          stubs pointing to arrays, as we don't create symbols for array
8460          types, only for the typedef-to-array types).  If that's the case,
8461          strip the typedef layer.  */
8462       if (type1->code () == TYPE_CODE_TYPEDEF)
8463         type1 = ada_check_typedef (type1);
8464
8465       return type1;
8466     }
8467 }
8468
8469 /* A value representing the data at VALADDR/ADDRESS as described by
8470    type TYPE0, but with a standard (static-sized) type that correctly
8471    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
8472    type, then return VAL0 [this feature is simply to avoid redundant
8473    creation of struct values].  */
8474
8475 static struct value *
8476 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8477                            struct value *val0)
8478 {
8479   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8480
8481   if (type == type0 && val0 != NULL)
8482     return val0;
8483
8484   if (VALUE_LVAL (val0) != lval_memory)
8485     {
8486       /* Our value does not live in memory; it could be a convenience
8487          variable, for instance.  Create a not_lval value using val0's
8488          contents.  */
8489       return value_from_contents (type, value_contents (val0).data ());
8490     }
8491
8492   return value_from_contents_and_address (type, 0, address);
8493 }
8494
8495 /* A value representing VAL, but with a standard (static-sized) type
8496    that correctly describes it.  Does not necessarily create a new
8497    value.  */
8498
8499 struct value *
8500 ada_to_fixed_value (struct value *val)
8501 {
8502   val = unwrap_value (val);
8503   val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
8504   return val;
8505 }
8506 \f
8507
8508 /* Attributes */
8509
8510 /* Table mapping attribute numbers to names.
8511    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
8512
8513 static const char * const attribute_names[] = {
8514   "<?>",
8515
8516   "first",
8517   "last",
8518   "length",
8519   "image",
8520   "max",
8521   "min",
8522   "modulus",
8523   "pos",
8524   "size",
8525   "tag",
8526   "val",
8527   0
8528 };
8529
8530 static const char *
8531 ada_attribute_name (enum exp_opcode n)
8532 {
8533   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8534     return attribute_names[n - OP_ATR_FIRST + 1];
8535   else
8536     return attribute_names[0];
8537 }
8538
8539 /* Evaluate the 'POS attribute applied to ARG.  */
8540
8541 static LONGEST
8542 pos_atr (struct value *arg)
8543 {
8544   struct value *val = coerce_ref (arg);
8545   struct type *type = value_type (val);
8546
8547   if (!discrete_type_p (type))
8548     error (_("'POS only defined on discrete types"));
8549
8550   gdb::optional<LONGEST> result = discrete_position (type, value_as_long (val));
8551   if (!result.has_value ())
8552     error (_("enumeration value is invalid: can't find 'POS"));
8553
8554   return *result;
8555 }
8556
8557 struct value *
8558 ada_pos_atr (struct type *expect_type,
8559              struct expression *exp,
8560              enum noside noside, enum exp_opcode op,
8561              struct value *arg)
8562 {
8563   struct type *type = builtin_type (exp->gdbarch)->builtin_int;
8564   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8565     return value_zero (type, not_lval);
8566   return value_from_longest (type, pos_atr (arg));
8567 }
8568
8569 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
8570
8571 static struct value *
8572 val_atr (struct type *type, LONGEST val)
8573 {
8574   gdb_assert (discrete_type_p (type));
8575   if (type->code () == TYPE_CODE_RANGE)
8576     type = TYPE_TARGET_TYPE (type);
8577   if (type->code () == TYPE_CODE_ENUM)
8578     {
8579       if (val < 0 || val >= type->num_fields ())
8580         error (_("argument to 'VAL out of range"));
8581       val = TYPE_FIELD_ENUMVAL (type, val);
8582     }
8583   return value_from_longest (type, val);
8584 }
8585
8586 struct value *
8587 ada_val_atr (enum noside noside, struct type *type, struct value *arg)
8588 {
8589   if (noside == EVAL_AVOID_SIDE_EFFECTS)
8590     return value_zero (type, not_lval);
8591
8592   if (!discrete_type_p (type))
8593     error (_("'VAL only defined on discrete types"));
8594   if (!integer_type_p (value_type (arg)))
8595     error (_("'VAL requires integral argument"));
8596
8597   return val_atr (type, value_as_long (arg));
8598 }
8599 \f
8600
8601                                 /* Evaluation */
8602
8603 /* True if TYPE appears to be an Ada character type.
8604    [At the moment, this is true only for Character and Wide_Character;
8605    It is a heuristic test that could stand improvement].  */
8606
8607 bool
8608 ada_is_character_type (struct type *type)
8609 {
8610   const char *name;
8611
8612   /* If the type code says it's a character, then assume it really is,
8613      and don't check any further.  */
8614   if (type->code () == TYPE_CODE_CHAR)
8615     return true;
8616   
8617   /* Otherwise, assume it's a character type iff it is a discrete type
8618      with a known character type name.  */
8619   name = ada_type_name (type);
8620   return (name != NULL
8621           && (type->code () == TYPE_CODE_INT
8622               || type->code () == TYPE_CODE_RANGE)
8623           && (strcmp (name, "character") == 0
8624               || strcmp (name, "wide_character") == 0
8625               || strcmp (name, "wide_wide_character") == 0
8626               || strcmp (name, "unsigned char") == 0));
8627 }
8628
8629 /* True if TYPE appears to be an Ada string type.  */
8630
8631 bool
8632 ada_is_string_type (struct type *type)
8633 {
8634   type = ada_check_typedef (type);
8635   if (type != NULL
8636       && type->code () != TYPE_CODE_PTR
8637       && (ada_is_simple_array_type (type)
8638           || ada_is_array_descriptor_type (type))
8639       && ada_array_arity (type) == 1)
8640     {
8641       struct type *elttype = ada_array_element_type (type, 1);
8642
8643       return ada_is_character_type (elttype);
8644     }
8645   else
8646     return false;
8647 }
8648
8649 /* The compiler sometimes provides a parallel XVS type for a given
8650    PAD type.  Normally, it is safe to follow the PAD type directly,
8651    but older versions of the compiler have a bug that causes the offset
8652    of its "F" field to be wrong.  Following that field in that case
8653    would lead to incorrect results, but this can be worked around
8654    by ignoring the PAD type and using the associated XVS type instead.
8655
8656    Set to True if the debugger should trust the contents of PAD types.
8657    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
8658 static bool trust_pad_over_xvs = true;
8659
8660 /* True if TYPE is a struct type introduced by the compiler to force the
8661    alignment of a value.  Such types have a single field with a
8662    distinctive name.  */
8663
8664 int
8665 ada_is_aligner_type (struct type *type)
8666 {
8667   type = ada_check_typedef (type);
8668
8669   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
8670     return 0;
8671
8672   return (type->code () == TYPE_CODE_STRUCT
8673           && type->num_fields () == 1
8674           && strcmp (type->field (0).name (), "F") == 0);
8675 }
8676
8677 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8678    the parallel type.  */
8679
8680 struct type *
8681 ada_get_base_type (struct type *raw_type)
8682 {
8683   struct type *real_type_namer;
8684   struct type *raw_real_type;
8685
8686   if (raw_type == NULL || raw_type->code () != TYPE_CODE_STRUCT)
8687     return raw_type;
8688
8689   if (ada_is_aligner_type (raw_type))
8690     /* The encoding specifies that we should always use the aligner type.
8691        So, even if this aligner type has an associated XVS type, we should
8692        simply ignore it.
8693
8694        According to the compiler gurus, an XVS type parallel to an aligner
8695        type may exist because of a stabs limitation.  In stabs, aligner
8696        types are empty because the field has a variable-sized type, and
8697        thus cannot actually be used as an aligner type.  As a result,
8698        we need the associated parallel XVS type to decode the type.
8699        Since the policy in the compiler is to not change the internal
8700        representation based on the debugging info format, we sometimes
8701        end up having a redundant XVS type parallel to the aligner type.  */
8702     return raw_type;
8703
8704   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
8705   if (real_type_namer == NULL
8706       || real_type_namer->code () != TYPE_CODE_STRUCT
8707       || real_type_namer->num_fields () != 1)
8708     return raw_type;
8709
8710   if (real_type_namer->field (0).type ()->code () != TYPE_CODE_REF)
8711     {
8712       /* This is an older encoding form where the base type needs to be
8713          looked up by name.  We prefer the newer encoding because it is
8714          more efficient.  */
8715       raw_real_type = ada_find_any_type (real_type_namer->field (0).name ());
8716       if (raw_real_type == NULL)
8717         return raw_type;
8718       else
8719         return raw_real_type;
8720     }
8721
8722   /* The field in our XVS type is a reference to the base type.  */
8723   return TYPE_TARGET_TYPE (real_type_namer->field (0).type ());
8724 }
8725
8726 /* The type of value designated by TYPE, with all aligners removed.  */
8727
8728 struct type *
8729 ada_aligned_type (struct type *type)
8730 {
8731   if (ada_is_aligner_type (type))
8732     return ada_aligned_type (type->field (0).type ());
8733   else
8734     return ada_get_base_type (type);
8735 }
8736
8737
8738 /* The address of the aligned value in an object at address VALADDR
8739    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
8740
8741 const gdb_byte *
8742 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
8743 {
8744   if (ada_is_aligner_type (type))
8745     return ada_aligned_value_addr (type->field (0).type (),
8746                                    valaddr +
8747                                    TYPE_FIELD_BITPOS (type,
8748                                                       0) / TARGET_CHAR_BIT);
8749   else
8750     return valaddr;
8751 }
8752
8753
8754
8755 /* The printed representation of an enumeration literal with encoded
8756    name NAME.  The value is good to the next call of ada_enum_name.  */
8757 const char *
8758 ada_enum_name (const char *name)
8759 {
8760   static std::string storage;
8761   const char *tmp;
8762
8763   /* First, unqualify the enumeration name:
8764      1. Search for the last '.' character.  If we find one, then skip
8765      all the preceding characters, the unqualified name starts
8766      right after that dot.
8767      2. Otherwise, we may be debugging on a target where the compiler
8768      translates dots into "__".  Search forward for double underscores,
8769      but stop searching when we hit an overloading suffix, which is
8770      of the form "__" followed by digits.  */
8771
8772   tmp = strrchr (name, '.');
8773   if (tmp != NULL)
8774     name = tmp + 1;
8775   else
8776     {
8777       while ((tmp = strstr (name, "__")) != NULL)
8778         {
8779           if (isdigit (tmp[2]))
8780             break;
8781           else
8782             name = tmp + 2;
8783         }
8784     }
8785
8786   if (name[0] == 'Q')
8787     {
8788       int v;
8789
8790       if (name[1] == 'U' || name[1] == 'W')
8791         {
8792           if (sscanf (name + 2, "%x", &v) != 1)
8793             return name;
8794         }
8795       else if (((name[1] >= '0' && name[1] <= '9')
8796                 || (name[1] >= 'a' && name[1] <= 'z'))
8797                && name[2] == '\0')
8798         {
8799           storage = string_printf ("'%c'", name[1]);
8800           return storage.c_str ();
8801         }
8802       else
8803         return name;
8804
8805       if (isascii (v) && isprint (v))
8806         storage = string_printf ("'%c'", v);
8807       else if (name[1] == 'U')
8808         storage = string_printf ("[\"%02x\"]", v);
8809       else
8810         storage = string_printf ("[\"%04x\"]", v);
8811
8812       return storage.c_str ();
8813     }
8814   else
8815     {
8816       tmp = strstr (name, "__");
8817       if (tmp == NULL)
8818         tmp = strstr (name, "$");
8819       if (tmp != NULL)
8820         {
8821           storage = std::string (name, tmp - name);
8822           return storage.c_str ();
8823         }
8824
8825       return name;
8826     }
8827 }
8828
8829 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8830    value it wraps.  */
8831
8832 static struct value *
8833 unwrap_value (struct value *val)
8834 {
8835   struct type *type = ada_check_typedef (value_type (val));
8836
8837   if (ada_is_aligner_type (type))
8838     {
8839       struct value *v = ada_value_struct_elt (val, "F", 0);
8840       struct type *val_type = ada_check_typedef (value_type (v));
8841
8842       if (ada_type_name (val_type) == NULL)
8843         val_type->set_name (ada_type_name (type));
8844
8845       return unwrap_value (v);
8846     }
8847   else
8848     {
8849       struct type *raw_real_type =
8850         ada_check_typedef (ada_get_base_type (type));
8851
8852       /* If there is no parallel XVS or XVE type, then the value is
8853          already unwrapped.  Return it without further modification.  */
8854       if ((type == raw_real_type)
8855           && ada_find_parallel_type (type, "___XVE") == NULL)
8856         return val;
8857
8858       return
8859         coerce_unspec_val_to_type
8860         (val, ada_to_fixed_type (raw_real_type, 0,
8861                                  value_address (val),
8862                                  NULL, 1));
8863     }
8864 }
8865
8866 /* Given two array types T1 and T2, return nonzero iff both arrays
8867    contain the same number of elements.  */
8868
8869 static int
8870 ada_same_array_size_p (struct type *t1, struct type *t2)
8871 {
8872   LONGEST lo1, hi1, lo2, hi2;
8873
8874   /* Get the array bounds in order to verify that the size of
8875      the two arrays match.  */
8876   if (!get_array_bounds (t1, &lo1, &hi1)
8877       || !get_array_bounds (t2, &lo2, &hi2))
8878     error (_("unable to determine array bounds"));
8879
8880   /* To make things easier for size comparison, normalize a bit
8881      the case of empty arrays by making sure that the difference
8882      between upper bound and lower bound is always -1.  */
8883   if (lo1 > hi1)
8884     hi1 = lo1 - 1;
8885   if (lo2 > hi2)
8886     hi2 = lo2 - 1;
8887
8888   return (hi1 - lo1 == hi2 - lo2);
8889 }
8890
8891 /* Assuming that VAL is an array of integrals, and TYPE represents
8892    an array with the same number of elements, but with wider integral
8893    elements, return an array "casted" to TYPE.  In practice, this
8894    means that the returned array is built by casting each element
8895    of the original array into TYPE's (wider) element type.  */
8896
8897 static struct value *
8898 ada_promote_array_of_integrals (struct type *type, struct value *val)
8899 {
8900   struct type *elt_type = TYPE_TARGET_TYPE (type);
8901   LONGEST lo, hi;
8902   struct value *res;
8903   LONGEST i;
8904
8905   /* Verify that both val and type are arrays of scalars, and
8906      that the size of val's elements is smaller than the size
8907      of type's element.  */
8908   gdb_assert (type->code () == TYPE_CODE_ARRAY);
8909   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
8910   gdb_assert (value_type (val)->code () == TYPE_CODE_ARRAY);
8911   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
8912   gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
8913               > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
8914
8915   if (!get_array_bounds (type, &lo, &hi))
8916     error (_("unable to determine array bounds"));
8917
8918   res = allocate_value (type);
8919
8920   /* Promote each array element.  */
8921   for (i = 0; i < hi - lo + 1; i++)
8922     {
8923       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
8924
8925       memcpy ((value_contents_writeable (res).data ()
8926                + (i * TYPE_LENGTH (elt_type))),
8927               value_contents_all (elt).data (), TYPE_LENGTH (elt_type));
8928     }
8929
8930   return res;
8931 }
8932
8933 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8934    return the converted value.  */
8935
8936 static struct value *
8937 coerce_for_assign (struct type *type, struct value *val)
8938 {
8939   struct type *type2 = value_type (val);
8940
8941   if (type == type2)
8942     return val;
8943
8944   type2 = ada_check_typedef (type2);
8945   type = ada_check_typedef (type);
8946
8947   if (type2->code () == TYPE_CODE_PTR
8948       && type->code () == TYPE_CODE_ARRAY)
8949     {
8950       val = ada_value_ind (val);
8951       type2 = value_type (val);
8952     }
8953
8954   if (type2->code () == TYPE_CODE_ARRAY
8955       && type->code () == TYPE_CODE_ARRAY)
8956     {
8957       if (!ada_same_array_size_p (type, type2))
8958         error (_("cannot assign arrays of different length"));
8959
8960       if (is_integral_type (TYPE_TARGET_TYPE (type))
8961           && is_integral_type (TYPE_TARGET_TYPE (type2))
8962           && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8963                < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8964         {
8965           /* Allow implicit promotion of the array elements to
8966              a wider type.  */
8967           return ada_promote_array_of_integrals (type, val);
8968         }
8969
8970       if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8971           != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8972         error (_("Incompatible types in assignment"));
8973       deprecated_set_value_type (val, type);
8974     }
8975   return val;
8976 }
8977
8978 static struct value *
8979 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
8980 {
8981   struct value *val;
8982   struct type *type1, *type2;
8983   LONGEST v, v1, v2;
8984
8985   arg1 = coerce_ref (arg1);
8986   arg2 = coerce_ref (arg2);
8987   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
8988   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
8989
8990   if (type1->code () != TYPE_CODE_INT
8991       || type2->code () != TYPE_CODE_INT)
8992     return value_binop (arg1, arg2, op);
8993
8994   switch (op)
8995     {
8996     case BINOP_MOD:
8997     case BINOP_DIV:
8998     case BINOP_REM:
8999       break;
9000     default:
9001       return value_binop (arg1, arg2, op);
9002     }
9003
9004   v2 = value_as_long (arg2);
9005   if (v2 == 0)
9006     {
9007       const char *name;
9008       if (op == BINOP_MOD)
9009         name = "mod";
9010       else if (op == BINOP_DIV)
9011         name = "/";
9012       else
9013         {
9014           gdb_assert (op == BINOP_REM);
9015           name = "rem";
9016         }
9017
9018       error (_("second operand of %s must not be zero."), name);
9019     }
9020
9021   if (type1->is_unsigned () || op == BINOP_MOD)
9022     return value_binop (arg1, arg2, op);
9023
9024   v1 = value_as_long (arg1);
9025   switch (op)
9026     {
9027     case BINOP_DIV:
9028       v = v1 / v2;
9029       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9030         v += v > 0 ? -1 : 1;
9031       break;
9032     case BINOP_REM:
9033       v = v1 % v2;
9034       if (v * v1 < 0)
9035         v -= v2;
9036       break;
9037     default:
9038       /* Should not reach this point.  */
9039       v = 0;
9040     }
9041
9042   val = allocate_value (type1);
9043   store_unsigned_integer (value_contents_raw (val).data (),
9044                           TYPE_LENGTH (value_type (val)),
9045                           type_byte_order (type1), v);
9046   return val;
9047 }
9048
9049 static int
9050 ada_value_equal (struct value *arg1, struct value *arg2)
9051 {
9052   if (ada_is_direct_array_type (value_type (arg1))
9053       || ada_is_direct_array_type (value_type (arg2)))
9054     {
9055       struct type *arg1_type, *arg2_type;
9056
9057       /* Automatically dereference any array reference before
9058          we attempt to perform the comparison.  */
9059       arg1 = ada_coerce_ref (arg1);
9060       arg2 = ada_coerce_ref (arg2);
9061
9062       arg1 = ada_coerce_to_simple_array (arg1);
9063       arg2 = ada_coerce_to_simple_array (arg2);
9064
9065       arg1_type = ada_check_typedef (value_type (arg1));
9066       arg2_type = ada_check_typedef (value_type (arg2));
9067
9068       if (arg1_type->code () != TYPE_CODE_ARRAY
9069           || arg2_type->code () != TYPE_CODE_ARRAY)
9070         error (_("Attempt to compare array with non-array"));
9071       /* FIXME: The following works only for types whose
9072          representations use all bits (no padding or undefined bits)
9073          and do not have user-defined equality.  */
9074       return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9075               && memcmp (value_contents (arg1).data (),
9076                          value_contents (arg2).data (),
9077                          TYPE_LENGTH (arg1_type)) == 0);
9078     }
9079   return value_equal (arg1, arg2);
9080 }
9081
9082 namespace expr
9083 {
9084
9085 bool
9086 check_objfile (const std::unique_ptr<ada_component> &comp,
9087                struct objfile *objfile)
9088 {
9089   return comp->uses_objfile (objfile);
9090 }
9091
9092 /* Assign the result of evaluating ARG starting at *POS to the INDEXth
9093    component of LHS (a simple array or a record).  Does not modify the
9094    inferior's memory, nor does it modify LHS (unless LHS ==
9095    CONTAINER).  */
9096
9097 static void
9098 assign_component (struct value *container, struct value *lhs, LONGEST index,
9099                   struct expression *exp, operation_up &arg)
9100 {
9101   scoped_value_mark mark;
9102
9103   struct value *elt;
9104   struct type *lhs_type = check_typedef (value_type (lhs));
9105
9106   if (lhs_type->code () == TYPE_CODE_ARRAY)
9107     {
9108       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9109       struct value *index_val = value_from_longest (index_type, index);
9110
9111       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9112     }
9113   else
9114     {
9115       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9116       elt = ada_to_fixed_value (elt);
9117     }
9118
9119   ada_aggregate_operation *ag_op
9120     = dynamic_cast<ada_aggregate_operation *> (arg.get ());
9121   if (ag_op != nullptr)
9122     ag_op->assign_aggregate (container, elt, exp);
9123   else
9124     value_assign_to_component (container, elt,
9125                                arg->evaluate (nullptr, exp,
9126                                               EVAL_NORMAL));
9127 }
9128
9129 bool
9130 ada_aggregate_component::uses_objfile (struct objfile *objfile)
9131 {
9132   for (const auto &item : m_components)
9133     if (item->uses_objfile (objfile))
9134       return true;
9135   return false;
9136 }
9137
9138 void
9139 ada_aggregate_component::dump (ui_file *stream, int depth)
9140 {
9141   fprintf_filtered (stream, _("%*sAggregate\n"), depth, "");
9142   for (const auto &item : m_components)
9143     item->dump (stream, depth + 1);
9144 }
9145
9146 void
9147 ada_aggregate_component::assign (struct value *container,
9148                                  struct value *lhs, struct expression *exp,
9149                                  std::vector<LONGEST> &indices,
9150                                  LONGEST low, LONGEST high)
9151 {
9152   for (auto &item : m_components)
9153     item->assign (container, lhs, exp, indices, low, high);
9154 }
9155
9156 /* See ada-exp.h.  */
9157
9158 value *
9159 ada_aggregate_operation::assign_aggregate (struct value *container,
9160                                            struct value *lhs,
9161                                            struct expression *exp)
9162 {
9163   struct type *lhs_type;
9164   LONGEST low_index, high_index;
9165
9166   container = ada_coerce_ref (container);
9167   if (ada_is_direct_array_type (value_type (container)))
9168     container = ada_coerce_to_simple_array (container);
9169   lhs = ada_coerce_ref (lhs);
9170   if (!deprecated_value_modifiable (lhs))
9171     error (_("Left operand of assignment is not a modifiable lvalue."));
9172
9173   lhs_type = check_typedef (value_type (lhs));
9174   if (ada_is_direct_array_type (lhs_type))
9175     {
9176       lhs = ada_coerce_to_simple_array (lhs);
9177       lhs_type = check_typedef (value_type (lhs));
9178       low_index = lhs_type->bounds ()->low.const_val ();
9179       high_index = lhs_type->bounds ()->high.const_val ();
9180     }
9181   else if (lhs_type->code () == TYPE_CODE_STRUCT)
9182     {
9183       low_index = 0;
9184       high_index = num_visible_fields (lhs_type) - 1;
9185     }
9186   else
9187     error (_("Left-hand side must be array or record."));
9188
9189   std::vector<LONGEST> indices (4);
9190   indices[0] = indices[1] = low_index - 1;
9191   indices[2] = indices[3] = high_index + 1;
9192
9193   std::get<0> (m_storage)->assign (container, lhs, exp, indices,
9194                                    low_index, high_index);
9195
9196   return container;
9197 }
9198
9199 bool
9200 ada_positional_component::uses_objfile (struct objfile *objfile)
9201 {
9202   return m_op->uses_objfile (objfile);
9203 }
9204
9205 void
9206 ada_positional_component::dump (ui_file *stream, int depth)
9207 {
9208   fprintf_filtered (stream, _("%*sPositional, index = %d\n"),
9209                     depth, "", m_index);
9210   m_op->dump (stream, depth + 1);
9211 }
9212
9213 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9214    construct, given that the positions are relative to lower bound
9215    LOW, where HIGH is the upper bound.  Record the position in
9216    INDICES.  CONTAINER is as for assign_aggregate.  */
9217 void
9218 ada_positional_component::assign (struct value *container,
9219                                   struct value *lhs, struct expression *exp,
9220                                   std::vector<LONGEST> &indices,
9221                                   LONGEST low, LONGEST high)
9222 {
9223   LONGEST ind = m_index + low;
9224
9225   if (ind - 1 == high)
9226     warning (_("Extra components in aggregate ignored."));
9227   if (ind <= high)
9228     {
9229       add_component_interval (ind, ind, indices);
9230       assign_component (container, lhs, ind, exp, m_op);
9231     }
9232 }
9233
9234 bool
9235 ada_discrete_range_association::uses_objfile (struct objfile *objfile)
9236 {
9237   return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
9238 }
9239
9240 void
9241 ada_discrete_range_association::dump (ui_file *stream, int depth)
9242 {
9243   fprintf_filtered (stream, _("%*sDiscrete range:\n"), depth, "");
9244   m_low->dump (stream, depth + 1);
9245   m_high->dump (stream, depth + 1);
9246 }
9247
9248 void
9249 ada_discrete_range_association::assign (struct value *container,
9250                                         struct value *lhs,
9251                                         struct expression *exp,
9252                                         std::vector<LONGEST> &indices,
9253                                         LONGEST low, LONGEST high,
9254                                         operation_up &op)
9255 {
9256   LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
9257   LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
9258
9259   if (lower <= upper && (lower < low || upper > high))
9260     error (_("Index in component association out of bounds."));
9261
9262   add_component_interval (lower, upper, indices);
9263   while (lower <= upper)
9264     {
9265       assign_component (container, lhs, lower, exp, op);
9266       lower += 1;
9267     }
9268 }
9269
9270 bool
9271 ada_name_association::uses_objfile (struct objfile *objfile)
9272 {
9273   return m_val->uses_objfile (objfile);
9274 }
9275
9276 void
9277 ada_name_association::dump (ui_file *stream, int depth)
9278 {
9279   fprintf_filtered (stream, _("%*sName:\n"), depth, "");
9280   m_val->dump (stream, depth + 1);
9281 }
9282
9283 void
9284 ada_name_association::assign (struct value *container,
9285                               struct value *lhs,
9286                               struct expression *exp,
9287                               std::vector<LONGEST> &indices,
9288                               LONGEST low, LONGEST high,
9289                               operation_up &op)
9290 {
9291   int index;
9292
9293   if (ada_is_direct_array_type (value_type (lhs)))
9294     index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
9295                                                             EVAL_NORMAL)));
9296   else
9297     {
9298       ada_string_operation *strop
9299         = dynamic_cast<ada_string_operation *> (m_val.get ());
9300
9301       const char *name;
9302       if (strop != nullptr)
9303         name = strop->get_name ();
9304       else
9305         {
9306           ada_var_value_operation *vvo
9307             = dynamic_cast<ada_var_value_operation *> (m_val.get ());
9308           if (vvo != nullptr)
9309             error (_("Invalid record component association."));
9310           name = vvo->get_symbol ()->natural_name ();
9311         }
9312
9313       index = 0;
9314       if (! find_struct_field (name, value_type (lhs), 0,
9315                                NULL, NULL, NULL, NULL, &index))
9316         error (_("Unknown component name: %s."), name);
9317     }
9318
9319   add_component_interval (index, index, indices);
9320   assign_component (container, lhs, index, exp, op);
9321 }
9322
9323 bool
9324 ada_choices_component::uses_objfile (struct objfile *objfile)
9325 {
9326   if (m_op->uses_objfile (objfile))
9327     return true;
9328   for (const auto &item : m_assocs)
9329     if (item->uses_objfile (objfile))
9330       return true;
9331   return false;
9332 }
9333
9334 void
9335 ada_choices_component::dump (ui_file *stream, int depth)
9336 {
9337   fprintf_filtered (stream, _("%*sChoices:\n"), depth, "");
9338   m_op->dump (stream, depth + 1);
9339   for (const auto &item : m_assocs)
9340     item->dump (stream, depth + 1);
9341 }
9342
9343 /* Assign into the components of LHS indexed by the OP_CHOICES
9344    construct at *POS, updating *POS past the construct, given that
9345    the allowable indices are LOW..HIGH.  Record the indices assigned
9346    to in INDICES.  CONTAINER is as for assign_aggregate.  */
9347 void
9348 ada_choices_component::assign (struct value *container,
9349                                struct value *lhs, struct expression *exp,
9350                                std::vector<LONGEST> &indices,
9351                                LONGEST low, LONGEST high)
9352 {
9353   for (auto &item : m_assocs)
9354     item->assign (container, lhs, exp, indices, low, high, m_op);
9355 }
9356
9357 bool
9358 ada_others_component::uses_objfile (struct objfile *objfile)
9359 {
9360   return m_op->uses_objfile (objfile);
9361 }
9362
9363 void
9364 ada_others_component::dump (ui_file *stream, int depth)
9365 {
9366   fprintf_filtered (stream, _("%*sOthers:\n"), depth, "");
9367   m_op->dump (stream, depth + 1);
9368 }
9369
9370 /* Assign the value of the expression in the OP_OTHERS construct in
9371    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9372    have not been previously assigned.  The index intervals already assigned
9373    are in INDICES.  CONTAINER is as for assign_aggregate.  */
9374 void
9375 ada_others_component::assign (struct value *container,
9376                               struct value *lhs, struct expression *exp,
9377                               std::vector<LONGEST> &indices,
9378                               LONGEST low, LONGEST high)
9379 {
9380   int num_indices = indices.size ();
9381   for (int i = 0; i < num_indices - 2; i += 2)
9382     {
9383       for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9384         assign_component (container, lhs, ind, exp, m_op);
9385     }
9386 }
9387
9388 struct value *
9389 ada_assign_operation::evaluate (struct type *expect_type,
9390                                 struct expression *exp,
9391                                 enum noside noside)
9392 {
9393   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
9394
9395   ada_aggregate_operation *ag_op
9396     = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
9397   if (ag_op != nullptr)
9398     {
9399       if (noside != EVAL_NORMAL)
9400         return arg1;
9401
9402       arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
9403       return ada_value_assign (arg1, arg1);
9404     }
9405   /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9406      except if the lhs of our assignment is a convenience variable.
9407      In the case of assigning to a convenience variable, the lhs
9408      should be exactly the result of the evaluation of the rhs.  */
9409   struct type *type = value_type (arg1);
9410   if (VALUE_LVAL (arg1) == lval_internalvar)
9411     type = NULL;
9412   value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
9413   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9414     return arg1;
9415   if (VALUE_LVAL (arg1) == lval_internalvar)
9416     {
9417       /* Nothing.  */
9418     }
9419   else
9420     arg2 = coerce_for_assign (value_type (arg1), arg2);
9421   return ada_value_assign (arg1, arg2);
9422 }
9423
9424 } /* namespace expr */
9425
9426 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9427    [ INDICES[0] .. INDICES[1] ],...  The resulting intervals do not
9428    overlap.  */
9429 static void
9430 add_component_interval (LONGEST low, LONGEST high, 
9431                         std::vector<LONGEST> &indices)
9432 {
9433   int i, j;
9434
9435   int size = indices.size ();
9436   for (i = 0; i < size; i += 2) {
9437     if (high >= indices[i] && low <= indices[i + 1])
9438       {
9439         int kh;
9440
9441         for (kh = i + 2; kh < size; kh += 2)
9442           if (high < indices[kh])
9443             break;
9444         if (low < indices[i])
9445           indices[i] = low;
9446         indices[i + 1] = indices[kh - 1];
9447         if (high > indices[i + 1])
9448           indices[i + 1] = high;
9449         memcpy (indices.data () + i + 2, indices.data () + kh, size - kh);
9450         indices.resize (kh - i - 2);
9451         return;
9452       }
9453     else if (high < indices[i])
9454       break;
9455   }
9456         
9457   indices.resize (indices.size () + 2);
9458   for (j = indices.size () - 1; j >= i + 2; j -= 1)
9459     indices[j] = indices[j - 2];
9460   indices[i] = low;
9461   indices[i + 1] = high;
9462 }
9463
9464 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9465    is different.  */
9466
9467 static struct value *
9468 ada_value_cast (struct type *type, struct value *arg2)
9469 {
9470   if (type == ada_check_typedef (value_type (arg2)))
9471     return arg2;
9472
9473   return value_cast (type, arg2);
9474 }
9475
9476 /*  Evaluating Ada expressions, and printing their result.
9477     ------------------------------------------------------
9478
9479     1. Introduction:
9480     ----------------
9481
9482     We usually evaluate an Ada expression in order to print its value.
9483     We also evaluate an expression in order to print its type, which
9484     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9485     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
9486     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9487     the evaluation compared to the EVAL_NORMAL, but is otherwise very
9488     similar.
9489
9490     Evaluating expressions is a little more complicated for Ada entities
9491     than it is for entities in languages such as C.  The main reason for
9492     this is that Ada provides types whose definition might be dynamic.
9493     One example of such types is variant records.  Or another example
9494     would be an array whose bounds can only be known at run time.
9495
9496     The following description is a general guide as to what should be
9497     done (and what should NOT be done) in order to evaluate an expression
9498     involving such types, and when.  This does not cover how the semantic
9499     information is encoded by GNAT as this is covered separatly.  For the
9500     document used as the reference for the GNAT encoding, see exp_dbug.ads
9501     in the GNAT sources.
9502
9503     Ideally, we should embed each part of this description next to its
9504     associated code.  Unfortunately, the amount of code is so vast right
9505     now that it's hard to see whether the code handling a particular
9506     situation might be duplicated or not.  One day, when the code is
9507     cleaned up, this guide might become redundant with the comments
9508     inserted in the code, and we might want to remove it.
9509
9510     2. ``Fixing'' an Entity, the Simple Case:
9511     -----------------------------------------
9512
9513     When evaluating Ada expressions, the tricky issue is that they may
9514     reference entities whose type contents and size are not statically
9515     known.  Consider for instance a variant record:
9516
9517        type Rec (Empty : Boolean := True) is record
9518           case Empty is
9519              when True => null;
9520              when False => Value : Integer;
9521           end case;
9522        end record;
9523        Yes : Rec := (Empty => False, Value => 1);
9524        No  : Rec := (empty => True);
9525
9526     The size and contents of that record depends on the value of the
9527     descriminant (Rec.Empty).  At this point, neither the debugging
9528     information nor the associated type structure in GDB are able to
9529     express such dynamic types.  So what the debugger does is to create
9530     "fixed" versions of the type that applies to the specific object.
9531     We also informally refer to this operation as "fixing" an object,
9532     which means creating its associated fixed type.
9533
9534     Example: when printing the value of variable "Yes" above, its fixed
9535     type would look like this:
9536
9537        type Rec is record
9538           Empty : Boolean;
9539           Value : Integer;
9540        end record;
9541
9542     On the other hand, if we printed the value of "No", its fixed type
9543     would become:
9544
9545        type Rec is record
9546           Empty : Boolean;
9547        end record;
9548
9549     Things become a little more complicated when trying to fix an entity
9550     with a dynamic type that directly contains another dynamic type,
9551     such as an array of variant records, for instance.  There are
9552     two possible cases: Arrays, and records.
9553
9554     3. ``Fixing'' Arrays:
9555     ---------------------
9556
9557     The type structure in GDB describes an array in terms of its bounds,
9558     and the type of its elements.  By design, all elements in the array
9559     have the same type and we cannot represent an array of variant elements
9560     using the current type structure in GDB.  When fixing an array,
9561     we cannot fix the array element, as we would potentially need one
9562     fixed type per element of the array.  As a result, the best we can do
9563     when fixing an array is to produce an array whose bounds and size
9564     are correct (allowing us to read it from memory), but without having
9565     touched its element type.  Fixing each element will be done later,
9566     when (if) necessary.
9567
9568     Arrays are a little simpler to handle than records, because the same
9569     amount of memory is allocated for each element of the array, even if
9570     the amount of space actually used by each element differs from element
9571     to element.  Consider for instance the following array of type Rec:
9572
9573        type Rec_Array is array (1 .. 2) of Rec;
9574
9575     The actual amount of memory occupied by each element might be different
9576     from element to element, depending on the value of their discriminant.
9577     But the amount of space reserved for each element in the array remains
9578     fixed regardless.  So we simply need to compute that size using
9579     the debugging information available, from which we can then determine
9580     the array size (we multiply the number of elements of the array by
9581     the size of each element).
9582
9583     The simplest case is when we have an array of a constrained element
9584     type. For instance, consider the following type declarations:
9585
9586         type Bounded_String (Max_Size : Integer) is
9587            Length : Integer;
9588            Buffer : String (1 .. Max_Size);
9589         end record;
9590         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9591
9592     In this case, the compiler describes the array as an array of
9593     variable-size elements (identified by its XVS suffix) for which
9594     the size can be read in the parallel XVZ variable.
9595
9596     In the case of an array of an unconstrained element type, the compiler
9597     wraps the array element inside a private PAD type.  This type should not
9598     be shown to the user, and must be "unwrap"'ed before printing.  Note
9599     that we also use the adjective "aligner" in our code to designate
9600     these wrapper types.
9601
9602     In some cases, the size allocated for each element is statically
9603     known.  In that case, the PAD type already has the correct size,
9604     and the array element should remain unfixed.
9605
9606     But there are cases when this size is not statically known.
9607     For instance, assuming that "Five" is an integer variable:
9608
9609         type Dynamic is array (1 .. Five) of Integer;
9610         type Wrapper (Has_Length : Boolean := False) is record
9611            Data : Dynamic;
9612            case Has_Length is
9613               when True => Length : Integer;
9614               when False => null;
9615            end case;
9616         end record;
9617         type Wrapper_Array is array (1 .. 2) of Wrapper;
9618
9619         Hello : Wrapper_Array := (others => (Has_Length => True,
9620                                              Data => (others => 17),
9621                                              Length => 1));
9622
9623
9624     The debugging info would describe variable Hello as being an
9625     array of a PAD type.  The size of that PAD type is not statically
9626     known, but can be determined using a parallel XVZ variable.
9627     In that case, a copy of the PAD type with the correct size should
9628     be used for the fixed array.
9629
9630     3. ``Fixing'' record type objects:
9631     ----------------------------------
9632
9633     Things are slightly different from arrays in the case of dynamic
9634     record types.  In this case, in order to compute the associated
9635     fixed type, we need to determine the size and offset of each of
9636     its components.  This, in turn, requires us to compute the fixed
9637     type of each of these components.
9638
9639     Consider for instance the example:
9640
9641         type Bounded_String (Max_Size : Natural) is record
9642            Str : String (1 .. Max_Size);
9643            Length : Natural;
9644         end record;
9645         My_String : Bounded_String (Max_Size => 10);
9646
9647     In that case, the position of field "Length" depends on the size
9648     of field Str, which itself depends on the value of the Max_Size
9649     discriminant.  In order to fix the type of variable My_String,
9650     we need to fix the type of field Str.  Therefore, fixing a variant
9651     record requires us to fix each of its components.
9652
9653     However, if a component does not have a dynamic size, the component
9654     should not be fixed.  In particular, fields that use a PAD type
9655     should not fixed.  Here is an example where this might happen
9656     (assuming type Rec above):
9657
9658        type Container (Big : Boolean) is record
9659           First : Rec;
9660           After : Integer;
9661           case Big is
9662              when True => Another : Integer;
9663              when False => null;
9664           end case;
9665        end record;
9666        My_Container : Container := (Big => False,
9667                                     First => (Empty => True),
9668                                     After => 42);
9669
9670     In that example, the compiler creates a PAD type for component First,
9671     whose size is constant, and then positions the component After just
9672     right after it.  The offset of component After is therefore constant
9673     in this case.
9674
9675     The debugger computes the position of each field based on an algorithm
9676     that uses, among other things, the actual position and size of the field
9677     preceding it.  Let's now imagine that the user is trying to print
9678     the value of My_Container.  If the type fixing was recursive, we would
9679     end up computing the offset of field After based on the size of the
9680     fixed version of field First.  And since in our example First has
9681     only one actual field, the size of the fixed type is actually smaller
9682     than the amount of space allocated to that field, and thus we would
9683     compute the wrong offset of field After.
9684
9685     To make things more complicated, we need to watch out for dynamic
9686     components of variant records (identified by the ___XVL suffix in
9687     the component name).  Even if the target type is a PAD type, the size
9688     of that type might not be statically known.  So the PAD type needs
9689     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
9690     we might end up with the wrong size for our component.  This can be
9691     observed with the following type declarations:
9692
9693         type Octal is new Integer range 0 .. 7;
9694         type Octal_Array is array (Positive range <>) of Octal;
9695         pragma Pack (Octal_Array);
9696
9697         type Octal_Buffer (Size : Positive) is record
9698            Buffer : Octal_Array (1 .. Size);
9699            Length : Integer;
9700         end record;
9701
9702     In that case, Buffer is a PAD type whose size is unset and needs
9703     to be computed by fixing the unwrapped type.
9704
9705     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9706     ----------------------------------------------------------
9707
9708     Lastly, when should the sub-elements of an entity that remained unfixed
9709     thus far, be actually fixed?
9710
9711     The answer is: Only when referencing that element.  For instance
9712     when selecting one component of a record, this specific component
9713     should be fixed at that point in time.  Or when printing the value
9714     of a record, each component should be fixed before its value gets
9715     printed.  Similarly for arrays, the element of the array should be
9716     fixed when printing each element of the array, or when extracting
9717     one element out of that array.  On the other hand, fixing should
9718     not be performed on the elements when taking a slice of an array!
9719
9720     Note that one of the side effects of miscomputing the offset and
9721     size of each field is that we end up also miscomputing the size
9722     of the containing type.  This can have adverse results when computing
9723     the value of an entity.  GDB fetches the value of an entity based
9724     on the size of its type, and thus a wrong size causes GDB to fetch
9725     the wrong amount of memory.  In the case where the computed size is
9726     too small, GDB fetches too little data to print the value of our
9727     entity.  Results in this case are unpredictable, as we usually read
9728     past the buffer containing the data =:-o.  */
9729
9730 /* A helper function for TERNOP_IN_RANGE.  */
9731
9732 static value *
9733 eval_ternop_in_range (struct type *expect_type, struct expression *exp,
9734                       enum noside noside,
9735                       value *arg1, value *arg2, value *arg3)
9736 {
9737   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9738   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9739   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
9740   return
9741     value_from_longest (type,
9742                         (value_less (arg1, arg3)
9743                          || value_equal (arg1, arg3))
9744                         && (value_less (arg2, arg1)
9745                             || value_equal (arg2, arg1)));
9746 }
9747
9748 /* A helper function for UNOP_NEG.  */
9749
9750 value *
9751 ada_unop_neg (struct type *expect_type,
9752               struct expression *exp,
9753               enum noside noside, enum exp_opcode op,
9754               struct value *arg1)
9755 {
9756   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9757   return value_neg (arg1);
9758 }
9759
9760 /* A helper function for UNOP_IN_RANGE.  */
9761
9762 value *
9763 ada_unop_in_range (struct type *expect_type,
9764                    struct expression *exp,
9765                    enum noside noside, enum exp_opcode op,
9766                    struct value *arg1, struct type *type)
9767 {
9768   struct value *arg2, *arg3;
9769   switch (type->code ())
9770     {
9771     default:
9772       lim_warning (_("Membership test incompletely implemented; "
9773                      "always returns true"));
9774       type = language_bool_type (exp->language_defn, exp->gdbarch);
9775       return value_from_longest (type, (LONGEST) 1);
9776
9777     case TYPE_CODE_RANGE:
9778       arg2 = value_from_longest (type,
9779                                  type->bounds ()->low.const_val ());
9780       arg3 = value_from_longest (type,
9781                                  type->bounds ()->high.const_val ());
9782       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9783       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9784       type = language_bool_type (exp->language_defn, exp->gdbarch);
9785       return
9786         value_from_longest (type,
9787                             (value_less (arg1, arg3)
9788                              || value_equal (arg1, arg3))
9789                             && (value_less (arg2, arg1)
9790                                 || value_equal (arg2, arg1)));
9791     }
9792 }
9793
9794 /* A helper function for OP_ATR_TAG.  */
9795
9796 value *
9797 ada_atr_tag (struct type *expect_type,
9798              struct expression *exp,
9799              enum noside noside, enum exp_opcode op,
9800              struct value *arg1)
9801 {
9802   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9803     return value_zero (ada_tag_type (arg1), not_lval);
9804
9805   return ada_value_tag (arg1);
9806 }
9807
9808 /* A helper function for OP_ATR_SIZE.  */
9809
9810 value *
9811 ada_atr_size (struct type *expect_type,
9812               struct expression *exp,
9813               enum noside noside, enum exp_opcode op,
9814               struct value *arg1)
9815 {
9816   struct type *type = value_type (arg1);
9817
9818   /* If the argument is a reference, then dereference its type, since
9819      the user is really asking for the size of the actual object,
9820      not the size of the pointer.  */
9821   if (type->code () == TYPE_CODE_REF)
9822     type = TYPE_TARGET_TYPE (type);
9823
9824   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9825     return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
9826   else
9827     return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
9828                                TARGET_CHAR_BIT * TYPE_LENGTH (type));
9829 }
9830
9831 /* A helper function for UNOP_ABS.  */
9832
9833 value *
9834 ada_abs (struct type *expect_type,
9835          struct expression *exp,
9836          enum noside noside, enum exp_opcode op,
9837          struct value *arg1)
9838 {
9839   unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9840   if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
9841     return value_neg (arg1);
9842   else
9843     return arg1;
9844 }
9845
9846 /* A helper function for BINOP_MUL.  */
9847
9848 value *
9849 ada_mult_binop (struct type *expect_type,
9850                 struct expression *exp,
9851                 enum noside noside, enum exp_opcode op,
9852                 struct value *arg1, struct value *arg2)
9853 {
9854   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9855     {
9856       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9857       return value_zero (value_type (arg1), not_lval);
9858     }
9859   else
9860     {
9861       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9862       return ada_value_binop (arg1, arg2, op);
9863     }
9864 }
9865
9866 /* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL.  */
9867
9868 value *
9869 ada_equal_binop (struct type *expect_type,
9870                  struct expression *exp,
9871                  enum noside noside, enum exp_opcode op,
9872                  struct value *arg1, struct value *arg2)
9873 {
9874   int tem;
9875   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9876     tem = 0;
9877   else
9878     {
9879       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9880       tem = ada_value_equal (arg1, arg2);
9881     }
9882   if (op == BINOP_NOTEQUAL)
9883     tem = !tem;
9884   struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
9885   return value_from_longest (type, (LONGEST) tem);
9886 }
9887
9888 /* A helper function for TERNOP_SLICE.  */
9889
9890 value *
9891 ada_ternop_slice (struct expression *exp,
9892                   enum noside noside,
9893                   struct value *array, struct value *low_bound_val,
9894                   struct value *high_bound_val)
9895 {
9896   LONGEST low_bound;
9897   LONGEST high_bound;
9898
9899   low_bound_val = coerce_ref (low_bound_val);
9900   high_bound_val = coerce_ref (high_bound_val);
9901   low_bound = value_as_long (low_bound_val);
9902   high_bound = value_as_long (high_bound_val);
9903
9904   /* If this is a reference to an aligner type, then remove all
9905      the aligners.  */
9906   if (value_type (array)->code () == TYPE_CODE_REF
9907       && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
9908     TYPE_TARGET_TYPE (value_type (array)) =
9909       ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
9910
9911   if (ada_is_any_packed_array_type (value_type (array)))
9912     error (_("cannot slice a packed array"));
9913
9914   /* If this is a reference to an array or an array lvalue,
9915      convert to a pointer.  */
9916   if (value_type (array)->code () == TYPE_CODE_REF
9917       || (value_type (array)->code () == TYPE_CODE_ARRAY
9918           && VALUE_LVAL (array) == lval_memory))
9919     array = value_addr (array);
9920
9921   if (noside == EVAL_AVOID_SIDE_EFFECTS
9922       && ada_is_array_descriptor_type (ada_check_typedef
9923                                        (value_type (array))))
9924     return empty_array (ada_type_of_array (array, 0), low_bound,
9925                         high_bound);
9926
9927   array = ada_coerce_to_simple_array_ptr (array);
9928
9929   /* If we have more than one level of pointer indirection,
9930      dereference the value until we get only one level.  */
9931   while (value_type (array)->code () == TYPE_CODE_PTR
9932          && (TYPE_TARGET_TYPE (value_type (array))->code ()
9933              == TYPE_CODE_PTR))
9934     array = value_ind (array);
9935
9936   /* Make sure we really do have an array type before going further,
9937      to avoid a SEGV when trying to get the index type or the target
9938      type later down the road if the debug info generated by
9939      the compiler is incorrect or incomplete.  */
9940   if (!ada_is_simple_array_type (value_type (array)))
9941     error (_("cannot take slice of non-array"));
9942
9943   if (ada_check_typedef (value_type (array))->code ()
9944       == TYPE_CODE_PTR)
9945     {
9946       struct type *type0 = ada_check_typedef (value_type (array));
9947
9948       if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
9949         return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
9950       else
9951         {
9952           struct type *arr_type0 =
9953             to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
9954
9955           return ada_value_slice_from_ptr (array, arr_type0,
9956                                            longest_to_int (low_bound),
9957                                            longest_to_int (high_bound));
9958         }
9959     }
9960   else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9961     return array;
9962   else if (high_bound < low_bound)
9963     return empty_array (value_type (array), low_bound, high_bound);
9964   else
9965     return ada_value_slice (array, longest_to_int (low_bound),
9966                             longest_to_int (high_bound));
9967 }
9968
9969 /* A helper function for BINOP_IN_BOUNDS.  */
9970
9971 value *
9972 ada_binop_in_bounds (struct expression *exp, enum noside noside,
9973                      struct value *arg1, struct value *arg2, int n)
9974 {
9975   if (noside == EVAL_AVOID_SIDE_EFFECTS)
9976     {
9977       struct type *type = language_bool_type (exp->language_defn,
9978                                               exp->gdbarch);
9979       return value_zero (type, not_lval);
9980     }
9981
9982   struct type *type = ada_index_type (value_type (arg2), n, "range");
9983   if (!type)
9984     type = value_type (arg1);
9985
9986   value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
9987   arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
9988
9989   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9990   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9991   type = language_bool_type (exp->language_defn, exp->gdbarch);
9992   return value_from_longest (type,
9993                              (value_less (arg1, arg3)
9994                               || value_equal (arg1, arg3))
9995                              && (value_less (arg2, arg1)
9996                                  || value_equal (arg2, arg1)));
9997 }
9998
9999 /* A helper function for some attribute operations.  */
10000
10001 static value *
10002 ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
10003               struct value *arg1, struct type *type_arg, int tem)
10004 {
10005   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10006     {
10007       if (type_arg == NULL)
10008         type_arg = value_type (arg1);
10009
10010       if (ada_is_constrained_packed_array_type (type_arg))
10011         type_arg = decode_constrained_packed_array_type (type_arg);
10012
10013       if (!discrete_type_p (type_arg))
10014         {
10015           switch (op)
10016             {
10017             default:          /* Should never happen.  */
10018               error (_("unexpected attribute encountered"));
10019             case OP_ATR_FIRST:
10020             case OP_ATR_LAST:
10021               type_arg = ada_index_type (type_arg, tem,
10022                                          ada_attribute_name (op));
10023               break;
10024             case OP_ATR_LENGTH:
10025               type_arg = builtin_type (exp->gdbarch)->builtin_int;
10026               break;
10027             }
10028         }
10029
10030       return value_zero (type_arg, not_lval);
10031     }
10032   else if (type_arg == NULL)
10033     {
10034       arg1 = ada_coerce_ref (arg1);
10035
10036       if (ada_is_constrained_packed_array_type (value_type (arg1)))
10037         arg1 = ada_coerce_to_simple_array (arg1);
10038
10039       struct type *type;
10040       if (op == OP_ATR_LENGTH)
10041         type = builtin_type (exp->gdbarch)->builtin_int;
10042       else
10043         {
10044           type = ada_index_type (value_type (arg1), tem,
10045                                  ada_attribute_name (op));
10046           if (type == NULL)
10047             type = builtin_type (exp->gdbarch)->builtin_int;
10048         }
10049
10050       switch (op)
10051         {
10052         default:          /* Should never happen.  */
10053           error (_("unexpected attribute encountered"));
10054         case OP_ATR_FIRST:
10055           return value_from_longest
10056             (type, ada_array_bound (arg1, tem, 0));
10057         case OP_ATR_LAST:
10058           return value_from_longest
10059             (type, ada_array_bound (arg1, tem, 1));
10060         case OP_ATR_LENGTH:
10061           return value_from_longest
10062             (type, ada_array_length (arg1, tem));
10063         }
10064     }
10065   else if (discrete_type_p (type_arg))
10066     {
10067       struct type *range_type;
10068       const char *name = ada_type_name (type_arg);
10069
10070       range_type = NULL;
10071       if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
10072         range_type = to_fixed_range_type (type_arg, NULL);
10073       if (range_type == NULL)
10074         range_type = type_arg;
10075       switch (op)
10076         {
10077         default:
10078           error (_("unexpected attribute encountered"));
10079         case OP_ATR_FIRST:
10080           return value_from_longest 
10081             (range_type, ada_discrete_type_low_bound (range_type));
10082         case OP_ATR_LAST:
10083           return value_from_longest
10084             (range_type, ada_discrete_type_high_bound (range_type));
10085         case OP_ATR_LENGTH:
10086           error (_("the 'length attribute applies only to array types"));
10087         }
10088     }
10089   else if (type_arg->code () == TYPE_CODE_FLT)
10090     error (_("unimplemented type attribute"));
10091   else
10092     {
10093       LONGEST low, high;
10094
10095       if (ada_is_constrained_packed_array_type (type_arg))
10096         type_arg = decode_constrained_packed_array_type (type_arg);
10097
10098       struct type *type;
10099       if (op == OP_ATR_LENGTH)
10100         type = builtin_type (exp->gdbarch)->builtin_int;
10101       else
10102         {
10103           type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10104           if (type == NULL)
10105             type = builtin_type (exp->gdbarch)->builtin_int;
10106         }
10107
10108       switch (op)
10109         {
10110         default:
10111           error (_("unexpected attribute encountered"));
10112         case OP_ATR_FIRST:
10113           low = ada_array_bound_from_type (type_arg, tem, 0);
10114           return value_from_longest (type, low);
10115         case OP_ATR_LAST:
10116           high = ada_array_bound_from_type (type_arg, tem, 1);
10117           return value_from_longest (type, high);
10118         case OP_ATR_LENGTH:
10119           low = ada_array_bound_from_type (type_arg, tem, 0);
10120           high = ada_array_bound_from_type (type_arg, tem, 1);
10121           return value_from_longest (type, high - low + 1);
10122         }
10123     }
10124 }
10125
10126 /* A helper function for OP_ATR_MIN and OP_ATR_MAX.  */
10127
10128 struct value *
10129 ada_binop_minmax (struct type *expect_type,
10130                   struct expression *exp,
10131                   enum noside noside, enum exp_opcode op,
10132                   struct value *arg1, struct value *arg2)
10133 {
10134   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10135     return value_zero (value_type (arg1), not_lval);
10136   else
10137     {
10138       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10139       return value_binop (arg1, arg2, op);
10140     }
10141 }
10142
10143 /* A helper function for BINOP_EXP.  */
10144
10145 struct value *
10146 ada_binop_exp (struct type *expect_type,
10147                struct expression *exp,
10148                enum noside noside, enum exp_opcode op,
10149                struct value *arg1, struct value *arg2)
10150 {
10151   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10152     return value_zero (value_type (arg1), not_lval);
10153   else
10154     {
10155       /* For integer exponentiation operations,
10156          only promote the first argument.  */
10157       if (is_integral_type (value_type (arg2)))
10158         unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10159       else
10160         binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10161
10162       return value_binop (arg1, arg2, op);
10163     }
10164 }
10165
10166 namespace expr
10167 {
10168
10169 /* See ada-exp.h.  */
10170
10171 operation_up
10172 ada_resolvable::replace (operation_up &&owner,
10173                          struct expression *exp,
10174                          bool deprocedure_p,
10175                          bool parse_completion,
10176                          innermost_block_tracker *tracker,
10177                          struct type *context_type)
10178 {
10179   if (resolve (exp, deprocedure_p, parse_completion, tracker, context_type))
10180     return (make_operation<ada_funcall_operation>
10181             (std::move (owner),
10182              std::vector<operation_up> ()));
10183   return std::move (owner);
10184 }
10185
10186 /* Convert the character literal whose ASCII value would be VAL to the
10187    appropriate value of type TYPE, if there is a translation.
10188    Otherwise return VAL.  Hence, in an enumeration type ('A', 'B'),
10189    the literal 'A' (VAL == 65), returns 0.  */
10190
10191 static LONGEST
10192 convert_char_literal (struct type *type, LONGEST val)
10193 {
10194   char name[7];
10195   int f;
10196
10197   if (type == NULL)
10198     return val;
10199   type = check_typedef (type);
10200   if (type->code () != TYPE_CODE_ENUM)
10201     return val;
10202
10203   if ((val >= 'a' && val <= 'z') || (val >= '0' && val <= '9'))
10204     xsnprintf (name, sizeof (name), "Q%c", (int) val);
10205   else
10206     xsnprintf (name, sizeof (name), "QU%02x", (int) val);
10207   size_t len = strlen (name);
10208   for (f = 0; f < type->num_fields (); f += 1)
10209     {
10210       /* Check the suffix because an enum constant in a package will
10211          have a name like "pkg__QUxx".  This is safe enough because we
10212          already have the correct type, and because mangling means
10213          there can't be clashes.  */
10214       const char *ename = type->field (f).name ();
10215       size_t elen = strlen (ename);
10216
10217       if (elen >= len && strcmp (name, ename + elen - len) == 0)
10218         return TYPE_FIELD_ENUMVAL (type, f);
10219     }
10220   return val;
10221 }
10222
10223 /* See ada-exp.h.  */
10224
10225 operation_up
10226 ada_char_operation::replace (operation_up &&owner,
10227                              struct expression *exp,
10228                              bool deprocedure_p,
10229                              bool parse_completion,
10230                              innermost_block_tracker *tracker,
10231                              struct type *context_type)
10232 {
10233   operation_up result = std::move (owner);
10234
10235   if (context_type != nullptr && context_type->code () == TYPE_CODE_ENUM)
10236     {
10237       gdb_assert (result.get () == this);
10238       std::get<0> (m_storage) = context_type;
10239       std::get<1> (m_storage)
10240         = convert_char_literal (context_type, std::get<1> (m_storage));
10241     }
10242
10243   return make_operation<ada_wrapped_operation> (std::move (result));
10244 }
10245
10246 value *
10247 ada_wrapped_operation::evaluate (struct type *expect_type,
10248                                  struct expression *exp,
10249                                  enum noside noside)
10250 {
10251   value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10252   if (noside == EVAL_NORMAL)
10253     result = unwrap_value (result);
10254
10255   /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10256      then we need to perform the conversion manually, because
10257      evaluate_subexp_standard doesn't do it.  This conversion is
10258      necessary in Ada because the different kinds of float/fixed
10259      types in Ada have different representations.
10260
10261      Similarly, we need to perform the conversion from OP_LONG
10262      ourselves.  */
10263   if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
10264     result = ada_value_cast (expect_type, result);
10265
10266   return result;
10267 }
10268
10269 value *
10270 ada_string_operation::evaluate (struct type *expect_type,
10271                                 struct expression *exp,
10272                                 enum noside noside)
10273 {
10274   value *result = string_operation::evaluate (expect_type, exp, noside);
10275   /* The result type will have code OP_STRING, bashed there from 
10276      OP_ARRAY.  Bash it back.  */
10277   if (value_type (result)->code () == TYPE_CODE_STRING)
10278     value_type (result)->set_code (TYPE_CODE_ARRAY);
10279   return result;
10280 }
10281
10282 value *
10283 ada_qual_operation::evaluate (struct type *expect_type,
10284                               struct expression *exp,
10285                               enum noside noside)
10286 {
10287   struct type *type = std::get<1> (m_storage);
10288   return std::get<0> (m_storage)->evaluate (type, exp, noside);
10289 }
10290
10291 value *
10292 ada_ternop_range_operation::evaluate (struct type *expect_type,
10293                                       struct expression *exp,
10294                                       enum noside noside)
10295 {
10296   value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10297   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10298   value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
10299   return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
10300 }
10301
10302 value *
10303 ada_binop_addsub_operation::evaluate (struct type *expect_type,
10304                                       struct expression *exp,
10305                                       enum noside noside)
10306 {
10307   value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
10308   value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
10309
10310   auto do_op = [=] (LONGEST x, LONGEST y)
10311     {
10312       if (std::get<0> (m_storage) == BINOP_ADD)
10313         return x + y;
10314       return x - y;
10315     };
10316
10317   if (value_type (arg1)->code () == TYPE_CODE_PTR)
10318     return (value_from_longest
10319             (value_type (arg1),
10320              do_op (value_as_long (arg1), value_as_long (arg2))));
10321   if (value_type (arg2)->code () == TYPE_CODE_PTR)
10322     return (value_from_longest
10323             (value_type (arg2),
10324              do_op (value_as_long (arg1), value_as_long (arg2))));
10325   /* Preserve the original type for use by the range case below.
10326      We cannot cast the result to a reference type, so if ARG1 is
10327      a reference type, find its underlying type.  */
10328   struct type *type = value_type (arg1);
10329   while (type->code () == TYPE_CODE_REF)
10330     type = TYPE_TARGET_TYPE (type);
10331   binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10332   arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
10333   /* We need to special-case the result with a range.
10334      This is done for the benefit of "ptype".  gdb's Ada support
10335      historically used the LHS to set the result type here, so
10336      preserve this behavior.  */
10337   if (type->code () == TYPE_CODE_RANGE)
10338     arg1 = value_cast (type, arg1);
10339   return arg1;
10340 }
10341
10342 value *
10343 ada_unop_atr_operation::evaluate (struct type *expect_type,
10344                                   struct expression *exp,
10345                                   enum noside noside)
10346 {
10347   struct type *type_arg = nullptr;
10348   value *val = nullptr;
10349
10350   if (std::get<0> (m_storage)->opcode () == OP_TYPE)
10351     {
10352       value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
10353                                                       EVAL_AVOID_SIDE_EFFECTS);
10354       type_arg = value_type (tem);
10355     }
10356   else
10357     val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10358
10359   return ada_unop_atr (exp, noside, std::get<1> (m_storage),
10360                        val, type_arg, std::get<2> (m_storage));
10361 }
10362
10363 value *
10364 ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
10365                                                  struct expression *exp,
10366                                                  enum noside noside)
10367 {
10368   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10369     return value_zero (expect_type, not_lval);
10370
10371   const bound_minimal_symbol &b = std::get<0> (m_storage);
10372   value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
10373
10374   val = ada_value_cast (expect_type, val);
10375
10376   /* Follow the Ada language semantics that do not allow taking
10377      an address of the result of a cast (view conversion in Ada).  */
10378   if (VALUE_LVAL (val) == lval_memory)
10379     {
10380       if (value_lazy (val))
10381         value_fetch_lazy (val);
10382       VALUE_LVAL (val) = not_lval;
10383     }
10384   return val;
10385 }
10386
10387 value *
10388 ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
10389                                             struct expression *exp,
10390                                             enum noside noside)
10391 {
10392   value *val = evaluate_var_value (noside,
10393                                    std::get<0> (m_storage).block,
10394                                    std::get<0> (m_storage).symbol);
10395
10396   val = ada_value_cast (expect_type, val);
10397
10398   /* Follow the Ada language semantics that do not allow taking
10399      an address of the result of a cast (view conversion in Ada).  */
10400   if (VALUE_LVAL (val) == lval_memory)
10401     {
10402       if (value_lazy (val))
10403         value_fetch_lazy (val);
10404       VALUE_LVAL (val) = not_lval;
10405     }
10406   return val;
10407 }
10408
10409 value *
10410 ada_var_value_operation::evaluate (struct type *expect_type,
10411                                    struct expression *exp,
10412                                    enum noside noside)
10413 {
10414   symbol *sym = std::get<0> (m_storage).symbol;
10415
10416   if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
10417     /* Only encountered when an unresolved symbol occurs in a
10418        context other than a function call, in which case, it is
10419        invalid.  */
10420     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10421            sym->print_name ());
10422
10423   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10424     {
10425       struct type *type = static_unwrap_type (SYMBOL_TYPE (sym));
10426       /* Check to see if this is a tagged type.  We also need to handle
10427          the case where the type is a reference to a tagged type, but
10428          we have to be careful to exclude pointers to tagged types.
10429          The latter should be shown as usual (as a pointer), whereas
10430          a reference should mostly be transparent to the user.  */
10431       if (ada_is_tagged_type (type, 0)
10432           || (type->code () == TYPE_CODE_REF
10433               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10434         {
10435           /* Tagged types are a little special in the fact that the real
10436              type is dynamic and can only be determined by inspecting the
10437              object's tag.  This means that we need to get the object's
10438              value first (EVAL_NORMAL) and then extract the actual object
10439              type from its tag.
10440
10441              Note that we cannot skip the final step where we extract
10442              the object type from its tag, because the EVAL_NORMAL phase
10443              results in dynamic components being resolved into fixed ones.
10444              This can cause problems when trying to print the type
10445              description of tagged types whose parent has a dynamic size:
10446              We use the type name of the "_parent" component in order
10447              to print the name of the ancestor type in the type description.
10448              If that component had a dynamic size, the resolution into
10449              a fixed type would result in the loss of that type name,
10450              thus preventing us from printing the name of the ancestor
10451              type in the type description.  */
10452           value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
10453
10454           if (type->code () != TYPE_CODE_REF)
10455             {
10456               struct type *actual_type;
10457
10458               actual_type = type_from_tag (ada_value_tag (arg1));
10459               if (actual_type == NULL)
10460                 /* If, for some reason, we were unable to determine
10461                    the actual type from the tag, then use the static
10462                    approximation that we just computed as a fallback.
10463                    This can happen if the debugging information is
10464                    incomplete, for instance.  */
10465                 actual_type = type;
10466               return value_zero (actual_type, not_lval);
10467             }
10468           else
10469             {
10470               /* In the case of a ref, ada_coerce_ref takes care
10471                  of determining the actual type.  But the evaluation
10472                  should return a ref as it should be valid to ask
10473                  for its address; so rebuild a ref after coerce.  */
10474               arg1 = ada_coerce_ref (arg1);
10475               return value_ref (arg1, TYPE_CODE_REF);
10476             }
10477         }
10478
10479       /* Records and unions for which GNAT encodings have been
10480          generated need to be statically fixed as well.
10481          Otherwise, non-static fixing produces a type where
10482          all dynamic properties are removed, which prevents "ptype"
10483          from being able to completely describe the type.
10484          For instance, a case statement in a variant record would be
10485          replaced by the relevant components based on the actual
10486          value of the discriminants.  */
10487       if ((type->code () == TYPE_CODE_STRUCT
10488            && dynamic_template_type (type) != NULL)
10489           || (type->code () == TYPE_CODE_UNION
10490               && ada_find_parallel_type (type, "___XVU") != NULL))
10491         return value_zero (to_static_fixed_type (type), not_lval);
10492     }
10493
10494   value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
10495   return ada_to_fixed_value (arg1);
10496 }
10497
10498 bool
10499 ada_var_value_operation::resolve (struct expression *exp,
10500                                   bool deprocedure_p,
10501                                   bool parse_completion,
10502                                   innermost_block_tracker *tracker,
10503                                   struct type *context_type)
10504 {
10505   symbol *sym = std::get<0> (m_storage).symbol;
10506   if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
10507     {
10508       block_symbol resolved
10509         = ada_resolve_variable (sym, std::get<0> (m_storage).block,
10510                                 context_type, parse_completion,
10511                                 deprocedure_p, tracker);
10512       std::get<0> (m_storage) = resolved;
10513     }
10514
10515   if (deprocedure_p
10516       && (SYMBOL_TYPE (std::get<0> (m_storage).symbol)->code ()
10517           == TYPE_CODE_FUNC))
10518     return true;
10519
10520   return false;
10521 }
10522
10523 value *
10524 ada_atr_val_operation::evaluate (struct type *expect_type,
10525                                  struct expression *exp,
10526                                  enum noside noside)
10527 {
10528   value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
10529   return ada_val_atr (noside, std::get<0> (m_storage), arg);
10530 }
10531
10532 value *
10533 ada_unop_ind_operation::evaluate (struct type *expect_type,
10534                                   struct expression *exp,
10535                                   enum noside noside)
10536 {
10537   value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
10538
10539   struct type *type = ada_check_typedef (value_type (arg1));
10540   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10541     {
10542       if (ada_is_array_descriptor_type (type))
10543         /* GDB allows dereferencing GNAT array descriptors.  */
10544         {
10545           struct type *arrType = ada_type_of_array (arg1, 0);
10546
10547           if (arrType == NULL)
10548             error (_("Attempt to dereference null array pointer."));
10549           return value_at_lazy (arrType, 0);
10550         }
10551       else if (type->code () == TYPE_CODE_PTR
10552                || type->code () == TYPE_CODE_REF
10553                /* In C you can dereference an array to get the 1st elt.  */
10554                || type->code () == TYPE_CODE_ARRAY)
10555         {
10556           /* As mentioned in the OP_VAR_VALUE case, tagged types can
10557              only be determined by inspecting the object's tag.
10558              This means that we need to evaluate completely the
10559              expression in order to get its type.  */
10560
10561           if ((type->code () == TYPE_CODE_REF
10562                || type->code () == TYPE_CODE_PTR)
10563               && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
10564             {
10565               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
10566                                                         EVAL_NORMAL);
10567               type = value_type (ada_value_ind (arg1));
10568             }
10569           else
10570             {
10571               type = to_static_fixed_type
10572                 (ada_aligned_type
10573                  (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10574             }
10575           return value_zero (type, lval_memory);
10576         }
10577       else if (type->code () == TYPE_CODE_INT)
10578         {
10579           /* GDB allows dereferencing an int.  */
10580           if (expect_type == NULL)
10581             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10582                                lval_memory);
10583           else
10584             {
10585               expect_type =
10586                 to_static_fixed_type (ada_aligned_type (expect_type));
10587               return value_zero (expect_type, lval_memory);
10588             }
10589         }
10590       else
10591         error (_("Attempt to take contents of a non-pointer value."));
10592     }
10593   arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
10594   type = ada_check_typedef (value_type (arg1));
10595
10596   if (type->code () == TYPE_CODE_INT)
10597     /* GDB allows dereferencing an int.  If we were given
10598        the expect_type, then use that as the target type.
10599        Otherwise, assume that the target type is an int.  */
10600     {
10601       if (expect_type != NULL)
10602         return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10603                                           arg1));
10604       else
10605         return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10606                               (CORE_ADDR) value_as_address (arg1));
10607     }
10608
10609   if (ada_is_array_descriptor_type (type))
10610     /* GDB allows dereferencing GNAT array descriptors.  */
10611     return ada_coerce_to_simple_array (arg1);
10612   else
10613     return ada_value_ind (arg1);
10614 }
10615
10616 value *
10617 ada_structop_operation::evaluate (struct type *expect_type,
10618                                   struct expression *exp,
10619                                   enum noside noside)
10620 {
10621   value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
10622   const char *str = std::get<1> (m_storage).c_str ();
10623   if (noside == EVAL_AVOID_SIDE_EFFECTS)
10624     {
10625       struct type *type;
10626       struct type *type1 = value_type (arg1);
10627
10628       if (ada_is_tagged_type (type1, 1))
10629         {
10630           type = ada_lookup_struct_elt_type (type1, str, 1, 1);
10631
10632           /* If the field is not found, check if it exists in the
10633              extension of this object's type. This means that we
10634              need to evaluate completely the expression.  */
10635
10636           if (type == NULL)
10637             {
10638               arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
10639                                                         EVAL_NORMAL);
10640               arg1 = ada_value_struct_elt (arg1, str, 0);
10641               arg1 = unwrap_value (arg1);
10642               type = value_type (ada_to_fixed_value (arg1));
10643             }
10644         }
10645       else
10646         type = ada_lookup_struct_elt_type (type1, str, 1, 0);
10647
10648       return value_zero (ada_aligned_type (type), lval_memory);
10649     }
10650   else
10651     {
10652       arg1 = ada_value_struct_elt (arg1, str, 0);
10653       arg1 = unwrap_value (arg1);
10654       return ada_to_fixed_value (arg1);
10655     }
10656 }
10657
10658 value *
10659 ada_funcall_operation::evaluate (struct type *expect_type,
10660                                  struct expression *exp,
10661                                  enum noside noside)
10662 {
10663   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
10664   int nargs = args_up.size ();
10665   std::vector<value *> argvec (nargs);
10666   operation_up &callee_op = std::get<0> (m_storage);
10667
10668   ada_var_value_operation *avv
10669     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
10670   if (avv != nullptr
10671       && SYMBOL_DOMAIN (avv->get_symbol ()) == UNDEF_DOMAIN)
10672     error (_("Unexpected unresolved symbol, %s, during evaluation"),
10673            avv->get_symbol ()->print_name ());
10674
10675   value *callee = callee_op->evaluate (nullptr, exp, noside);
10676   for (int i = 0; i < args_up.size (); ++i)
10677     argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
10678
10679   if (ada_is_constrained_packed_array_type
10680       (desc_base_type (value_type (callee))))
10681     callee = ada_coerce_to_simple_array (callee);
10682   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
10683            && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
10684     /* This is a packed array that has already been fixed, and
10685        therefore already coerced to a simple array.  Nothing further
10686        to do.  */
10687     ;
10688   else if (value_type (callee)->code () == TYPE_CODE_REF)
10689     {
10690       /* Make sure we dereference references so that all the code below
10691          feels like it's really handling the referenced value.  Wrapping
10692          types (for alignment) may be there, so make sure we strip them as
10693          well.  */
10694       callee = ada_to_fixed_value (coerce_ref (callee));
10695     }
10696   else if (value_type (callee)->code () == TYPE_CODE_ARRAY
10697            && VALUE_LVAL (callee) == lval_memory)
10698     callee = value_addr (callee);
10699
10700   struct type *type = ada_check_typedef (value_type (callee));
10701
10702   /* Ada allows us to implicitly dereference arrays when subscripting
10703      them.  So, if this is an array typedef (encoding use for array
10704      access types encoded as fat pointers), strip it now.  */
10705   if (type->code () == TYPE_CODE_TYPEDEF)
10706     type = ada_typedef_target_type (type);
10707
10708   if (type->code () == TYPE_CODE_PTR)
10709     {
10710       switch (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ())
10711         {
10712         case TYPE_CODE_FUNC:
10713           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10714           break;
10715         case TYPE_CODE_ARRAY:
10716           break;
10717         case TYPE_CODE_STRUCT:
10718           if (noside != EVAL_AVOID_SIDE_EFFECTS)
10719             callee = ada_value_ind (callee);
10720           type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10721           break;
10722         default:
10723           error (_("cannot subscript or call something of type `%s'"),
10724                  ada_type_name (value_type (callee)));
10725           break;
10726         }
10727     }
10728
10729   switch (type->code ())
10730     {
10731     case TYPE_CODE_FUNC:
10732       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10733         {
10734           if (TYPE_TARGET_TYPE (type) == NULL)
10735             error_call_unknown_return_type (NULL);
10736           return allocate_value (TYPE_TARGET_TYPE (type));
10737         }
10738       return call_function_by_hand (callee, NULL, argvec);
10739     case TYPE_CODE_INTERNAL_FUNCTION:
10740       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10741         /* We don't know anything about what the internal
10742            function might return, but we have to return
10743            something.  */
10744         return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10745                            not_lval);
10746       else
10747         return call_internal_function (exp->gdbarch, exp->language_defn,
10748                                        callee, nargs,
10749                                        argvec.data ());
10750
10751     case TYPE_CODE_STRUCT:
10752       {
10753         int arity;
10754
10755         arity = ada_array_arity (type);
10756         type = ada_array_element_type (type, nargs);
10757         if (type == NULL)
10758           error (_("cannot subscript or call a record"));
10759         if (arity != nargs)
10760           error (_("wrong number of subscripts; expecting %d"), arity);
10761         if (noside == EVAL_AVOID_SIDE_EFFECTS)
10762           return value_zero (ada_aligned_type (type), lval_memory);
10763         return
10764           unwrap_value (ada_value_subscript
10765                         (callee, nargs, argvec.data ()));
10766       }
10767     case TYPE_CODE_ARRAY:
10768       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10769         {
10770           type = ada_array_element_type (type, nargs);
10771           if (type == NULL)
10772             error (_("element type of array unknown"));
10773           else
10774             return value_zero (ada_aligned_type (type), lval_memory);
10775         }
10776       return
10777         unwrap_value (ada_value_subscript
10778                       (ada_coerce_to_simple_array (callee),
10779                        nargs, argvec.data ()));
10780     case TYPE_CODE_PTR:     /* Pointer to array */
10781       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10782         {
10783           type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10784           type = ada_array_element_type (type, nargs);
10785           if (type == NULL)
10786             error (_("element type of array unknown"));
10787           else
10788             return value_zero (ada_aligned_type (type), lval_memory);
10789         }
10790       return
10791         unwrap_value (ada_value_ptr_subscript (callee, nargs,
10792                                                argvec.data ()));
10793
10794     default:
10795       error (_("Attempt to index or call something other than an "
10796                "array or function"));
10797     }
10798 }
10799
10800 bool
10801 ada_funcall_operation::resolve (struct expression *exp,
10802                                 bool deprocedure_p,
10803                                 bool parse_completion,
10804                                 innermost_block_tracker *tracker,
10805                                 struct type *context_type)
10806 {
10807   operation_up &callee_op = std::get<0> (m_storage);
10808
10809   ada_var_value_operation *avv
10810     = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
10811   if (avv == nullptr)
10812     return false;
10813
10814   symbol *sym = avv->get_symbol ();
10815   if (SYMBOL_DOMAIN (sym) != UNDEF_DOMAIN)
10816     return false;
10817
10818   const std::vector<operation_up> &args_up = std::get<1> (m_storage);
10819   int nargs = args_up.size ();
10820   std::vector<value *> argvec (nargs);
10821
10822   for (int i = 0; i < args_up.size (); ++i)
10823     argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
10824
10825   const block *block = avv->get_block ();
10826   block_symbol resolved
10827     = ada_resolve_funcall (sym, block,
10828                            context_type, parse_completion,
10829                            nargs, argvec.data (),
10830                            tracker);
10831
10832   std::get<0> (m_storage)
10833     = make_operation<ada_var_value_operation> (resolved);
10834   return false;
10835 }
10836
10837 bool
10838 ada_ternop_slice_operation::resolve (struct expression *exp,
10839                                      bool deprocedure_p,
10840                                      bool parse_completion,
10841                                      innermost_block_tracker *tracker,
10842                                      struct type *context_type)
10843 {
10844   /* Historically this check was done during resolution, so we
10845      continue that here.  */
10846   value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
10847                                                 EVAL_AVOID_SIDE_EFFECTS);
10848   if (ada_is_any_packed_array_type (value_type (v)))
10849     error (_("cannot slice a packed array"));
10850   return false;
10851 }
10852
10853 }
10854
10855 \f
10856
10857 /* Return non-zero iff TYPE represents a System.Address type.  */
10858
10859 int
10860 ada_is_system_address_type (struct type *type)
10861 {
10862   return (type->name () && strcmp (type->name (), "system__address") == 0);
10863 }
10864
10865 \f
10866
10867                                 /* Range types */
10868
10869 /* Scan STR beginning at position K for a discriminant name, and
10870    return the value of that discriminant field of DVAL in *PX.  If
10871    PNEW_K is not null, put the position of the character beyond the
10872    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
10873    not alter *PX and *PNEW_K if unsuccessful.  */
10874
10875 static int
10876 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
10877                     int *pnew_k)
10878 {
10879   static std::string storage;
10880   const char *pstart, *pend, *bound;
10881   struct value *bound_val;
10882
10883   if (dval == NULL || str == NULL || str[k] == '\0')
10884     return 0;
10885
10886   pstart = str + k;
10887   pend = strstr (pstart, "__");
10888   if (pend == NULL)
10889     {
10890       bound = pstart;
10891       k += strlen (bound);
10892     }
10893   else
10894     {
10895       int len = pend - pstart;
10896
10897       /* Strip __ and beyond.  */
10898       storage = std::string (pstart, len);
10899       bound = storage.c_str ();
10900       k = pend - str;
10901     }
10902
10903   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
10904   if (bound_val == NULL)
10905     return 0;
10906
10907   *px = value_as_long (bound_val);
10908   if (pnew_k != NULL)
10909     *pnew_k = k;
10910   return 1;
10911 }
10912
10913 /* Value of variable named NAME.  Only exact matches are considered.
10914    If no such variable found, then if ERR_MSG is null, returns 0, and
10915    otherwise causes an error with message ERR_MSG.  */
10916
10917 static struct value *
10918 get_var_value (const char *name, const char *err_msg)
10919 {
10920   std::string quoted_name = add_angle_brackets (name);
10921
10922   lookup_name_info lookup_name (quoted_name, symbol_name_match_type::FULL);
10923
10924   std::vector<struct block_symbol> syms
10925     = ada_lookup_symbol_list_worker (lookup_name,
10926                                      get_selected_block (0),
10927                                      VAR_DOMAIN, 1);
10928
10929   if (syms.size () != 1)
10930     {
10931       if (err_msg == NULL)
10932         return 0;
10933       else
10934         error (("%s"), err_msg);
10935     }
10936
10937   return value_of_variable (syms[0].symbol, syms[0].block);
10938 }
10939
10940 /* Value of integer variable named NAME in the current environment.
10941    If no such variable is found, returns false.  Otherwise, sets VALUE
10942    to the variable's value and returns true.  */
10943
10944 bool
10945 get_int_var_value (const char *name, LONGEST &value)
10946 {
10947   struct value *var_val = get_var_value (name, 0);
10948
10949   if (var_val == 0)
10950     return false;
10951
10952   value = value_as_long (var_val);
10953   return true;
10954 }
10955
10956
10957 /* Return a range type whose base type is that of the range type named
10958    NAME in the current environment, and whose bounds are calculated
10959    from NAME according to the GNAT range encoding conventions.
10960    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
10961    corresponding range type from debug information; fall back to using it
10962    if symbol lookup fails.  If a new type must be created, allocate it
10963    like ORIG_TYPE was.  The bounds information, in general, is encoded
10964    in NAME, the base type given in the named range type.  */
10965
10966 static struct type *
10967 to_fixed_range_type (struct type *raw_type, struct value *dval)
10968 {
10969   const char *name;
10970   struct type *base_type;
10971   const char *subtype_info;
10972
10973   gdb_assert (raw_type != NULL);
10974   gdb_assert (raw_type->name () != NULL);
10975
10976   if (raw_type->code () == TYPE_CODE_RANGE)
10977     base_type = TYPE_TARGET_TYPE (raw_type);
10978   else
10979     base_type = raw_type;
10980
10981   name = raw_type->name ();
10982   subtype_info = strstr (name, "___XD");
10983   if (subtype_info == NULL)
10984     {
10985       LONGEST L = ada_discrete_type_low_bound (raw_type);
10986       LONGEST U = ada_discrete_type_high_bound (raw_type);
10987
10988       if (L < INT_MIN || U > INT_MAX)
10989         return raw_type;
10990       else
10991         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
10992                                          L, U);
10993     }
10994   else
10995     {
10996       int prefix_len = subtype_info - name;
10997       LONGEST L, U;
10998       struct type *type;
10999       const char *bounds_str;
11000       int n;
11001
11002       subtype_info += 5;
11003       bounds_str = strchr (subtype_info, '_');
11004       n = 1;
11005
11006       if (*subtype_info == 'L')
11007         {
11008           if (!ada_scan_number (bounds_str, n, &L, &n)
11009               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11010             return raw_type;
11011           if (bounds_str[n] == '_')
11012             n += 2;
11013           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
11014             n += 1;
11015           subtype_info += 1;
11016         }
11017       else
11018         {
11019           std::string name_buf = std::string (name, prefix_len) + "___L";
11020           if (!get_int_var_value (name_buf.c_str (), L))
11021             {
11022               lim_warning (_("Unknown lower bound, using 1."));
11023               L = 1;
11024             }
11025         }
11026
11027       if (*subtype_info == 'U')
11028         {
11029           if (!ada_scan_number (bounds_str, n, &U, &n)
11030               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11031             return raw_type;
11032         }
11033       else
11034         {
11035           std::string name_buf = std::string (name, prefix_len) + "___U";
11036           if (!get_int_var_value (name_buf.c_str (), U))
11037             {
11038               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11039               U = L;
11040             }
11041         }
11042
11043       type = create_static_range_type (alloc_type_copy (raw_type),
11044                                        base_type, L, U);
11045       /* create_static_range_type alters the resulting type's length
11046          to match the size of the base_type, which is not what we want.
11047          Set it back to the original range type's length.  */
11048       TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11049       type->set_name (name);
11050       return type;
11051     }
11052 }
11053
11054 /* True iff NAME is the name of a range type.  */
11055
11056 int
11057 ada_is_range_type_name (const char *name)
11058 {
11059   return (name != NULL && strstr (name, "___XD"));
11060 }
11061 \f
11062
11063                                 /* Modular types */
11064
11065 /* True iff TYPE is an Ada modular type.  */
11066
11067 int
11068 ada_is_modular_type (struct type *type)
11069 {
11070   struct type *subranged_type = get_base_type (type);
11071
11072   return (subranged_type != NULL && type->code () == TYPE_CODE_RANGE
11073           && subranged_type->code () == TYPE_CODE_INT
11074           && subranged_type->is_unsigned ());
11075 }
11076
11077 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
11078
11079 ULONGEST
11080 ada_modulus (struct type *type)
11081 {
11082   const dynamic_prop &high = type->bounds ()->high;
11083
11084   if (high.kind () == PROP_CONST)
11085     return (ULONGEST) high.const_val () + 1;
11086
11087   /* If TYPE is unresolved, the high bound might be a location list.  Return
11088      0, for lack of a better value to return.  */
11089   return 0;
11090 }
11091 \f
11092
11093 /* Ada exception catchpoint support:
11094    ---------------------------------
11095
11096    We support 3 kinds of exception catchpoints:
11097      . catchpoints on Ada exceptions
11098      . catchpoints on unhandled Ada exceptions
11099      . catchpoints on failed assertions
11100
11101    Exceptions raised during failed assertions, or unhandled exceptions
11102    could perfectly be caught with the general catchpoint on Ada exceptions.
11103    However, we can easily differentiate these two special cases, and having
11104    the option to distinguish these two cases from the rest can be useful
11105    to zero-in on certain situations.
11106
11107    Exception catchpoints are a specialized form of breakpoint,
11108    since they rely on inserting breakpoints inside known routines
11109    of the GNAT runtime.  The implementation therefore uses a standard
11110    breakpoint structure of the BP_BREAKPOINT type, but with its own set
11111    of breakpoint_ops.
11112
11113    Support in the runtime for exception catchpoints have been changed
11114    a few times already, and these changes affect the implementation
11115    of these catchpoints.  In order to be able to support several
11116    variants of the runtime, we use a sniffer that will determine
11117    the runtime variant used by the program being debugged.  */
11118
11119 /* Ada's standard exceptions.
11120
11121    The Ada 83 standard also defined Numeric_Error.  But there so many
11122    situations where it was unclear from the Ada 83 Reference Manual
11123    (RM) whether Constraint_Error or Numeric_Error should be raised,
11124    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11125    Interpretation saying that anytime the RM says that Numeric_Error
11126    should be raised, the implementation may raise Constraint_Error.
11127    Ada 95 went one step further and pretty much removed Numeric_Error
11128    from the list of standard exceptions (it made it a renaming of
11129    Constraint_Error, to help preserve compatibility when compiling
11130    an Ada83 compiler). As such, we do not include Numeric_Error from
11131    this list of standard exceptions.  */
11132
11133 static const char * const standard_exc[] = {
11134   "constraint_error",
11135   "program_error",
11136   "storage_error",
11137   "tasking_error"
11138 };
11139
11140 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11141
11142 /* A structure that describes how to support exception catchpoints
11143    for a given executable.  */
11144
11145 struct exception_support_info
11146 {
11147    /* The name of the symbol to break on in order to insert
11148       a catchpoint on exceptions.  */
11149    const char *catch_exception_sym;
11150
11151    /* The name of the symbol to break on in order to insert
11152       a catchpoint on unhandled exceptions.  */
11153    const char *catch_exception_unhandled_sym;
11154
11155    /* The name of the symbol to break on in order to insert
11156       a catchpoint on failed assertions.  */
11157    const char *catch_assert_sym;
11158
11159    /* The name of the symbol to break on in order to insert
11160       a catchpoint on exception handling.  */
11161    const char *catch_handlers_sym;
11162
11163    /* Assuming that the inferior just triggered an unhandled exception
11164       catchpoint, this function is responsible for returning the address
11165       in inferior memory where the name of that exception is stored.
11166       Return zero if the address could not be computed.  */
11167    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11168 };
11169
11170 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11171 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11172
11173 /* The following exception support info structure describes how to
11174    implement exception catchpoints with the latest version of the
11175    Ada runtime (as of 2019-08-??).  */
11176
11177 static const struct exception_support_info default_exception_support_info =
11178 {
11179   "__gnat_debug_raise_exception", /* catch_exception_sym */
11180   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11181   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11182   "__gnat_begin_handler_v1", /* catch_handlers_sym */
11183   ada_unhandled_exception_name_addr
11184 };
11185
11186 /* The following exception support info structure describes how to
11187    implement exception catchpoints with an earlier version of the
11188    Ada runtime (as of 2007-03-06) using v0 of the EH ABI.  */
11189
11190 static const struct exception_support_info exception_support_info_v0 =
11191 {
11192   "__gnat_debug_raise_exception", /* catch_exception_sym */
11193   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11194   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11195   "__gnat_begin_handler", /* catch_handlers_sym */
11196   ada_unhandled_exception_name_addr
11197 };
11198
11199 /* The following exception support info structure describes how to
11200    implement exception catchpoints with a slightly older version
11201    of the Ada runtime.  */
11202
11203 static const struct exception_support_info exception_support_info_fallback =
11204 {
11205   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11206   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11207   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
11208   "__gnat_begin_handler", /* catch_handlers_sym */
11209   ada_unhandled_exception_name_addr_from_raise
11210 };
11211
11212 /* Return nonzero if we can detect the exception support routines
11213    described in EINFO.
11214
11215    This function errors out if an abnormal situation is detected
11216    (for instance, if we find the exception support routines, but
11217    that support is found to be incomplete).  */
11218
11219 static int
11220 ada_has_this_exception_support (const struct exception_support_info *einfo)
11221 {
11222   struct symbol *sym;
11223
11224   /* The symbol we're looking up is provided by a unit in the GNAT runtime
11225      that should be compiled with debugging information.  As a result, we
11226      expect to find that symbol in the symtabs.  */
11227
11228   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11229   if (sym == NULL)
11230     {
11231       /* Perhaps we did not find our symbol because the Ada runtime was
11232          compiled without debugging info, or simply stripped of it.
11233          It happens on some GNU/Linux distributions for instance, where
11234          users have to install a separate debug package in order to get
11235          the runtime's debugging info.  In that situation, let the user
11236          know why we cannot insert an Ada exception catchpoint.
11237
11238          Note: Just for the purpose of inserting our Ada exception
11239          catchpoint, we could rely purely on the associated minimal symbol.
11240          But we would be operating in degraded mode anyway, since we are
11241          still lacking the debugging info needed later on to extract
11242          the name of the exception being raised (this name is printed in
11243          the catchpoint message, and is also used when trying to catch
11244          a specific exception).  We do not handle this case for now.  */
11245       struct bound_minimal_symbol msym
11246         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11247
11248       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11249         error (_("Your Ada runtime appears to be missing some debugging "
11250                  "information.\nCannot insert Ada exception catchpoint "
11251                  "in this configuration."));
11252
11253       return 0;
11254     }
11255
11256   /* Make sure that the symbol we found corresponds to a function.  */
11257
11258   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11259     {
11260       error (_("Symbol \"%s\" is not a function (class = %d)"),
11261              sym->linkage_name (), SYMBOL_CLASS (sym));
11262       return 0;
11263     }
11264
11265   sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11266   if (sym == NULL)
11267     {
11268       struct bound_minimal_symbol msym
11269         = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11270
11271       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11272         error (_("Your Ada runtime appears to be missing some debugging "
11273                  "information.\nCannot insert Ada exception catchpoint "
11274                  "in this configuration."));
11275
11276       return 0;
11277     }
11278
11279   /* Make sure that the symbol we found corresponds to a function.  */
11280
11281   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11282     {
11283       error (_("Symbol \"%s\" is not a function (class = %d)"),
11284              sym->linkage_name (), SYMBOL_CLASS (sym));
11285       return 0;
11286     }
11287
11288   return 1;
11289 }
11290
11291 /* Inspect the Ada runtime and determine which exception info structure
11292    should be used to provide support for exception catchpoints.
11293
11294    This function will always set the per-inferior exception_info,
11295    or raise an error.  */
11296
11297 static void
11298 ada_exception_support_info_sniffer (void)
11299 {
11300   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11301
11302   /* If the exception info is already known, then no need to recompute it.  */
11303   if (data->exception_info != NULL)
11304     return;
11305
11306   /* Check the latest (default) exception support info.  */
11307   if (ada_has_this_exception_support (&default_exception_support_info))
11308     {
11309       data->exception_info = &default_exception_support_info;
11310       return;
11311     }
11312
11313   /* Try the v0 exception suport info.  */
11314   if (ada_has_this_exception_support (&exception_support_info_v0))
11315     {
11316       data->exception_info = &exception_support_info_v0;
11317       return;
11318     }
11319
11320   /* Try our fallback exception suport info.  */
11321   if (ada_has_this_exception_support (&exception_support_info_fallback))
11322     {
11323       data->exception_info = &exception_support_info_fallback;
11324       return;
11325     }
11326
11327   /* Sometimes, it is normal for us to not be able to find the routine
11328      we are looking for.  This happens when the program is linked with
11329      the shared version of the GNAT runtime, and the program has not been
11330      started yet.  Inform the user of these two possible causes if
11331      applicable.  */
11332
11333   if (ada_update_initial_language (language_unknown) != language_ada)
11334     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
11335
11336   /* If the symbol does not exist, then check that the program is
11337      already started, to make sure that shared libraries have been
11338      loaded.  If it is not started, this may mean that the symbol is
11339      in a shared library.  */
11340
11341   if (inferior_ptid.pid () == 0)
11342     error (_("Unable to insert catchpoint. Try to start the program first."));
11343
11344   /* At this point, we know that we are debugging an Ada program and
11345      that the inferior has been started, but we still are not able to
11346      find the run-time symbols.  That can mean that we are in
11347      configurable run time mode, or that a-except as been optimized
11348      out by the linker...  In any case, at this point it is not worth
11349      supporting this feature.  */
11350
11351   error (_("Cannot insert Ada exception catchpoints in this configuration."));
11352 }
11353
11354 /* True iff FRAME is very likely to be that of a function that is
11355    part of the runtime system.  This is all very heuristic, but is
11356    intended to be used as advice as to what frames are uninteresting
11357    to most users.  */
11358
11359 static int
11360 is_known_support_routine (struct frame_info *frame)
11361 {
11362   enum language func_lang;
11363   int i;
11364   const char *fullname;
11365
11366   /* If this code does not have any debugging information (no symtab),
11367      This cannot be any user code.  */
11368
11369   symtab_and_line sal = find_frame_sal (frame);
11370   if (sal.symtab == NULL)
11371     return 1;
11372
11373   /* If there is a symtab, but the associated source file cannot be
11374      located, then assume this is not user code:  Selecting a frame
11375      for which we cannot display the code would not be very helpful
11376      for the user.  This should also take care of case such as VxWorks
11377      where the kernel has some debugging info provided for a few units.  */
11378
11379   fullname = symtab_to_fullname (sal.symtab);
11380   if (access (fullname, R_OK) != 0)
11381     return 1;
11382
11383   /* Check the unit filename against the Ada runtime file naming.
11384      We also check the name of the objfile against the name of some
11385      known system libraries that sometimes come with debugging info
11386      too.  */
11387
11388   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11389     {
11390       re_comp (known_runtime_file_name_patterns[i]);
11391       if (re_exec (lbasename (sal.symtab->filename)))
11392         return 1;
11393       if (SYMTAB_OBJFILE (sal.symtab) != NULL
11394           && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
11395         return 1;
11396     }
11397
11398   /* Check whether the function is a GNAT-generated entity.  */
11399
11400   gdb::unique_xmalloc_ptr<char> func_name
11401     = find_frame_funname (frame, &func_lang, NULL);
11402   if (func_name == NULL)
11403     return 1;
11404
11405   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11406     {
11407       re_comp (known_auxiliary_function_name_patterns[i]);
11408       if (re_exec (func_name.get ()))
11409         return 1;
11410     }
11411
11412   return 0;
11413 }
11414
11415 /* Find the first frame that contains debugging information and that is not
11416    part of the Ada run-time, starting from FI and moving upward.  */
11417
11418 void
11419 ada_find_printable_frame (struct frame_info *fi)
11420 {
11421   for (; fi != NULL; fi = get_prev_frame (fi))
11422     {
11423       if (!is_known_support_routine (fi))
11424         {
11425           select_frame (fi);
11426           break;
11427         }
11428     }
11429
11430 }
11431
11432 /* Assuming that the inferior just triggered an unhandled exception
11433    catchpoint, return the address in inferior memory where the name
11434    of the exception is stored.
11435    
11436    Return zero if the address could not be computed.  */
11437
11438 static CORE_ADDR
11439 ada_unhandled_exception_name_addr (void)
11440 {
11441   return parse_and_eval_address ("e.full_name");
11442 }
11443
11444 /* Same as ada_unhandled_exception_name_addr, except that this function
11445    should be used when the inferior uses an older version of the runtime,
11446    where the exception name needs to be extracted from a specific frame
11447    several frames up in the callstack.  */
11448
11449 static CORE_ADDR
11450 ada_unhandled_exception_name_addr_from_raise (void)
11451 {
11452   int frame_level;
11453   struct frame_info *fi;
11454   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11455
11456   /* To determine the name of this exception, we need to select
11457      the frame corresponding to RAISE_SYM_NAME.  This frame is
11458      at least 3 levels up, so we simply skip the first 3 frames
11459      without checking the name of their associated function.  */
11460   fi = get_current_frame ();
11461   for (frame_level = 0; frame_level < 3; frame_level += 1)
11462     if (fi != NULL)
11463       fi = get_prev_frame (fi); 
11464
11465   while (fi != NULL)
11466     {
11467       enum language func_lang;
11468
11469       gdb::unique_xmalloc_ptr<char> func_name
11470         = find_frame_funname (fi, &func_lang, NULL);
11471       if (func_name != NULL)
11472         {
11473           if (strcmp (func_name.get (),
11474                       data->exception_info->catch_exception_sym) == 0)
11475             break; /* We found the frame we were looking for...  */
11476         }
11477       fi = get_prev_frame (fi);
11478     }
11479
11480   if (fi == NULL)
11481     return 0;
11482
11483   select_frame (fi);
11484   return parse_and_eval_address ("id.full_name");
11485 }
11486
11487 /* Assuming the inferior just triggered an Ada exception catchpoint
11488    (of any type), return the address in inferior memory where the name
11489    of the exception is stored, if applicable.
11490
11491    Assumes the selected frame is the current frame.
11492
11493    Return zero if the address could not be computed, or if not relevant.  */
11494
11495 static CORE_ADDR
11496 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
11497                            struct breakpoint *b)
11498 {
11499   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11500
11501   switch (ex)
11502     {
11503       case ada_catch_exception:
11504         return (parse_and_eval_address ("e.full_name"));
11505         break;
11506
11507       case ada_catch_exception_unhandled:
11508         return data->exception_info->unhandled_exception_name_addr ();
11509         break;
11510
11511       case ada_catch_handlers:
11512         return 0;  /* The runtimes does not provide access to the exception
11513                       name.  */
11514         break;
11515
11516       case ada_catch_assert:
11517         return 0;  /* Exception name is not relevant in this case.  */
11518         break;
11519
11520       default:
11521         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11522         break;
11523     }
11524
11525   return 0; /* Should never be reached.  */
11526 }
11527
11528 /* Assuming the inferior is stopped at an exception catchpoint,
11529    return the message which was associated to the exception, if
11530    available.  Return NULL if the message could not be retrieved.
11531
11532    Note: The exception message can be associated to an exception
11533    either through the use of the Raise_Exception function, or
11534    more simply (Ada 2005 and later), via:
11535
11536        raise Exception_Name with "exception message";
11537
11538    */
11539
11540 static gdb::unique_xmalloc_ptr<char>
11541 ada_exception_message_1 (void)
11542 {
11543   struct value *e_msg_val;
11544   int e_msg_len;
11545
11546   /* For runtimes that support this feature, the exception message
11547      is passed as an unbounded string argument called "message".  */
11548   e_msg_val = parse_and_eval ("message");
11549   if (e_msg_val == NULL)
11550     return NULL; /* Exception message not supported.  */
11551
11552   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
11553   gdb_assert (e_msg_val != NULL);
11554   e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
11555
11556   /* If the message string is empty, then treat it as if there was
11557      no exception message.  */
11558   if (e_msg_len <= 0)
11559     return NULL;
11560
11561   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
11562   read_memory (value_address (e_msg_val), (gdb_byte *) e_msg.get (),
11563                e_msg_len);
11564   e_msg.get ()[e_msg_len] = '\0';
11565
11566   return e_msg;
11567 }
11568
11569 /* Same as ada_exception_message_1, except that all exceptions are
11570    contained here (returning NULL instead).  */
11571
11572 static gdb::unique_xmalloc_ptr<char>
11573 ada_exception_message (void)
11574 {
11575   gdb::unique_xmalloc_ptr<char> e_msg;
11576
11577   try
11578     {
11579       e_msg = ada_exception_message_1 ();
11580     }
11581   catch (const gdb_exception_error &e)
11582     {
11583       e_msg.reset (nullptr);
11584     }
11585
11586   return e_msg;
11587 }
11588
11589 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11590    any error that ada_exception_name_addr_1 might cause to be thrown.
11591    When an error is intercepted, a warning with the error message is printed,
11592    and zero is returned.  */
11593
11594 static CORE_ADDR
11595 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
11596                          struct breakpoint *b)
11597 {
11598   CORE_ADDR result = 0;
11599
11600   try
11601     {
11602       result = ada_exception_name_addr_1 (ex, b);
11603     }
11604
11605   catch (const gdb_exception_error &e)
11606     {
11607       warning (_("failed to get exception name: %s"), e.what ());
11608       return 0;
11609     }
11610
11611   return result;
11612 }
11613
11614 static std::string ada_exception_catchpoint_cond_string
11615   (const char *excep_string,
11616    enum ada_exception_catchpoint_kind ex);
11617
11618 /* Ada catchpoints.
11619
11620    In the case of catchpoints on Ada exceptions, the catchpoint will
11621    stop the target on every exception the program throws.  When a user
11622    specifies the name of a specific exception, we translate this
11623    request into a condition expression (in text form), and then parse
11624    it into an expression stored in each of the catchpoint's locations.
11625    We then use this condition to check whether the exception that was
11626    raised is the one the user is interested in.  If not, then the
11627    target is resumed again.  We store the name of the requested
11628    exception, in order to be able to re-set the condition expression
11629    when symbols change.  */
11630
11631 /* An instance of this type is used to represent an Ada catchpoint
11632    breakpoint location.  */
11633
11634 class ada_catchpoint_location : public bp_location
11635 {
11636 public:
11637   ada_catchpoint_location (breakpoint *owner)
11638     : bp_location (owner, bp_loc_software_breakpoint)
11639   {}
11640
11641   /* The condition that checks whether the exception that was raised
11642      is the specific exception the user specified on catchpoint
11643      creation.  */
11644   expression_up excep_cond_expr;
11645 };
11646
11647 /* An instance of this type is used to represent an Ada catchpoint.  */
11648
11649 struct ada_catchpoint : public breakpoint
11650 {
11651   explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind)
11652     : m_kind (kind)
11653   {
11654   }
11655
11656   /* The name of the specific exception the user specified.  */
11657   std::string excep_string;
11658
11659   /* What kind of catchpoint this is.  */
11660   enum ada_exception_catchpoint_kind m_kind;
11661 };
11662
11663 /* Parse the exception condition string in the context of each of the
11664    catchpoint's locations, and store them for later evaluation.  */
11665
11666 static void
11667 create_excep_cond_exprs (struct ada_catchpoint *c,
11668                          enum ada_exception_catchpoint_kind ex)
11669 {
11670   /* Nothing to do if there's no specific exception to catch.  */
11671   if (c->excep_string.empty ())
11672     return;
11673
11674   /* Same if there are no locations... */
11675   if (c->loc == NULL)
11676     return;
11677
11678   /* Compute the condition expression in text form, from the specific
11679      expection we want to catch.  */
11680   std::string cond_string
11681     = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
11682
11683   /* Iterate over all the catchpoint's locations, and parse an
11684      expression for each.  */
11685   for (bp_location *bl : c->locations ())
11686     {
11687       struct ada_catchpoint_location *ada_loc
11688         = (struct ada_catchpoint_location *) bl;
11689       expression_up exp;
11690
11691       if (!bl->shlib_disabled)
11692         {
11693           const char *s;
11694
11695           s = cond_string.c_str ();
11696           try
11697             {
11698               exp = parse_exp_1 (&s, bl->address,
11699                                  block_for_pc (bl->address),
11700                                  0);
11701             }
11702           catch (const gdb_exception_error &e)
11703             {
11704               warning (_("failed to reevaluate internal exception condition "
11705                          "for catchpoint %d: %s"),
11706                        c->number, e.what ());
11707             }
11708         }
11709
11710       ada_loc->excep_cond_expr = std::move (exp);
11711     }
11712 }
11713
11714 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11715    structure for all exception catchpoint kinds.  */
11716
11717 static struct bp_location *
11718 allocate_location_exception (struct breakpoint *self)
11719 {
11720   return new ada_catchpoint_location (self);
11721 }
11722
11723 /* Implement the RE_SET method in the breakpoint_ops structure for all
11724    exception catchpoint kinds.  */
11725
11726 static void
11727 re_set_exception (struct breakpoint *b)
11728 {
11729   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11730
11731   /* Call the base class's method.  This updates the catchpoint's
11732      locations.  */
11733   bkpt_breakpoint_ops.re_set (b);
11734
11735   /* Reparse the exception conditional expressions.  One for each
11736      location.  */
11737   create_excep_cond_exprs (c, c->m_kind);
11738 }
11739
11740 /* Returns true if we should stop for this breakpoint hit.  If the
11741    user specified a specific exception, we only want to cause a stop
11742    if the program thrown that exception.  */
11743
11744 static bool
11745 should_stop_exception (const struct bp_location *bl)
11746 {
11747   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11748   const struct ada_catchpoint_location *ada_loc
11749     = (const struct ada_catchpoint_location *) bl;
11750   bool stop;
11751
11752   struct internalvar *var = lookup_internalvar ("_ada_exception");
11753   if (c->m_kind == ada_catch_assert)
11754     clear_internalvar (var);
11755   else
11756     {
11757       try
11758         {
11759           const char *expr;
11760
11761           if (c->m_kind == ada_catch_handlers)
11762             expr = ("GNAT_GCC_exception_Access(gcc_exception)"
11763                     ".all.occurrence.id");
11764           else
11765             expr = "e";
11766
11767           struct value *exc = parse_and_eval (expr);
11768           set_internalvar (var, exc);
11769         }
11770       catch (const gdb_exception_error &ex)
11771         {
11772           clear_internalvar (var);
11773         }
11774     }
11775
11776   /* With no specific exception, should always stop.  */
11777   if (c->excep_string.empty ())
11778     return true;
11779
11780   if (ada_loc->excep_cond_expr == NULL)
11781     {
11782       /* We will have a NULL expression if back when we were creating
11783          the expressions, this location's had failed to parse.  */
11784       return true;
11785     }
11786
11787   stop = true;
11788   try
11789     {
11790       struct value *mark;
11791
11792       mark = value_mark ();
11793       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
11794       value_free_to_mark (mark);
11795     }
11796   catch (const gdb_exception &ex)
11797     {
11798       exception_fprintf (gdb_stderr, ex,
11799                          _("Error in testing exception condition:\n"));
11800     }
11801
11802   return stop;
11803 }
11804
11805 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
11806    for all exception catchpoint kinds.  */
11807
11808 static void
11809 check_status_exception (bpstat bs)
11810 {
11811   bs->stop = should_stop_exception (bs->bp_location_at.get ());
11812 }
11813
11814 /* Implement the PRINT_IT method in the breakpoint_ops structure
11815    for all exception catchpoint kinds.  */
11816
11817 static enum print_stop_action
11818 print_it_exception (bpstat bs)
11819 {
11820   struct ui_out *uiout = current_uiout;
11821   struct breakpoint *b = bs->breakpoint_at;
11822
11823   annotate_catchpoint (b->number);
11824
11825   if (uiout->is_mi_like_p ())
11826     {
11827       uiout->field_string ("reason",
11828                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11829       uiout->field_string ("disp", bpdisp_text (b->disposition));
11830     }
11831
11832   uiout->text (b->disposition == disp_del
11833                ? "\nTemporary catchpoint " : "\nCatchpoint ");
11834   uiout->field_signed ("bkptno", b->number);
11835   uiout->text (", ");
11836
11837   /* ada_exception_name_addr relies on the selected frame being the
11838      current frame.  Need to do this here because this function may be
11839      called more than once when printing a stop, and below, we'll
11840      select the first frame past the Ada run-time (see
11841      ada_find_printable_frame).  */
11842   select_frame (get_current_frame ());
11843
11844   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11845   switch (c->m_kind)
11846     {
11847       case ada_catch_exception:
11848       case ada_catch_exception_unhandled:
11849       case ada_catch_handlers:
11850         {
11851           const CORE_ADDR addr = ada_exception_name_addr (c->m_kind, b);
11852           char exception_name[256];
11853
11854           if (addr != 0)
11855             {
11856               read_memory (addr, (gdb_byte *) exception_name,
11857                            sizeof (exception_name) - 1);
11858               exception_name [sizeof (exception_name) - 1] = '\0';
11859             }
11860           else
11861             {
11862               /* For some reason, we were unable to read the exception
11863                  name.  This could happen if the Runtime was compiled
11864                  without debugging info, for instance.  In that case,
11865                  just replace the exception name by the generic string
11866                  "exception" - it will read as "an exception" in the
11867                  notification we are about to print.  */
11868               memcpy (exception_name, "exception", sizeof ("exception"));
11869             }
11870           /* In the case of unhandled exception breakpoints, we print
11871              the exception name as "unhandled EXCEPTION_NAME", to make
11872              it clearer to the user which kind of catchpoint just got
11873              hit.  We used ui_out_text to make sure that this extra
11874              info does not pollute the exception name in the MI case.  */
11875           if (c->m_kind == ada_catch_exception_unhandled)
11876             uiout->text ("unhandled ");
11877           uiout->field_string ("exception-name", exception_name);
11878         }
11879         break;
11880       case ada_catch_assert:
11881         /* In this case, the name of the exception is not really
11882            important.  Just print "failed assertion" to make it clearer
11883            that his program just hit an assertion-failure catchpoint.
11884            We used ui_out_text because this info does not belong in
11885            the MI output.  */
11886         uiout->text ("failed assertion");
11887         break;
11888     }
11889
11890   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
11891   if (exception_message != NULL)
11892     {
11893       uiout->text (" (");
11894       uiout->field_string ("exception-message", exception_message.get ());
11895       uiout->text (")");
11896     }
11897
11898   uiout->text (" at ");
11899   ada_find_printable_frame (get_current_frame ());
11900
11901   return PRINT_SRC_AND_LOC;
11902 }
11903
11904 /* Implement the PRINT_ONE method in the breakpoint_ops structure
11905    for all exception catchpoint kinds.  */
11906
11907 static void
11908 print_one_exception (struct breakpoint *b, struct bp_location **last_loc)
11909
11910   struct ui_out *uiout = current_uiout;
11911   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11912   struct value_print_options opts;
11913
11914   get_user_print_options (&opts);
11915
11916   if (opts.addressprint)
11917     uiout->field_skip ("addr");
11918
11919   annotate_field (5);
11920   switch (c->m_kind)
11921     {
11922       case ada_catch_exception:
11923         if (!c->excep_string.empty ())
11924           {
11925             std::string msg = string_printf (_("`%s' Ada exception"),
11926                                              c->excep_string.c_str ());
11927
11928             uiout->field_string ("what", msg);
11929           }
11930         else
11931           uiout->field_string ("what", "all Ada exceptions");
11932         
11933         break;
11934
11935       case ada_catch_exception_unhandled:
11936         uiout->field_string ("what", "unhandled Ada exceptions");
11937         break;
11938       
11939       case ada_catch_handlers:
11940         if (!c->excep_string.empty ())
11941           {
11942             uiout->field_fmt ("what",
11943                               _("`%s' Ada exception handlers"),
11944                               c->excep_string.c_str ());
11945           }
11946         else
11947           uiout->field_string ("what", "all Ada exceptions handlers");
11948         break;
11949
11950       case ada_catch_assert:
11951         uiout->field_string ("what", "failed Ada assertions");
11952         break;
11953
11954       default:
11955         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11956         break;
11957     }
11958 }
11959
11960 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
11961    for all exception catchpoint kinds.  */
11962
11963 static void
11964 print_mention_exception (struct breakpoint *b)
11965 {
11966   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11967   struct ui_out *uiout = current_uiout;
11968
11969   uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
11970                                                  : _("Catchpoint "));
11971   uiout->field_signed ("bkptno", b->number);
11972   uiout->text (": ");
11973
11974   switch (c->m_kind)
11975     {
11976       case ada_catch_exception:
11977         if (!c->excep_string.empty ())
11978           {
11979             std::string info = string_printf (_("`%s' Ada exception"),
11980                                               c->excep_string.c_str ());
11981             uiout->text (info);
11982           }
11983         else
11984           uiout->text (_("all Ada exceptions"));
11985         break;
11986
11987       case ada_catch_exception_unhandled:
11988         uiout->text (_("unhandled Ada exceptions"));
11989         break;
11990
11991       case ada_catch_handlers:
11992         if (!c->excep_string.empty ())
11993           {
11994             std::string info
11995               = string_printf (_("`%s' Ada exception handlers"),
11996                                c->excep_string.c_str ());
11997             uiout->text (info);
11998           }
11999         else
12000           uiout->text (_("all Ada exceptions handlers"));
12001         break;
12002
12003       case ada_catch_assert:
12004         uiout->text (_("failed Ada assertions"));
12005         break;
12006
12007       default:
12008         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12009         break;
12010     }
12011 }
12012
12013 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12014    for all exception catchpoint kinds.  */
12015
12016 static void
12017 print_recreate_exception (struct breakpoint *b, struct ui_file *fp)
12018 {
12019   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12020
12021   switch (c->m_kind)
12022     {
12023       case ada_catch_exception:
12024         fprintf_filtered (fp, "catch exception");
12025         if (!c->excep_string.empty ())
12026           fprintf_filtered (fp, " %s", c->excep_string.c_str ());
12027         break;
12028
12029       case ada_catch_exception_unhandled:
12030         fprintf_filtered (fp, "catch exception unhandled");
12031         break;
12032
12033       case ada_catch_handlers:
12034         fprintf_filtered (fp, "catch handlers");
12035         break;
12036
12037       case ada_catch_assert:
12038         fprintf_filtered (fp, "catch assert");
12039         break;
12040
12041       default:
12042         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12043     }
12044   print_recreate_thread (b, fp);
12045 }
12046
12047 /* Virtual tables for various breakpoint types.  */
12048 static struct breakpoint_ops catch_exception_breakpoint_ops;
12049 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
12050 static struct breakpoint_ops catch_assert_breakpoint_ops;
12051 static struct breakpoint_ops catch_handlers_breakpoint_ops;
12052
12053 /* See ada-lang.h.  */
12054
12055 bool
12056 is_ada_exception_catchpoint (breakpoint *bp)
12057 {
12058   return (bp->ops == &catch_exception_breakpoint_ops
12059           || bp->ops == &catch_exception_unhandled_breakpoint_ops
12060           || bp->ops == &catch_assert_breakpoint_ops
12061           || bp->ops == &catch_handlers_breakpoint_ops);
12062 }
12063
12064 /* Split the arguments specified in a "catch exception" command.  
12065    Set EX to the appropriate catchpoint type.
12066    Set EXCEP_STRING to the name of the specific exception if
12067    specified by the user.
12068    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12069    "catch handlers" command.  False otherwise.
12070    If a condition is found at the end of the arguments, the condition
12071    expression is stored in COND_STRING (memory must be deallocated
12072    after use).  Otherwise COND_STRING is set to NULL.  */
12073
12074 static void
12075 catch_ada_exception_command_split (const char *args,
12076                                    bool is_catch_handlers_cmd,
12077                                    enum ada_exception_catchpoint_kind *ex,
12078                                    std::string *excep_string,
12079                                    std::string *cond_string)
12080 {
12081   std::string exception_name;
12082
12083   exception_name = extract_arg (&args);
12084   if (exception_name == "if")
12085     {
12086       /* This is not an exception name; this is the start of a condition
12087          expression for a catchpoint on all exceptions.  So, "un-get"
12088          this token, and set exception_name to NULL.  */
12089       exception_name.clear ();
12090       args -= 2;
12091     }
12092
12093   /* Check to see if we have a condition.  */
12094
12095   args = skip_spaces (args);
12096   if (startswith (args, "if")
12097       && (isspace (args[2]) || args[2] == '\0'))
12098     {
12099       args += 2;
12100       args = skip_spaces (args);
12101
12102       if (args[0] == '\0')
12103         error (_("Condition missing after `if' keyword"));
12104       *cond_string = args;
12105
12106       args += strlen (args);
12107     }
12108
12109   /* Check that we do not have any more arguments.  Anything else
12110      is unexpected.  */
12111
12112   if (args[0] != '\0')
12113     error (_("Junk at end of expression"));
12114
12115   if (is_catch_handlers_cmd)
12116     {
12117       /* Catch handling of exceptions.  */
12118       *ex = ada_catch_handlers;
12119       *excep_string = exception_name;
12120     }
12121   else if (exception_name.empty ())
12122     {
12123       /* Catch all exceptions.  */
12124       *ex = ada_catch_exception;
12125       excep_string->clear ();
12126     }
12127   else if (exception_name == "unhandled")
12128     {
12129       /* Catch unhandled exceptions.  */
12130       *ex = ada_catch_exception_unhandled;
12131       excep_string->clear ();
12132     }
12133   else
12134     {
12135       /* Catch a specific exception.  */
12136       *ex = ada_catch_exception;
12137       *excep_string = exception_name;
12138     }
12139 }
12140
12141 /* Return the name of the symbol on which we should break in order to
12142    implement a catchpoint of the EX kind.  */
12143
12144 static const char *
12145 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12146 {
12147   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12148
12149   gdb_assert (data->exception_info != NULL);
12150
12151   switch (ex)
12152     {
12153       case ada_catch_exception:
12154         return (data->exception_info->catch_exception_sym);
12155         break;
12156       case ada_catch_exception_unhandled:
12157         return (data->exception_info->catch_exception_unhandled_sym);
12158         break;
12159       case ada_catch_assert:
12160         return (data->exception_info->catch_assert_sym);
12161         break;
12162       case ada_catch_handlers:
12163         return (data->exception_info->catch_handlers_sym);
12164         break;
12165       default:
12166         internal_error (__FILE__, __LINE__,
12167                         _("unexpected catchpoint kind (%d)"), ex);
12168     }
12169 }
12170
12171 /* Return the breakpoint ops "virtual table" used for catchpoints
12172    of the EX kind.  */
12173
12174 static const struct breakpoint_ops *
12175 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
12176 {
12177   switch (ex)
12178     {
12179       case ada_catch_exception:
12180         return (&catch_exception_breakpoint_ops);
12181         break;
12182       case ada_catch_exception_unhandled:
12183         return (&catch_exception_unhandled_breakpoint_ops);
12184         break;
12185       case ada_catch_assert:
12186         return (&catch_assert_breakpoint_ops);
12187         break;
12188       case ada_catch_handlers:
12189         return (&catch_handlers_breakpoint_ops);
12190         break;
12191       default:
12192         internal_error (__FILE__, __LINE__,
12193                         _("unexpected catchpoint kind (%d)"), ex);
12194     }
12195 }
12196
12197 /* Return the condition that will be used to match the current exception
12198    being raised with the exception that the user wants to catch.  This
12199    assumes that this condition is used when the inferior just triggered
12200    an exception catchpoint.
12201    EX: the type of catchpoints used for catching Ada exceptions.  */
12202
12203 static std::string
12204 ada_exception_catchpoint_cond_string (const char *excep_string,
12205                                       enum ada_exception_catchpoint_kind ex)
12206 {
12207   int i;
12208   bool is_standard_exc = false;
12209   std::string result;
12210
12211   if (ex == ada_catch_handlers)
12212     {
12213       /* For exception handlers catchpoints, the condition string does
12214          not use the same parameter as for the other exceptions.  */
12215       result = ("long_integer (GNAT_GCC_exception_Access"
12216                 "(gcc_exception).all.occurrence.id)");
12217     }
12218   else
12219     result = "long_integer (e)";
12220
12221   /* The standard exceptions are a special case.  They are defined in
12222      runtime units that have been compiled without debugging info; if
12223      EXCEP_STRING is the not-fully-qualified name of a standard
12224      exception (e.g. "constraint_error") then, during the evaluation
12225      of the condition expression, the symbol lookup on this name would
12226      *not* return this standard exception.  The catchpoint condition
12227      may then be set only on user-defined exceptions which have the
12228      same not-fully-qualified name (e.g. my_package.constraint_error).
12229
12230      To avoid this unexcepted behavior, these standard exceptions are
12231      systematically prefixed by "standard".  This means that "catch
12232      exception constraint_error" is rewritten into "catch exception
12233      standard.constraint_error".
12234
12235      If an exception named constraint_error is defined in another package of
12236      the inferior program, then the only way to specify this exception as a
12237      breakpoint condition is to use its fully-qualified named:
12238      e.g. my_package.constraint_error.  */
12239
12240   for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12241     {
12242       if (strcmp (standard_exc [i], excep_string) == 0)
12243         {
12244           is_standard_exc = true;
12245           break;
12246         }
12247     }
12248
12249   result += " = ";
12250
12251   if (is_standard_exc)
12252     string_appendf (result, "long_integer (&standard.%s)", excep_string);
12253   else
12254     string_appendf (result, "long_integer (&%s)", excep_string);
12255
12256   return result;
12257 }
12258
12259 /* Return the symtab_and_line that should be used to insert an exception
12260    catchpoint of the TYPE kind.
12261
12262    ADDR_STRING returns the name of the function where the real
12263    breakpoint that implements the catchpoints is set, depending on the
12264    type of catchpoint we need to create.  */
12265
12266 static struct symtab_and_line
12267 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12268                    std::string *addr_string, const struct breakpoint_ops **ops)
12269 {
12270   const char *sym_name;
12271   struct symbol *sym;
12272
12273   /* First, find out which exception support info to use.  */
12274   ada_exception_support_info_sniffer ();
12275
12276   /* Then lookup the function on which we will break in order to catch
12277      the Ada exceptions requested by the user.  */
12278   sym_name = ada_exception_sym_name (ex);
12279   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12280
12281   if (sym == NULL)
12282     error (_("Catchpoint symbol not found: %s"), sym_name);
12283
12284   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12285     error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12286
12287   /* Set ADDR_STRING.  */
12288   *addr_string = sym_name;
12289
12290   /* Set OPS.  */
12291   *ops = ada_exception_breakpoint_ops (ex);
12292
12293   return find_function_start_sal (sym, 1);
12294 }
12295
12296 /* Create an Ada exception catchpoint.
12297
12298    EX_KIND is the kind of exception catchpoint to be created.
12299
12300    If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12301    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
12302    of the exception to which this catchpoint applies.
12303
12304    COND_STRING, if not empty, is the catchpoint condition.
12305
12306    TEMPFLAG, if nonzero, means that the underlying breakpoint
12307    should be temporary.
12308
12309    FROM_TTY is the usual argument passed to all commands implementations.  */
12310
12311 void
12312 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12313                                  enum ada_exception_catchpoint_kind ex_kind,
12314                                  const std::string &excep_string,
12315                                  const std::string &cond_string,
12316                                  int tempflag,
12317                                  int disabled,
12318                                  int from_tty)
12319 {
12320   std::string addr_string;
12321   const struct breakpoint_ops *ops = NULL;
12322   struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
12323
12324   std::unique_ptr<ada_catchpoint> c (new ada_catchpoint (ex_kind));
12325   init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
12326                                  ops, tempflag, disabled, from_tty);
12327   c->excep_string = excep_string;
12328   create_excep_cond_exprs (c.get (), ex_kind);
12329   if (!cond_string.empty ())
12330     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty, false);
12331   install_breakpoint (0, std::move (c), 1);
12332 }
12333
12334 /* Implement the "catch exception" command.  */
12335
12336 static void
12337 catch_ada_exception_command (const char *arg_entry, int from_tty,
12338                              struct cmd_list_element *command)
12339 {
12340   const char *arg = arg_entry;
12341   struct gdbarch *gdbarch = get_current_arch ();
12342   int tempflag;
12343   enum ada_exception_catchpoint_kind ex_kind;
12344   std::string excep_string;
12345   std::string cond_string;
12346
12347   tempflag = command->context () == CATCH_TEMPORARY;
12348
12349   if (!arg)
12350     arg = "";
12351   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
12352                                      &cond_string);
12353   create_ada_exception_catchpoint (gdbarch, ex_kind,
12354                                    excep_string, cond_string,
12355                                    tempflag, 1 /* enabled */,
12356                                    from_tty);
12357 }
12358
12359 /* Implement the "catch handlers" command.  */
12360
12361 static void
12362 catch_ada_handlers_command (const char *arg_entry, int from_tty,
12363                             struct cmd_list_element *command)
12364 {
12365   const char *arg = arg_entry;
12366   struct gdbarch *gdbarch = get_current_arch ();
12367   int tempflag;
12368   enum ada_exception_catchpoint_kind ex_kind;
12369   std::string excep_string;
12370   std::string cond_string;
12371
12372   tempflag = command->context () == CATCH_TEMPORARY;
12373
12374   if (!arg)
12375     arg = "";
12376   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
12377                                      &cond_string);
12378   create_ada_exception_catchpoint (gdbarch, ex_kind,
12379                                    excep_string, cond_string,
12380                                    tempflag, 1 /* enabled */,
12381                                    from_tty);
12382 }
12383
12384 /* Completion function for the Ada "catch" commands.  */
12385
12386 static void
12387 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
12388                      const char *text, const char *word)
12389 {
12390   std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
12391
12392   for (const ada_exc_info &info : exceptions)
12393     {
12394       if (startswith (info.name, word))
12395         tracker.add_completion (make_unique_xstrdup (info.name));
12396     }
12397 }
12398
12399 /* Split the arguments specified in a "catch assert" command.
12400
12401    ARGS contains the command's arguments (or the empty string if
12402    no arguments were passed).
12403
12404    If ARGS contains a condition, set COND_STRING to that condition
12405    (the memory needs to be deallocated after use).  */
12406
12407 static void
12408 catch_ada_assert_command_split (const char *args, std::string &cond_string)
12409 {
12410   args = skip_spaces (args);
12411
12412   /* Check whether a condition was provided.  */
12413   if (startswith (args, "if")
12414       && (isspace (args[2]) || args[2] == '\0'))
12415     {
12416       args += 2;
12417       args = skip_spaces (args);
12418       if (args[0] == '\0')
12419         error (_("condition missing after `if' keyword"));
12420       cond_string.assign (args);
12421     }
12422
12423   /* Otherwise, there should be no other argument at the end of
12424      the command.  */
12425   else if (args[0] != '\0')
12426     error (_("Junk at end of arguments."));
12427 }
12428
12429 /* Implement the "catch assert" command.  */
12430
12431 static void
12432 catch_assert_command (const char *arg_entry, int from_tty,
12433                       struct cmd_list_element *command)
12434 {
12435   const char *arg = arg_entry;
12436   struct gdbarch *gdbarch = get_current_arch ();
12437   int tempflag;
12438   std::string cond_string;
12439
12440   tempflag = command->context () == CATCH_TEMPORARY;
12441
12442   if (!arg)
12443     arg = "";
12444   catch_ada_assert_command_split (arg, cond_string);
12445   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12446                                    "", cond_string,
12447                                    tempflag, 1 /* enabled */,
12448                                    from_tty);
12449 }
12450
12451 /* Return non-zero if the symbol SYM is an Ada exception object.  */
12452
12453 static int
12454 ada_is_exception_sym (struct symbol *sym)
12455 {
12456   const char *type_name = SYMBOL_TYPE (sym)->name ();
12457
12458   return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12459           && SYMBOL_CLASS (sym) != LOC_BLOCK
12460           && SYMBOL_CLASS (sym) != LOC_CONST
12461           && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12462           && type_name != NULL && strcmp (type_name, "exception") == 0);
12463 }
12464
12465 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12466    Ada exception object.  This matches all exceptions except the ones
12467    defined by the Ada language.  */
12468
12469 static int
12470 ada_is_non_standard_exception_sym (struct symbol *sym)
12471 {
12472   int i;
12473
12474   if (!ada_is_exception_sym (sym))
12475     return 0;
12476
12477   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12478     if (strcmp (sym->linkage_name (), standard_exc[i]) == 0)
12479       return 0;  /* A standard exception.  */
12480
12481   /* Numeric_Error is also a standard exception, so exclude it.
12482      See the STANDARD_EXC description for more details as to why
12483      this exception is not listed in that array.  */
12484   if (strcmp (sym->linkage_name (), "numeric_error") == 0)
12485     return 0;
12486
12487   return 1;
12488 }
12489
12490 /* A helper function for std::sort, comparing two struct ada_exc_info
12491    objects.
12492
12493    The comparison is determined first by exception name, and then
12494    by exception address.  */
12495
12496 bool
12497 ada_exc_info::operator< (const ada_exc_info &other) const
12498 {
12499   int result;
12500
12501   result = strcmp (name, other.name);
12502   if (result < 0)
12503     return true;
12504   if (result == 0 && addr < other.addr)
12505     return true;
12506   return false;
12507 }
12508
12509 bool
12510 ada_exc_info::operator== (const ada_exc_info &other) const
12511 {
12512   return addr == other.addr && strcmp (name, other.name) == 0;
12513 }
12514
12515 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12516    routine, but keeping the first SKIP elements untouched.
12517
12518    All duplicates are also removed.  */
12519
12520 static void
12521 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
12522                                       int skip)
12523 {
12524   std::sort (exceptions->begin () + skip, exceptions->end ());
12525   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
12526                      exceptions->end ());
12527 }
12528
12529 /* Add all exceptions defined by the Ada standard whose name match
12530    a regular expression.
12531
12532    If PREG is not NULL, then this regexp_t object is used to
12533    perform the symbol name matching.  Otherwise, no name-based
12534    filtering is performed.
12535
12536    EXCEPTIONS is a vector of exceptions to which matching exceptions
12537    gets pushed.  */
12538
12539 static void
12540 ada_add_standard_exceptions (compiled_regex *preg,
12541                              std::vector<ada_exc_info> *exceptions)
12542 {
12543   int i;
12544
12545   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12546     {
12547       if (preg == NULL
12548           || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
12549         {
12550           struct bound_minimal_symbol msymbol
12551             = ada_lookup_simple_minsym (standard_exc[i]);
12552
12553           if (msymbol.minsym != NULL)
12554             {
12555               struct ada_exc_info info
12556                 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
12557
12558               exceptions->push_back (info);
12559             }
12560         }
12561     }
12562 }
12563
12564 /* Add all Ada exceptions defined locally and accessible from the given
12565    FRAME.
12566
12567    If PREG is not NULL, then this regexp_t object is used to
12568    perform the symbol name matching.  Otherwise, no name-based
12569    filtering is performed.
12570
12571    EXCEPTIONS is a vector of exceptions to which matching exceptions
12572    gets pushed.  */
12573
12574 static void
12575 ada_add_exceptions_from_frame (compiled_regex *preg,
12576                                struct frame_info *frame,
12577                                std::vector<ada_exc_info> *exceptions)
12578 {
12579   const struct block *block = get_frame_block (frame, 0);
12580
12581   while (block != 0)
12582     {
12583       struct block_iterator iter;
12584       struct symbol *sym;
12585
12586       ALL_BLOCK_SYMBOLS (block, iter, sym)
12587         {
12588           switch (SYMBOL_CLASS (sym))
12589             {
12590             case LOC_TYPEDEF:
12591             case LOC_BLOCK:
12592             case LOC_CONST:
12593               break;
12594             default:
12595               if (ada_is_exception_sym (sym))
12596                 {
12597                   struct ada_exc_info info = {sym->print_name (),
12598                                               SYMBOL_VALUE_ADDRESS (sym)};
12599
12600                   exceptions->push_back (info);
12601                 }
12602             }
12603         }
12604       if (BLOCK_FUNCTION (block) != NULL)
12605         break;
12606       block = BLOCK_SUPERBLOCK (block);
12607     }
12608 }
12609
12610 /* Return true if NAME matches PREG or if PREG is NULL.  */
12611
12612 static bool
12613 name_matches_regex (const char *name, compiled_regex *preg)
12614 {
12615   return (preg == NULL
12616           || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
12617 }
12618
12619 /* Add all exceptions defined globally whose name name match
12620    a regular expression, excluding standard exceptions.
12621
12622    The reason we exclude standard exceptions is that they need
12623    to be handled separately: Standard exceptions are defined inside
12624    a runtime unit which is normally not compiled with debugging info,
12625    and thus usually do not show up in our symbol search.  However,
12626    if the unit was in fact built with debugging info, we need to
12627    exclude them because they would duplicate the entry we found
12628    during the special loop that specifically searches for those
12629    standard exceptions.
12630
12631    If PREG is not NULL, then this regexp_t object is used to
12632    perform the symbol name matching.  Otherwise, no name-based
12633    filtering is performed.
12634
12635    EXCEPTIONS is a vector of exceptions to which matching exceptions
12636    gets pushed.  */
12637
12638 static void
12639 ada_add_global_exceptions (compiled_regex *preg,
12640                            std::vector<ada_exc_info> *exceptions)
12641 {
12642   /* In Ada, the symbol "search name" is a linkage name, whereas the
12643      regular expression used to do the matching refers to the natural
12644      name.  So match against the decoded name.  */
12645   expand_symtabs_matching (NULL,
12646                            lookup_name_info::match_any (),
12647                            [&] (const char *search_name)
12648                            {
12649                              std::string decoded = ada_decode (search_name);
12650                              return name_matches_regex (decoded.c_str (), preg);
12651                            },
12652                            NULL,
12653                            SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
12654                            VARIABLES_DOMAIN);
12655
12656   for (objfile *objfile : current_program_space->objfiles ())
12657     {
12658       for (compunit_symtab *s : objfile->compunits ())
12659         {
12660           const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
12661           int i;
12662
12663           for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
12664             {
12665               const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
12666               struct block_iterator iter;
12667               struct symbol *sym;
12668
12669               ALL_BLOCK_SYMBOLS (b, iter, sym)
12670                 if (ada_is_non_standard_exception_sym (sym)
12671                     && name_matches_regex (sym->natural_name (), preg))
12672                   {
12673                     struct ada_exc_info info
12674                       = {sym->print_name (), SYMBOL_VALUE_ADDRESS (sym)};
12675
12676                     exceptions->push_back (info);
12677                   }
12678             }
12679         }
12680     }
12681 }
12682
12683 /* Implements ada_exceptions_list with the regular expression passed
12684    as a regex_t, rather than a string.
12685
12686    If not NULL, PREG is used to filter out exceptions whose names
12687    do not match.  Otherwise, all exceptions are listed.  */
12688
12689 static std::vector<ada_exc_info>
12690 ada_exceptions_list_1 (compiled_regex *preg)
12691 {
12692   std::vector<ada_exc_info> result;
12693   int prev_len;
12694
12695   /* First, list the known standard exceptions.  These exceptions
12696      need to be handled separately, as they are usually defined in
12697      runtime units that have been compiled without debugging info.  */
12698
12699   ada_add_standard_exceptions (preg, &result);
12700
12701   /* Next, find all exceptions whose scope is local and accessible
12702      from the currently selected frame.  */
12703
12704   if (has_stack_frames ())
12705     {
12706       prev_len = result.size ();
12707       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
12708                                      &result);
12709       if (result.size () > prev_len)
12710         sort_remove_dups_ada_exceptions_list (&result, prev_len);
12711     }
12712
12713   /* Add all exceptions whose scope is global.  */
12714
12715   prev_len = result.size ();
12716   ada_add_global_exceptions (preg, &result);
12717   if (result.size () > prev_len)
12718     sort_remove_dups_ada_exceptions_list (&result, prev_len);
12719
12720   return result;
12721 }
12722
12723 /* Return a vector of ada_exc_info.
12724
12725    If REGEXP is NULL, all exceptions are included in the result.
12726    Otherwise, it should contain a valid regular expression,
12727    and only the exceptions whose names match that regular expression
12728    are included in the result.
12729
12730    The exceptions are sorted in the following order:
12731      - Standard exceptions (defined by the Ada language), in
12732        alphabetical order;
12733      - Exceptions only visible from the current frame, in
12734        alphabetical order;
12735      - Exceptions whose scope is global, in alphabetical order.  */
12736
12737 std::vector<ada_exc_info>
12738 ada_exceptions_list (const char *regexp)
12739 {
12740   if (regexp == NULL)
12741     return ada_exceptions_list_1 (NULL);
12742
12743   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
12744   return ada_exceptions_list_1 (&reg);
12745 }
12746
12747 /* Implement the "info exceptions" command.  */
12748
12749 static void
12750 info_exceptions_command (const char *regexp, int from_tty)
12751 {
12752   struct gdbarch *gdbarch = get_current_arch ();
12753
12754   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
12755
12756   if (regexp != NULL)
12757     printf_filtered
12758       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
12759   else
12760     printf_filtered (_("All defined Ada exceptions:\n"));
12761
12762   for (const ada_exc_info &info : exceptions)
12763     printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
12764 }
12765
12766 \f
12767                                 /* Language vector */
12768
12769 /* symbol_name_matcher_ftype adapter for wild_match.  */
12770
12771 static bool
12772 do_wild_match (const char *symbol_search_name,
12773                const lookup_name_info &lookup_name,
12774                completion_match_result *comp_match_res)
12775 {
12776   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
12777 }
12778
12779 /* symbol_name_matcher_ftype adapter for full_match.  */
12780
12781 static bool
12782 do_full_match (const char *symbol_search_name,
12783                const lookup_name_info &lookup_name,
12784                completion_match_result *comp_match_res)
12785 {
12786   const char *lname = lookup_name.ada ().lookup_name ().c_str ();
12787
12788   /* If both symbols start with "_ada_", just let the loop below
12789      handle the comparison.  However, if only the symbol name starts
12790      with "_ada_", skip the prefix and let the match proceed as
12791      usual.  */
12792   if (startswith (symbol_search_name, "_ada_")
12793       && !startswith (lname, "_ada"))
12794     symbol_search_name += 5;
12795
12796   int uscore_count = 0;
12797   while (*lname != '\0')
12798     {
12799       if (*symbol_search_name != *lname)
12800         {
12801           if (*symbol_search_name == 'B' && uscore_count == 2
12802               && symbol_search_name[1] == '_')
12803             {
12804               symbol_search_name += 2;
12805               while (isdigit (*symbol_search_name))
12806                 ++symbol_search_name;
12807               if (symbol_search_name[0] == '_'
12808                   && symbol_search_name[1] == '_')
12809                 {
12810                   symbol_search_name += 2;
12811                   continue;
12812                 }
12813             }
12814           return false;
12815         }
12816
12817       if (*symbol_search_name == '_')
12818         ++uscore_count;
12819       else
12820         uscore_count = 0;
12821
12822       ++symbol_search_name;
12823       ++lname;
12824     }
12825
12826   return is_name_suffix (symbol_search_name);
12827 }
12828
12829 /* symbol_name_matcher_ftype for exact (verbatim) matches.  */
12830
12831 static bool
12832 do_exact_match (const char *symbol_search_name,
12833                 const lookup_name_info &lookup_name,
12834                 completion_match_result *comp_match_res)
12835 {
12836   return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
12837 }
12838
12839 /* Build the Ada lookup name for LOOKUP_NAME.  */
12840
12841 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
12842 {
12843   gdb::string_view user_name = lookup_name.name ();
12844
12845   if (!user_name.empty () && user_name[0] == '<')
12846     {
12847       if (user_name.back () == '>')
12848         m_encoded_name
12849           = gdb::to_string (user_name.substr (1, user_name.size () - 2));
12850       else
12851         m_encoded_name
12852           = gdb::to_string (user_name.substr (1, user_name.size () - 1));
12853       m_encoded_p = true;
12854       m_verbatim_p = true;
12855       m_wild_match_p = false;
12856       m_standard_p = false;
12857     }
12858   else
12859     {
12860       m_verbatim_p = false;
12861
12862       m_encoded_p = user_name.find ("__") != gdb::string_view::npos;
12863
12864       if (!m_encoded_p)
12865         {
12866           const char *folded = ada_fold_name (user_name);
12867           m_encoded_name = ada_encode_1 (folded, false);
12868           if (m_encoded_name.empty ())
12869             m_encoded_name = gdb::to_string (user_name);
12870         }
12871       else
12872         m_encoded_name = gdb::to_string (user_name);
12873
12874       /* Handle the 'package Standard' special case.  See description
12875          of m_standard_p.  */
12876       if (startswith (m_encoded_name.c_str (), "standard__"))
12877         {
12878           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
12879           m_standard_p = true;
12880         }
12881       else
12882         m_standard_p = false;
12883
12884       /* If the name contains a ".", then the user is entering a fully
12885          qualified entity name, and the match must not be done in wild
12886          mode.  Similarly, if the user wants to complete what looks
12887          like an encoded name, the match must not be done in wild
12888          mode.  Also, in the standard__ special case always do
12889          non-wild matching.  */
12890       m_wild_match_p
12891         = (lookup_name.match_type () != symbol_name_match_type::FULL
12892            && !m_encoded_p
12893            && !m_standard_p
12894            && user_name.find ('.') == std::string::npos);
12895     }
12896 }
12897
12898 /* symbol_name_matcher_ftype method for Ada.  This only handles
12899    completion mode.  */
12900
12901 static bool
12902 ada_symbol_name_matches (const char *symbol_search_name,
12903                          const lookup_name_info &lookup_name,
12904                          completion_match_result *comp_match_res)
12905 {
12906   return lookup_name.ada ().matches (symbol_search_name,
12907                                      lookup_name.match_type (),
12908                                      comp_match_res);
12909 }
12910
12911 /* A name matcher that matches the symbol name exactly, with
12912    strcmp.  */
12913
12914 static bool
12915 literal_symbol_name_matcher (const char *symbol_search_name,
12916                              const lookup_name_info &lookup_name,
12917                              completion_match_result *comp_match_res)
12918 {
12919   gdb::string_view name_view = lookup_name.name ();
12920
12921   if (lookup_name.completion_mode ()
12922       ? (strncmp (symbol_search_name, name_view.data (),
12923                   name_view.size ()) == 0)
12924       : symbol_search_name == name_view)
12925     {
12926       if (comp_match_res != NULL)
12927         comp_match_res->set_match (symbol_search_name);
12928       return true;
12929     }
12930   else
12931     return false;
12932 }
12933
12934 /* Implement the "get_symbol_name_matcher" language_defn method for
12935    Ada.  */
12936
12937 static symbol_name_matcher_ftype *
12938 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
12939 {
12940   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
12941     return literal_symbol_name_matcher;
12942
12943   if (lookup_name.completion_mode ())
12944     return ada_symbol_name_matches;
12945   else
12946     {
12947       if (lookup_name.ada ().wild_match_p ())
12948         return do_wild_match;
12949       else if (lookup_name.ada ().verbatim_p ())
12950         return do_exact_match;
12951       else
12952         return do_full_match;
12953     }
12954 }
12955
12956 /* Class representing the Ada language.  */
12957
12958 class ada_language : public language_defn
12959 {
12960 public:
12961   ada_language ()
12962     : language_defn (language_ada)
12963   { /* Nothing.  */ }
12964
12965   /* See language.h.  */
12966
12967   const char *name () const override
12968   { return "ada"; }
12969
12970   /* See language.h.  */
12971
12972   const char *natural_name () const override
12973   { return "Ada"; }
12974
12975   /* See language.h.  */
12976
12977   const std::vector<const char *> &filename_extensions () const override
12978   {
12979     static const std::vector<const char *> extensions
12980       = { ".adb", ".ads", ".a", ".ada", ".dg" };
12981     return extensions;
12982   }
12983
12984   /* Print an array element index using the Ada syntax.  */
12985
12986   void print_array_index (struct type *index_type,
12987                           LONGEST index,
12988                           struct ui_file *stream,
12989                           const value_print_options *options) const override
12990   {
12991     struct value *index_value = val_atr (index_type, index);
12992
12993     value_print (index_value, stream, options);
12994     fprintf_filtered (stream, " => ");
12995   }
12996
12997   /* Implement the "read_var_value" language_defn method for Ada.  */
12998
12999   struct value *read_var_value (struct symbol *var,
13000                                 const struct block *var_block,
13001                                 struct frame_info *frame) const override
13002   {
13003     /* The only case where default_read_var_value is not sufficient
13004        is when VAR is a renaming...  */
13005     if (frame != nullptr)
13006       {
13007         const struct block *frame_block = get_frame_block (frame, NULL);
13008         if (frame_block != nullptr && ada_is_renaming_symbol (var))
13009           return ada_read_renaming_var_value (var, frame_block);
13010       }
13011
13012     /* This is a typical case where we expect the default_read_var_value
13013        function to work.  */
13014     return language_defn::read_var_value (var, var_block, frame);
13015   }
13016
13017   /* See language.h.  */
13018   virtual bool symbol_printing_suppressed (struct symbol *symbol) const override
13019   {
13020     return symbol->artificial;
13021   }
13022
13023   /* See language.h.  */
13024   void language_arch_info (struct gdbarch *gdbarch,
13025                            struct language_arch_info *lai) const override
13026   {
13027     const struct builtin_type *builtin = builtin_type (gdbarch);
13028
13029     /* Helper function to allow shorter lines below.  */
13030     auto add = [&] (struct type *t)
13031     {
13032       lai->add_primitive_type (t);
13033     };
13034
13035     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13036                             0, "integer"));
13037     add (arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13038                             0, "long_integer"));
13039     add (arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13040                             0, "short_integer"));
13041     struct type *char_type = arch_character_type (gdbarch, TARGET_CHAR_BIT,
13042                                                   0, "character");
13043     lai->set_string_char_type (char_type);
13044     add (char_type);
13045     add (arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13046                           "float", gdbarch_float_format (gdbarch)));
13047     add (arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13048                           "long_float", gdbarch_double_format (gdbarch)));
13049     add (arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13050                             0, "long_long_integer"));
13051     add (arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13052                           "long_long_float",
13053                           gdbarch_long_double_format (gdbarch)));
13054     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13055                             0, "natural"));
13056     add (arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13057                             0, "positive"));
13058     add (builtin->builtin_void);
13059
13060     struct type *system_addr_ptr
13061       = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13062                                         "void"));
13063     system_addr_ptr->set_name ("system__address");
13064     add (system_addr_ptr);
13065
13066     /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13067        type.  This is a signed integral type whose size is the same as
13068        the size of addresses.  */
13069     unsigned int addr_length = TYPE_LENGTH (system_addr_ptr);
13070     add (arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13071                             "storage_offset"));
13072
13073     lai->set_bool_type (builtin->builtin_bool);
13074   }
13075
13076   /* See language.h.  */
13077
13078   bool iterate_over_symbols
13079         (const struct block *block, const lookup_name_info &name,
13080          domain_enum domain,
13081          gdb::function_view<symbol_found_callback_ftype> callback) const override
13082   {
13083     std::vector<struct block_symbol> results
13084       = ada_lookup_symbol_list_worker (name, block, domain, 0);
13085     for (block_symbol &sym : results)
13086       {
13087         if (!callback (&sym))
13088           return false;
13089       }
13090
13091     return true;
13092   }
13093
13094   /* See language.h.  */
13095   bool sniff_from_mangled_name
13096        (const char *mangled,
13097         gdb::unique_xmalloc_ptr<char> *out) const override
13098   {
13099     std::string demangled = ada_decode (mangled);
13100
13101     *out = NULL;
13102
13103     if (demangled != mangled && demangled[0] != '<')
13104       {
13105         /* Set the gsymbol language to Ada, but still return 0.
13106            Two reasons for that:
13107
13108            1. For Ada, we prefer computing the symbol's decoded name
13109            on the fly rather than pre-compute it, in order to save
13110            memory (Ada projects are typically very large).
13111
13112            2. There are some areas in the definition of the GNAT
13113            encoding where, with a bit of bad luck, we might be able
13114            to decode a non-Ada symbol, generating an incorrect
13115            demangled name (Eg: names ending with "TB" for instance
13116            are identified as task bodies and so stripped from
13117            the decoded name returned).
13118
13119            Returning true, here, but not setting *DEMANGLED, helps us get
13120            a little bit of the best of both worlds.  Because we're last,
13121            we should not affect any of the other languages that were
13122            able to demangle the symbol before us; we get to correctly
13123            tag Ada symbols as such; and even if we incorrectly tagged a
13124            non-Ada symbol, which should be rare, any routing through the
13125            Ada language should be transparent (Ada tries to behave much
13126            like C/C++ with non-Ada symbols).  */
13127         return true;
13128       }
13129
13130     return false;
13131   }
13132
13133   /* See language.h.  */
13134
13135   gdb::unique_xmalloc_ptr<char> demangle_symbol (const char *mangled,
13136                                                  int options) const override
13137   {
13138     return make_unique_xstrdup (ada_decode (mangled).c_str ());
13139   }
13140
13141   /* See language.h.  */
13142
13143   void print_type (struct type *type, const char *varstring,
13144                    struct ui_file *stream, int show, int level,
13145                    const struct type_print_options *flags) const override
13146   {
13147     ada_print_type (type, varstring, stream, show, level, flags);
13148   }
13149
13150   /* See language.h.  */
13151
13152   const char *word_break_characters (void) const override
13153   {
13154     return ada_completer_word_break_characters;
13155   }
13156
13157   /* See language.h.  */
13158
13159   void collect_symbol_completion_matches (completion_tracker &tracker,
13160                                           complete_symbol_mode mode,
13161                                           symbol_name_match_type name_match_type,
13162                                           const char *text, const char *word,
13163                                           enum type_code code) const override
13164   {
13165     struct symbol *sym;
13166     const struct block *b, *surrounding_static_block = 0;
13167     struct block_iterator iter;
13168
13169     gdb_assert (code == TYPE_CODE_UNDEF);
13170
13171     lookup_name_info lookup_name (text, name_match_type, true);
13172
13173     /* First, look at the partial symtab symbols.  */
13174     expand_symtabs_matching (NULL,
13175                              lookup_name,
13176                              NULL,
13177                              NULL,
13178                              SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
13179                              ALL_DOMAIN);
13180
13181     /* At this point scan through the misc symbol vectors and add each
13182        symbol you find to the list.  Eventually we want to ignore
13183        anything that isn't a text symbol (everything else will be
13184        handled by the psymtab code above).  */
13185
13186     for (objfile *objfile : current_program_space->objfiles ())
13187       {
13188         for (minimal_symbol *msymbol : objfile->msymbols ())
13189           {
13190             QUIT;
13191
13192             if (completion_skip_symbol (mode, msymbol))
13193               continue;
13194
13195             language symbol_language = msymbol->language ();
13196
13197             /* Ada minimal symbols won't have their language set to Ada.  If
13198                we let completion_list_add_name compare using the
13199                default/C-like matcher, then when completing e.g., symbols in a
13200                package named "pck", we'd match internal Ada symbols like
13201                "pckS", which are invalid in an Ada expression, unless you wrap
13202                them in '<' '>' to request a verbatim match.
13203
13204                Unfortunately, some Ada encoded names successfully demangle as
13205                C++ symbols (using an old mangling scheme), such as "name__2Xn"
13206                -> "Xn::name(void)" and thus some Ada minimal symbols end up
13207                with the wrong language set.  Paper over that issue here.  */
13208             if (symbol_language == language_auto
13209                 || symbol_language == language_cplus)
13210               symbol_language = language_ada;
13211
13212             completion_list_add_name (tracker,
13213                                       symbol_language,
13214                                       msymbol->linkage_name (),
13215                                       lookup_name, text, word);
13216           }
13217       }
13218
13219     /* Search upwards from currently selected frame (so that we can
13220        complete on local vars.  */
13221
13222     for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
13223       {
13224         if (!BLOCK_SUPERBLOCK (b))
13225           surrounding_static_block = b;   /* For elmin of dups */
13226
13227         ALL_BLOCK_SYMBOLS (b, iter, sym)
13228           {
13229             if (completion_skip_symbol (mode, sym))
13230               continue;
13231
13232             completion_list_add_name (tracker,
13233                                       sym->language (),
13234                                       sym->linkage_name (),
13235                                       lookup_name, text, word);
13236           }
13237       }
13238
13239     /* Go through the symtabs and check the externs and statics for
13240        symbols which match.  */
13241
13242     for (objfile *objfile : current_program_space->objfiles ())
13243       {
13244         for (compunit_symtab *s : objfile->compunits ())
13245           {
13246             QUIT;
13247             b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
13248             ALL_BLOCK_SYMBOLS (b, iter, sym)
13249               {
13250                 if (completion_skip_symbol (mode, sym))
13251                   continue;
13252
13253                 completion_list_add_name (tracker,
13254                                           sym->language (),
13255                                           sym->linkage_name (),
13256                                           lookup_name, text, word);
13257               }
13258           }
13259       }
13260
13261     for (objfile *objfile : current_program_space->objfiles ())
13262       {
13263         for (compunit_symtab *s : objfile->compunits ())
13264           {
13265             QUIT;
13266             b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
13267             /* Don't do this block twice.  */
13268             if (b == surrounding_static_block)
13269               continue;
13270             ALL_BLOCK_SYMBOLS (b, iter, sym)
13271               {
13272                 if (completion_skip_symbol (mode, sym))
13273                   continue;
13274
13275                 completion_list_add_name (tracker,
13276                                           sym->language (),
13277                                           sym->linkage_name (),
13278                                           lookup_name, text, word);
13279               }
13280           }
13281       }
13282   }
13283
13284   /* See language.h.  */
13285
13286   gdb::unique_xmalloc_ptr<char> watch_location_expression
13287         (struct type *type, CORE_ADDR addr) const override
13288   {
13289     type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
13290     std::string name = type_to_string (type);
13291     return gdb::unique_xmalloc_ptr<char>
13292       (xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr)));
13293   }
13294
13295   /* See language.h.  */
13296
13297   void value_print (struct value *val, struct ui_file *stream,
13298                     const struct value_print_options *options) const override
13299   {
13300     return ada_value_print (val, stream, options);
13301   }
13302
13303   /* See language.h.  */
13304
13305   void value_print_inner
13306         (struct value *val, struct ui_file *stream, int recurse,
13307          const struct value_print_options *options) const override
13308   {
13309     return ada_value_print_inner (val, stream, recurse, options);
13310   }
13311
13312   /* See language.h.  */
13313
13314   struct block_symbol lookup_symbol_nonlocal
13315         (const char *name, const struct block *block,
13316          const domain_enum domain) const override
13317   {
13318     struct block_symbol sym;
13319
13320     sym = ada_lookup_symbol (name, block_static_block (block), domain);
13321     if (sym.symbol != NULL)
13322       return sym;
13323
13324     /* If we haven't found a match at this point, try the primitive
13325        types.  In other languages, this search is performed before
13326        searching for global symbols in order to short-circuit that
13327        global-symbol search if it happens that the name corresponds
13328        to a primitive type.  But we cannot do the same in Ada, because
13329        it is perfectly legitimate for a program to declare a type which
13330        has the same name as a standard type.  If looking up a type in
13331        that situation, we have traditionally ignored the primitive type
13332        in favor of user-defined types.  This is why, unlike most other
13333        languages, we search the primitive types this late and only after
13334        having searched the global symbols without success.  */
13335
13336     if (domain == VAR_DOMAIN)
13337       {
13338         struct gdbarch *gdbarch;
13339
13340         if (block == NULL)
13341           gdbarch = target_gdbarch ();
13342         else
13343           gdbarch = block_gdbarch (block);
13344         sym.symbol
13345           = language_lookup_primitive_type_as_symbol (this, gdbarch, name);
13346         if (sym.symbol != NULL)
13347           return sym;
13348       }
13349
13350     return {};
13351   }
13352
13353   /* See language.h.  */
13354
13355   int parser (struct parser_state *ps) const override
13356   {
13357     warnings_issued = 0;
13358     return ada_parse (ps);
13359   }
13360
13361   /* See language.h.  */
13362
13363   void emitchar (int ch, struct type *chtype,
13364                  struct ui_file *stream, int quoter) const override
13365   {
13366     ada_emit_char (ch, chtype, stream, quoter, 1);
13367   }
13368
13369   /* See language.h.  */
13370
13371   void printchar (int ch, struct type *chtype,
13372                   struct ui_file *stream) const override
13373   {
13374     ada_printchar (ch, chtype, stream);
13375   }
13376
13377   /* See language.h.  */
13378
13379   void printstr (struct ui_file *stream, struct type *elttype,
13380                  const gdb_byte *string, unsigned int length,
13381                  const char *encoding, int force_ellipses,
13382                  const struct value_print_options *options) const override
13383   {
13384     ada_printstr (stream, elttype, string, length, encoding,
13385                   force_ellipses, options);
13386   }
13387
13388   /* See language.h.  */
13389
13390   void print_typedef (struct type *type, struct symbol *new_symbol,
13391                       struct ui_file *stream) const override
13392   {
13393     ada_print_typedef (type, new_symbol, stream);
13394   }
13395
13396   /* See language.h.  */
13397
13398   bool is_string_type_p (struct type *type) const override
13399   {
13400     return ada_is_string_type (type);
13401   }
13402
13403   /* See language.h.  */
13404
13405   const char *struct_too_deep_ellipsis () const override
13406   { return "(...)"; }
13407
13408   /* See language.h.  */
13409
13410   bool c_style_arrays_p () const override
13411   { return false; }
13412
13413   /* See language.h.  */
13414
13415   bool store_sym_names_in_linkage_form_p () const override
13416   { return true; }
13417
13418   /* See language.h.  */
13419
13420   const struct lang_varobj_ops *varobj_ops () const override
13421   { return &ada_varobj_ops; }
13422
13423 protected:
13424   /* See language.h.  */
13425
13426   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
13427         (const lookup_name_info &lookup_name) const override
13428   {
13429     return ada_get_symbol_name_matcher (lookup_name);
13430   }
13431 };
13432
13433 /* Single instance of the Ada language class.  */
13434
13435 static ada_language ada_language_defn;
13436
13437 /* Command-list for the "set/show ada" prefix command.  */
13438 static struct cmd_list_element *set_ada_list;
13439 static struct cmd_list_element *show_ada_list;
13440
13441 static void
13442 initialize_ada_catchpoint_ops (void)
13443 {
13444   struct breakpoint_ops *ops;
13445
13446   initialize_breakpoint_ops ();
13447
13448   ops = &catch_exception_breakpoint_ops;
13449   *ops = bkpt_breakpoint_ops;
13450   ops->allocate_location = allocate_location_exception;
13451   ops->re_set = re_set_exception;
13452   ops->check_status = check_status_exception;
13453   ops->print_it = print_it_exception;
13454   ops->print_one = print_one_exception;
13455   ops->print_mention = print_mention_exception;
13456   ops->print_recreate = print_recreate_exception;
13457
13458   ops = &catch_exception_unhandled_breakpoint_ops;
13459   *ops = bkpt_breakpoint_ops;
13460   ops->allocate_location = allocate_location_exception;
13461   ops->re_set = re_set_exception;
13462   ops->check_status = check_status_exception;
13463   ops->print_it = print_it_exception;
13464   ops->print_one = print_one_exception;
13465   ops->print_mention = print_mention_exception;
13466   ops->print_recreate = print_recreate_exception;
13467
13468   ops = &catch_assert_breakpoint_ops;
13469   *ops = bkpt_breakpoint_ops;
13470   ops->allocate_location = allocate_location_exception;
13471   ops->re_set = re_set_exception;
13472   ops->check_status = check_status_exception;
13473   ops->print_it = print_it_exception;
13474   ops->print_one = print_one_exception;
13475   ops->print_mention = print_mention_exception;
13476   ops->print_recreate = print_recreate_exception;
13477
13478   ops = &catch_handlers_breakpoint_ops;
13479   *ops = bkpt_breakpoint_ops;
13480   ops->allocate_location = allocate_location_exception;
13481   ops->re_set = re_set_exception;
13482   ops->check_status = check_status_exception;
13483   ops->print_it = print_it_exception;
13484   ops->print_one = print_one_exception;
13485   ops->print_mention = print_mention_exception;
13486   ops->print_recreate = print_recreate_exception;
13487 }
13488
13489 /* This module's 'new_objfile' observer.  */
13490
13491 static void
13492 ada_new_objfile_observer (struct objfile *objfile)
13493 {
13494   ada_clear_symbol_cache ();
13495 }
13496
13497 /* This module's 'free_objfile' observer.  */
13498
13499 static void
13500 ada_free_objfile_observer (struct objfile *objfile)
13501 {
13502   ada_clear_symbol_cache ();
13503 }
13504
13505 void _initialize_ada_language ();
13506 void
13507 _initialize_ada_language ()
13508 {
13509   initialize_ada_catchpoint_ops ();
13510
13511   add_basic_prefix_cmd ("ada", no_class,
13512                         _("Prefix command for changing Ada-specific settings."),
13513                         &set_ada_list, 0, &setlist);
13514
13515   add_show_prefix_cmd ("ada", no_class,
13516                        _("Generic command for showing Ada-specific settings."),
13517                        &show_ada_list, 0, &showlist);
13518
13519   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13520                            &trust_pad_over_xvs, _("\
13521 Enable or disable an optimization trusting PAD types over XVS types."), _("\
13522 Show whether an optimization trusting PAD types over XVS types is activated."),
13523                            _("\
13524 This is related to the encoding used by the GNAT compiler.  The debugger\n\
13525 should normally trust the contents of PAD types, but certain older versions\n\
13526 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13527 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
13528 work around this bug.  It is always safe to turn this option \"off\", but\n\
13529 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13530 this option to \"off\" unless necessary."),
13531                             NULL, NULL, &set_ada_list, &show_ada_list);
13532
13533   add_setshow_boolean_cmd ("print-signatures", class_vars,
13534                            &print_signatures, _("\
13535 Enable or disable the output of formal and return types for functions in the \
13536 overloads selection menu."), _("\
13537 Show whether the output of formal and return types for functions in the \
13538 overloads selection menu is activated."),
13539                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
13540
13541   add_catch_command ("exception", _("\
13542 Catch Ada exceptions, when raised.\n\
13543 Usage: catch exception [ARG] [if CONDITION]\n\
13544 Without any argument, stop when any Ada exception is raised.\n\
13545 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
13546 being raised does not have a handler (and will therefore lead to the task's\n\
13547 termination).\n\
13548 Otherwise, the catchpoint only stops when the name of the exception being\n\
13549 raised is the same as ARG.\n\
13550 CONDITION is a boolean expression that is evaluated to see whether the\n\
13551 exception should cause a stop."),
13552                      catch_ada_exception_command,
13553                      catch_ada_completer,
13554                      CATCH_PERMANENT,
13555                      CATCH_TEMPORARY);
13556
13557   add_catch_command ("handlers", _("\
13558 Catch Ada exceptions, when handled.\n\
13559 Usage: catch handlers [ARG] [if CONDITION]\n\
13560 Without any argument, stop when any Ada exception is handled.\n\
13561 With an argument, catch only exceptions with the given name.\n\
13562 CONDITION is a boolean expression that is evaluated to see whether the\n\
13563 exception should cause a stop."),
13564                      catch_ada_handlers_command,
13565                      catch_ada_completer,
13566                      CATCH_PERMANENT,
13567                      CATCH_TEMPORARY);
13568   add_catch_command ("assert", _("\
13569 Catch failed Ada assertions, when raised.\n\
13570 Usage: catch assert [if CONDITION]\n\
13571 CONDITION is a boolean expression that is evaluated to see whether the\n\
13572 exception should cause a stop."),
13573                      catch_assert_command,
13574                      NULL,
13575                      CATCH_PERMANENT,
13576                      CATCH_TEMPORARY);
13577
13578   add_info ("exceptions", info_exceptions_command,
13579             _("\
13580 List all Ada exception names.\n\
13581 Usage: info exceptions [REGEXP]\n\
13582 If a regular expression is passed as an argument, only those matching\n\
13583 the regular expression are listed."));
13584
13585   add_basic_prefix_cmd ("ada", class_maintenance,
13586                         _("Set Ada maintenance-related variables."),
13587                         &maint_set_ada_cmdlist,
13588                         0/*allow-unknown*/, &maintenance_set_cmdlist);
13589
13590   add_show_prefix_cmd ("ada", class_maintenance,
13591                        _("Show Ada maintenance-related variables."),
13592                        &maint_show_ada_cmdlist,
13593                        0/*allow-unknown*/, &maintenance_show_cmdlist);
13594
13595   add_setshow_boolean_cmd
13596     ("ignore-descriptive-types", class_maintenance,
13597      &ada_ignore_descriptive_types_p,
13598      _("Set whether descriptive types generated by GNAT should be ignored."),
13599      _("Show whether descriptive types generated by GNAT should be ignored."),
13600      _("\
13601 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13602 DWARF attribute."),
13603      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
13604
13605   decoded_names_store = htab_create_alloc (256, htab_hash_string,
13606                                            htab_eq_string,
13607                                            NULL, xcalloc, xfree);
13608
13609   /* The ada-lang observers.  */
13610   gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
13611   gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
13612   gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");
13613 }
This page took 0.791774 seconds and 4 git commands to generate.