]> Git Repo - binutils.git/blob - gdb/ada-lang.c
Update copyright year range in all GDB files.
[binutils.git] / gdb / ada-lang.c
1 /* Ada language support routines for GDB, the GNU debugger.
2
3    Copyright (C) 1992-2020 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
53 #include "value.h"
54 #include "mi/mi-common.h"
55 #include "arch-utils.h"
56 #include "cli/cli-utils.h"
57 #include "gdbsupport/function-view.h"
58 #include "gdbsupport/byte-vector.h"
59 #include <algorithm>
60
61 /* Define whether or not the C operator '/' truncates towards zero for
62    differently signed operands (truncation direction is undefined in C).
63    Copied from valarith.c.  */
64
65 #ifndef TRUNCATION_TOWARDS_ZERO
66 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
67 #endif
68
69 static struct type *desc_base_type (struct type *);
70
71 static struct type *desc_bounds_type (struct type *);
72
73 static struct value *desc_bounds (struct value *);
74
75 static int fat_pntr_bounds_bitpos (struct type *);
76
77 static int fat_pntr_bounds_bitsize (struct type *);
78
79 static struct type *desc_data_target_type (struct type *);
80
81 static struct value *desc_data (struct value *);
82
83 static int fat_pntr_data_bitpos (struct type *);
84
85 static int fat_pntr_data_bitsize (struct type *);
86
87 static struct value *desc_one_bound (struct value *, int, int);
88
89 static int desc_bound_bitpos (struct type *, int, int);
90
91 static int desc_bound_bitsize (struct type *, int, int);
92
93 static struct type *desc_index_type (struct type *, int);
94
95 static int desc_arity (struct type *);
96
97 static int ada_type_match (struct type *, struct type *, int);
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 (struct obstack *,
104                                    const struct block *,
105                                    const lookup_name_info &lookup_name,
106                                    domain_enum, struct objfile *);
107
108 static void ada_add_all_symbols (struct obstack *, const struct block *,
109                                  const lookup_name_info &lookup_name,
110                                  domain_enum, int, int *);
111
112 static int is_nonfunction (struct block_symbol *, int);
113
114 static void add_defn_to_vec (struct obstack *, struct symbol *,
115                              const struct block *);
116
117 static int num_defns_collected (struct obstack *);
118
119 static struct block_symbol *defns_collected (struct obstack *, int);
120
121 static struct value *resolve_subexp (expression_up *, int *, int,
122                                      struct type *, int,
123                                      innermost_block_tracker *);
124
125 static void replace_operator_with_call (expression_up *, int, int, int,
126                                         struct symbol *, const struct block *);
127
128 static int possible_user_operator_p (enum exp_opcode, struct value **);
129
130 static const char *ada_op_name (enum exp_opcode);
131
132 static const char *ada_decoded_op_name (enum exp_opcode);
133
134 static int numeric_type_p (struct type *);
135
136 static int integer_type_p (struct type *);
137
138 static int scalar_type_p (struct type *);
139
140 static int discrete_type_p (struct type *);
141
142 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
143                                                 int, int);
144
145 static struct value *evaluate_subexp_type (struct expression *, int *);
146
147 static struct type *ada_find_parallel_type_with_name (struct type *,
148                                                       const char *);
149
150 static int is_dynamic_field (struct type *, int);
151
152 static struct type *to_fixed_variant_branch_type (struct type *,
153                                                   const gdb_byte *,
154                                                   CORE_ADDR, struct value *);
155
156 static struct type *to_fixed_array_type (struct type *, struct value *, int);
157
158 static struct type *to_fixed_range_type (struct type *, struct value *);
159
160 static struct type *to_static_fixed_type (struct type *);
161 static struct type *static_unwrap_type (struct type *type);
162
163 static struct value *unwrap_value (struct value *);
164
165 static struct type *constrained_packed_array_type (struct type *, long *);
166
167 static struct type *decode_constrained_packed_array_type (struct type *);
168
169 static long decode_packed_array_bitsize (struct type *);
170
171 static struct value *decode_constrained_packed_array (struct value *);
172
173 static int ada_is_packed_array_type  (struct type *);
174
175 static int ada_is_unconstrained_packed_array_type (struct type *);
176
177 static struct value *value_subscript_packed (struct value *, int,
178                                              struct value **);
179
180 static struct value *coerce_unspec_val_to_type (struct value *,
181                                                 struct type *);
182
183 static int lesseq_defined_than (struct symbol *, struct symbol *);
184
185 static int equiv_types (struct type *, struct type *);
186
187 static int is_name_suffix (const char *);
188
189 static int advance_wild_match (const char **, const char *, int);
190
191 static bool wild_match (const char *name, const char *patn);
192
193 static struct value *ada_coerce_ref (struct value *);
194
195 static LONGEST pos_atr (struct value *);
196
197 static struct value *value_pos_atr (struct type *, struct value *);
198
199 static struct value *value_val_atr (struct type *, struct value *);
200
201 static struct symbol *standard_lookup (const char *, const struct block *,
202                                        domain_enum);
203
204 static struct value *ada_search_struct_field (const char *, struct value *, int,
205                                               struct type *);
206
207 static struct value *ada_value_primitive_field (struct value *, int, int,
208                                                 struct type *);
209
210 static int find_struct_field (const char *, struct type *, int,
211                               struct type **, int *, int *, int *, int *);
212
213 static int ada_resolve_function (struct block_symbol *, int,
214                                  struct value **, int, const char *,
215                                  struct type *, int);
216
217 static int ada_is_direct_array_type (struct type *);
218
219 static void ada_language_arch_info (struct gdbarch *,
220                                     struct language_arch_info *);
221
222 static struct value *ada_index_struct_field (int, struct value *, int,
223                                              struct type *);
224
225 static struct value *assign_aggregate (struct value *, struct value *, 
226                                        struct expression *,
227                                        int *, enum noside);
228
229 static void aggregate_assign_from_choices (struct value *, struct value *, 
230                                            struct expression *,
231                                            int *, LONGEST *, int *,
232                                            int, LONGEST, LONGEST);
233
234 static void aggregate_assign_positional (struct value *, struct value *,
235                                          struct expression *,
236                                          int *, LONGEST *, int *, int,
237                                          LONGEST, LONGEST);
238
239
240 static void aggregate_assign_others (struct value *, struct value *,
241                                      struct expression *,
242                                      int *, LONGEST *, int, LONGEST, LONGEST);
243
244
245 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
246
247
248 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
249                                           int *, enum noside);
250
251 static void ada_forward_operator_length (struct expression *, int, int *,
252                                          int *);
253
254 static struct type *ada_find_any_type (const char *name);
255
256 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
257   (const lookup_name_info &lookup_name);
258
259 \f
260
261 /* The result of a symbol lookup to be stored in our symbol cache.  */
262
263 struct cache_entry
264 {
265   /* The name used to perform the lookup.  */
266   const char *name;
267   /* The namespace used during the lookup.  */
268   domain_enum domain;
269   /* The symbol returned by the lookup, or NULL if no matching symbol
270      was found.  */
271   struct symbol *sym;
272   /* The block where the symbol was found, or NULL if no matching
273      symbol was found.  */
274   const struct block *block;
275   /* A pointer to the next entry with the same hash.  */
276   struct cache_entry *next;
277 };
278
279 /* The Ada symbol cache, used to store the result of Ada-mode symbol
280    lookups in the course of executing the user's commands.
281
282    The cache is implemented using a simple, fixed-sized hash.
283    The size is fixed on the grounds that there are not likely to be
284    all that many symbols looked up during any given session, regardless
285    of the size of the symbol table.  If we decide to go to a resizable
286    table, let's just use the stuff from libiberty instead.  */
287
288 #define HASH_SIZE 1009
289
290 struct ada_symbol_cache
291 {
292   /* An obstack used to store the entries in our cache.  */
293   struct obstack cache_space;
294
295   /* The root of the hash table used to implement our symbol cache.  */
296   struct cache_entry *root[HASH_SIZE];
297 };
298
299 static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
300
301 /* Maximum-sized dynamic type.  */
302 static unsigned int varsize_limit;
303
304 static const char ada_completer_word_break_characters[] =
305 #ifdef VMS
306   " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
307 #else
308   " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
309 #endif
310
311 /* The name of the symbol to use to get the name of the main subprogram.  */
312 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
313   = "__gnat_ada_main_program_name";
314
315 /* Limit on the number of warnings to raise per expression evaluation.  */
316 static int warning_limit = 2;
317
318 /* Number of warning messages issued; reset to 0 by cleanups after
319    expression evaluation.  */
320 static int warnings_issued = 0;
321
322 static const char *known_runtime_file_name_patterns[] = {
323   ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
324 };
325
326 static const char *known_auxiliary_function_name_patterns[] = {
327   ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
328 };
329
330 /* Maintenance-related settings for this module.  */
331
332 static struct cmd_list_element *maint_set_ada_cmdlist;
333 static struct cmd_list_element *maint_show_ada_cmdlist;
334
335 /* Implement the "maintenance set ada" (prefix) command.  */
336
337 static void
338 maint_set_ada_cmd (const char *args, int from_tty)
339 {
340   help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
341              gdb_stdout);
342 }
343
344 /* Implement the "maintenance show ada" (prefix) command.  */
345
346 static void
347 maint_show_ada_cmd (const char *args, int from_tty)
348 {
349   cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
350 }
351
352 /* The "maintenance ada set/show ignore-descriptive-type" value.  */
353
354 static bool ada_ignore_descriptive_types_p = false;
355
356                         /* Inferior-specific data.  */
357
358 /* Per-inferior data for this module.  */
359
360 struct ada_inferior_data
361 {
362   /* The ada__tags__type_specific_data type, which is used when decoding
363      tagged types.  With older versions of GNAT, this type was directly
364      accessible through a component ("tsd") in the object tag.  But this
365      is no longer the case, so we cache it for each inferior.  */
366   struct type *tsd_type = nullptr;
367
368   /* The exception_support_info data.  This data is used to determine
369      how to implement support for Ada exception catchpoints in a given
370      inferior.  */
371   const struct exception_support_info *exception_info = nullptr;
372 };
373
374 /* Our key to this module's inferior data.  */
375 static const struct inferior_key<ada_inferior_data> ada_inferior_data;
376
377 /* Return our inferior data for the given inferior (INF).
378
379    This function always returns a valid pointer to an allocated
380    ada_inferior_data structure.  If INF's inferior data has not
381    been previously set, this functions creates a new one with all
382    fields set to zero, sets INF's inferior to it, and then returns
383    a pointer to that newly allocated ada_inferior_data.  */
384
385 static struct ada_inferior_data *
386 get_ada_inferior_data (struct inferior *inf)
387 {
388   struct ada_inferior_data *data;
389
390   data = ada_inferior_data.get (inf);
391   if (data == NULL)
392     data = ada_inferior_data.emplace (inf);
393
394   return data;
395 }
396
397 /* Perform all necessary cleanups regarding our module's inferior data
398    that is required after the inferior INF just exited.  */
399
400 static void
401 ada_inferior_exit (struct inferior *inf)
402 {
403   ada_inferior_data.clear (inf);
404 }
405
406
407                         /* program-space-specific data.  */
408
409 /* This module's per-program-space data.  */
410 struct ada_pspace_data
411 {
412   ~ada_pspace_data ()
413   {
414     if (sym_cache != NULL)
415       ada_free_symbol_cache (sym_cache);
416   }
417
418   /* The Ada symbol cache.  */
419   struct ada_symbol_cache *sym_cache = nullptr;
420 };
421
422 /* Key to our per-program-space data.  */
423 static const struct program_space_key<ada_pspace_data> ada_pspace_data_handle;
424
425 /* Return this module's data for the given program space (PSPACE).
426    If not is found, add a zero'ed one now.
427
428    This function always returns a valid object.  */
429
430 static struct ada_pspace_data *
431 get_ada_pspace_data (struct program_space *pspace)
432 {
433   struct ada_pspace_data *data;
434
435   data = ada_pspace_data_handle.get (pspace);
436   if (data == NULL)
437     data = ada_pspace_data_handle.emplace (pspace);
438
439   return data;
440 }
441
442                         /* Utilities */
443
444 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
445    all typedef layers have been peeled.  Otherwise, return TYPE.
446
447    Normally, we really expect a typedef type to only have 1 typedef layer.
448    In other words, we really expect the target type of a typedef type to be
449    a non-typedef type.  This is particularly true for Ada units, because
450    the language does not have a typedef vs not-typedef distinction.
451    In that respect, the Ada compiler has been trying to eliminate as many
452    typedef definitions in the debugging information, since they generally
453    do not bring any extra information (we still use typedef under certain
454    circumstances related mostly to the GNAT encoding).
455
456    Unfortunately, we have seen situations where the debugging information
457    generated by the compiler leads to such multiple typedef layers.  For
458    instance, consider the following example with stabs:
459
460      .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
461      .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
462
463    This is an error in the debugging information which causes type
464    pck__float_array___XUP to be defined twice, and the second time,
465    it is defined as a typedef of a typedef.
466
467    This is on the fringe of legality as far as debugging information is
468    concerned, and certainly unexpected.  But it is easy to handle these
469    situations correctly, so we can afford to be lenient in this case.  */
470
471 static struct type *
472 ada_typedef_target_type (struct type *type)
473 {
474   while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
475     type = TYPE_TARGET_TYPE (type);
476   return type;
477 }
478
479 /* Given DECODED_NAME a string holding a symbol name in its
480    decoded form (ie using the Ada dotted notation), returns
481    its unqualified name.  */
482
483 static const char *
484 ada_unqualified_name (const char *decoded_name)
485 {
486   const char *result;
487   
488   /* If the decoded name starts with '<', it means that the encoded
489      name does not follow standard naming conventions, and thus that
490      it is not your typical Ada symbol name.  Trying to unqualify it
491      is therefore pointless and possibly erroneous.  */
492   if (decoded_name[0] == '<')
493     return decoded_name;
494
495   result = strrchr (decoded_name, '.');
496   if (result != NULL)
497     result++;                   /* Skip the dot...  */
498   else
499     result = decoded_name;
500
501   return result;
502 }
503
504 /* Return a string starting with '<', followed by STR, and '>'.  */
505
506 static std::string
507 add_angle_brackets (const char *str)
508 {
509   return string_printf ("<%s>", str);
510 }
511
512 static const char *
513 ada_get_gdb_completer_word_break_characters (void)
514 {
515   return ada_completer_word_break_characters;
516 }
517
518 /* Print an array element index using the Ada syntax.  */
519
520 static void
521 ada_print_array_index (struct value *index_value, struct ui_file *stream,
522                        const struct value_print_options *options)
523 {
524   LA_VALUE_PRINT (index_value, stream, options);
525   fprintf_filtered (stream, " => ");
526 }
527
528 /* la_watch_location_expression for Ada.  */
529
530 static gdb::unique_xmalloc_ptr<char>
531 ada_watch_location_expression (struct type *type, CORE_ADDR addr)
532 {
533   type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
534   std::string name = type_to_string (type);
535   return gdb::unique_xmalloc_ptr<char>
536     (xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr)));
537 }
538
539 /* Assuming V points to an array of S objects,  make sure that it contains at
540    least M objects, updating V and S as necessary.  */
541
542 #define GROW_VECT(v, s, m)                                    \
543    if ((s) < (m)) (v) = (char *) grow_vect (v, &(s), m, sizeof *(v));
544
545 /* Assuming VECT points to an array of *SIZE objects of size
546    ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
547    updating *SIZE as necessary and returning the (new) array.  */
548
549 static void *
550 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
551 {
552   if (*size < min_size)
553     {
554       *size *= 2;
555       if (*size < min_size)
556         *size = min_size;
557       vect = xrealloc (vect, *size * element_size);
558     }
559   return vect;
560 }
561
562 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
563    suffix of FIELD_NAME beginning "___".  */
564
565 static int
566 field_name_match (const char *field_name, const char *target)
567 {
568   int len = strlen (target);
569
570   return
571     (strncmp (field_name, target, len) == 0
572      && (field_name[len] == '\0'
573          || (startswith (field_name + len, "___")
574              && strcmp (field_name + strlen (field_name) - 6,
575                         "___XVN") != 0)));
576 }
577
578
579 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
580    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
581    and return its index.  This function also handles fields whose name
582    have ___ suffixes because the compiler sometimes alters their name
583    by adding such a suffix to represent fields with certain constraints.
584    If the field could not be found, return a negative number if
585    MAYBE_MISSING is set.  Otherwise raise an error.  */
586
587 int
588 ada_get_field_index (const struct type *type, const char *field_name,
589                      int maybe_missing)
590 {
591   int fieldno;
592   struct type *struct_type = check_typedef ((struct type *) type);
593
594   for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
595     if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
596       return fieldno;
597
598   if (!maybe_missing)
599     error (_("Unable to find field %s in struct %s.  Aborting"),
600            field_name, TYPE_NAME (struct_type));
601
602   return -1;
603 }
604
605 /* The length of the prefix of NAME prior to any "___" suffix.  */
606
607 int
608 ada_name_prefix_len (const char *name)
609 {
610   if (name == NULL)
611     return 0;
612   else
613     {
614       const char *p = strstr (name, "___");
615
616       if (p == NULL)
617         return strlen (name);
618       else
619         return p - name;
620     }
621 }
622
623 /* Return non-zero if SUFFIX is a suffix of STR.
624    Return zero if STR is null.  */
625
626 static int
627 is_suffix (const char *str, const char *suffix)
628 {
629   int len1, len2;
630
631   if (str == NULL)
632     return 0;
633   len1 = strlen (str);
634   len2 = strlen (suffix);
635   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
636 }
637
638 /* The contents of value VAL, treated as a value of type TYPE.  The
639    result is an lval in memory if VAL is.  */
640
641 static struct value *
642 coerce_unspec_val_to_type (struct value *val, struct type *type)
643 {
644   type = ada_check_typedef (type);
645   if (value_type (val) == type)
646     return val;
647   else
648     {
649       struct value *result;
650
651       /* Make sure that the object size is not unreasonable before
652          trying to allocate some memory for it.  */
653       ada_ensure_varsize_limit (type);
654
655       if (value_lazy (val)
656           || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
657         result = allocate_value_lazy (type);
658       else
659         {
660           result = allocate_value (type);
661           value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
662         }
663       set_value_component_location (result, val);
664       set_value_bitsize (result, value_bitsize (val));
665       set_value_bitpos (result, value_bitpos (val));
666       if (VALUE_LVAL (result) == lval_memory)
667         set_value_address (result, value_address (val));
668       return result;
669     }
670 }
671
672 static const gdb_byte *
673 cond_offset_host (const gdb_byte *valaddr, long offset)
674 {
675   if (valaddr == NULL)
676     return NULL;
677   else
678     return valaddr + offset;
679 }
680
681 static CORE_ADDR
682 cond_offset_target (CORE_ADDR address, long offset)
683 {
684   if (address == 0)
685     return 0;
686   else
687     return address + offset;
688 }
689
690 /* Issue a warning (as for the definition of warning in utils.c, but
691    with exactly one argument rather than ...), unless the limit on the
692    number of warnings has passed during the evaluation of the current
693    expression.  */
694
695 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
696    provided by "complaint".  */
697 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
698
699 static void
700 lim_warning (const char *format, ...)
701 {
702   va_list args;
703
704   va_start (args, format);
705   warnings_issued += 1;
706   if (warnings_issued <= warning_limit)
707     vwarning (format, args);
708
709   va_end (args);
710 }
711
712 /* Issue an error if the size of an object of type T is unreasonable,
713    i.e. if it would be a bad idea to allocate a value of this type in
714    GDB.  */
715
716 void
717 ada_ensure_varsize_limit (const struct type *type)
718 {
719   if (TYPE_LENGTH (type) > varsize_limit)
720     error (_("object size is larger than varsize-limit"));
721 }
722
723 /* Maximum value of a SIZE-byte signed integer type.  */
724 static LONGEST
725 max_of_size (int size)
726 {
727   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
728
729   return top_bit | (top_bit - 1);
730 }
731
732 /* Minimum value of a SIZE-byte signed integer type.  */
733 static LONGEST
734 min_of_size (int size)
735 {
736   return -max_of_size (size) - 1;
737 }
738
739 /* Maximum value of a SIZE-byte unsigned integer type.  */
740 static ULONGEST
741 umax_of_size (int size)
742 {
743   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
744
745   return top_bit | (top_bit - 1);
746 }
747
748 /* Maximum value of integral type T, as a signed quantity.  */
749 static LONGEST
750 max_of_type (struct type *t)
751 {
752   if (TYPE_UNSIGNED (t))
753     return (LONGEST) umax_of_size (TYPE_LENGTH (t));
754   else
755     return max_of_size (TYPE_LENGTH (t));
756 }
757
758 /* Minimum value of integral type T, as a signed quantity.  */
759 static LONGEST
760 min_of_type (struct type *t)
761 {
762   if (TYPE_UNSIGNED (t)) 
763     return 0;
764   else
765     return min_of_size (TYPE_LENGTH (t));
766 }
767
768 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
769 LONGEST
770 ada_discrete_type_high_bound (struct type *type)
771 {
772   type = resolve_dynamic_type (type, NULL, 0);
773   switch (TYPE_CODE (type))
774     {
775     case TYPE_CODE_RANGE:
776       return TYPE_HIGH_BOUND (type);
777     case TYPE_CODE_ENUM:
778       return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
779     case TYPE_CODE_BOOL:
780       return 1;
781     case TYPE_CODE_CHAR:
782     case TYPE_CODE_INT:
783       return max_of_type (type);
784     default:
785       error (_("Unexpected type in ada_discrete_type_high_bound."));
786     }
787 }
788
789 /* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
790 LONGEST
791 ada_discrete_type_low_bound (struct type *type)
792 {
793   type = resolve_dynamic_type (type, NULL, 0);
794   switch (TYPE_CODE (type))
795     {
796     case TYPE_CODE_RANGE:
797       return TYPE_LOW_BOUND (type);
798     case TYPE_CODE_ENUM:
799       return TYPE_FIELD_ENUMVAL (type, 0);
800     case TYPE_CODE_BOOL:
801       return 0;
802     case TYPE_CODE_CHAR:
803     case TYPE_CODE_INT:
804       return min_of_type (type);
805     default:
806       error (_("Unexpected type in ada_discrete_type_low_bound."));
807     }
808 }
809
810 /* The identity on non-range types.  For range types, the underlying
811    non-range scalar type.  */
812
813 static struct type *
814 get_base_type (struct type *type)
815 {
816   while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
817     {
818       if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
819         return type;
820       type = TYPE_TARGET_TYPE (type);
821     }
822   return type;
823 }
824
825 /* Return a decoded version of the given VALUE.  This means returning
826    a value whose type is obtained by applying all the GNAT-specific
827    encodings, making the resulting type a static but standard description
828    of the initial type.  */
829
830 struct value *
831 ada_get_decoded_value (struct value *value)
832 {
833   struct type *type = ada_check_typedef (value_type (value));
834
835   if (ada_is_array_descriptor_type (type)
836       || (ada_is_constrained_packed_array_type (type)
837           && TYPE_CODE (type) != TYPE_CODE_PTR))
838     {
839       if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)  /* array access type.  */
840         value = ada_coerce_to_simple_array_ptr (value);
841       else
842         value = ada_coerce_to_simple_array (value);
843     }
844   else
845     value = ada_to_fixed_value (value);
846
847   return value;
848 }
849
850 /* Same as ada_get_decoded_value, but with the given TYPE.
851    Because there is no associated actual value for this type,
852    the resulting type might be a best-effort approximation in
853    the case of dynamic types.  */
854
855 struct type *
856 ada_get_decoded_type (struct type *type)
857 {
858   type = to_static_fixed_type (type);
859   if (ada_is_constrained_packed_array_type (type))
860     type = ada_coerce_to_simple_array_type (type);
861   return type;
862 }
863
864 \f
865
866                                 /* Language Selection */
867
868 /* If the main program is in Ada, return language_ada, otherwise return LANG
869    (the main program is in Ada iif the adainit symbol is found).  */
870
871 static enum language
872 ada_update_initial_language (enum language lang)
873 {
874   if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
875     return language_ada;
876
877   return lang;
878 }
879
880 /* If the main procedure is written in Ada, then return its name.
881    The result is good until the next call.  Return NULL if the main
882    procedure doesn't appear to be in Ada.  */
883
884 char *
885 ada_main_name (void)
886 {
887   struct bound_minimal_symbol msym;
888   static gdb::unique_xmalloc_ptr<char> main_program_name;
889
890   /* For Ada, the name of the main procedure is stored in a specific
891      string constant, generated by the binder.  Look for that symbol,
892      extract its address, and then read that string.  If we didn't find
893      that string, then most probably the main procedure is not written
894      in Ada.  */
895   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
896
897   if (msym.minsym != NULL)
898     {
899       CORE_ADDR main_program_name_addr;
900       int err_code;
901
902       main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
903       if (main_program_name_addr == 0)
904         error (_("Invalid address for Ada main program name."));
905
906       target_read_string (main_program_name_addr, &main_program_name,
907                           1024, &err_code);
908
909       if (err_code != 0)
910         return NULL;
911       return main_program_name.get ();
912     }
913
914   /* The main procedure doesn't seem to be in Ada.  */
915   return NULL;
916 }
917 \f
918                                 /* Symbols */
919
920 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
921    of NULLs.  */
922
923 const struct ada_opname_map ada_opname_table[] = {
924   {"Oadd", "\"+\"", BINOP_ADD},
925   {"Osubtract", "\"-\"", BINOP_SUB},
926   {"Omultiply", "\"*\"", BINOP_MUL},
927   {"Odivide", "\"/\"", BINOP_DIV},
928   {"Omod", "\"mod\"", BINOP_MOD},
929   {"Orem", "\"rem\"", BINOP_REM},
930   {"Oexpon", "\"**\"", BINOP_EXP},
931   {"Olt", "\"<\"", BINOP_LESS},
932   {"Ole", "\"<=\"", BINOP_LEQ},
933   {"Ogt", "\">\"", BINOP_GTR},
934   {"Oge", "\">=\"", BINOP_GEQ},
935   {"Oeq", "\"=\"", BINOP_EQUAL},
936   {"One", "\"/=\"", BINOP_NOTEQUAL},
937   {"Oand", "\"and\"", BINOP_BITWISE_AND},
938   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
939   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
940   {"Oconcat", "\"&\"", BINOP_CONCAT},
941   {"Oabs", "\"abs\"", UNOP_ABS},
942   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
943   {"Oadd", "\"+\"", UNOP_PLUS},
944   {"Osubtract", "\"-\"", UNOP_NEG},
945   {NULL, NULL}
946 };
947
948 /* The "encoded" form of DECODED, according to GNAT conventions.  The
949    result is valid until the next call to ada_encode.  If
950    THROW_ERRORS, throw an error if invalid operator name is found.
951    Otherwise, return NULL in that case.  */
952
953 static char *
954 ada_encode_1 (const char *decoded, bool throw_errors)
955 {
956   static char *encoding_buffer = NULL;
957   static size_t encoding_buffer_size = 0;
958   const char *p;
959   int k;
960
961   if (decoded == NULL)
962     return NULL;
963
964   GROW_VECT (encoding_buffer, encoding_buffer_size,
965              2 * strlen (decoded) + 10);
966
967   k = 0;
968   for (p = decoded; *p != '\0'; p += 1)
969     {
970       if (*p == '.')
971         {
972           encoding_buffer[k] = encoding_buffer[k + 1] = '_';
973           k += 2;
974         }
975       else if (*p == '"')
976         {
977           const struct ada_opname_map *mapping;
978
979           for (mapping = ada_opname_table;
980                mapping->encoded != NULL
981                && !startswith (p, mapping->decoded); mapping += 1)
982             ;
983           if (mapping->encoded == NULL)
984             {
985               if (throw_errors)
986                 error (_("invalid Ada operator name: %s"), p);
987               else
988                 return NULL;
989             }
990           strcpy (encoding_buffer + k, mapping->encoded);
991           k += strlen (mapping->encoded);
992           break;
993         }
994       else
995         {
996           encoding_buffer[k] = *p;
997           k += 1;
998         }
999     }
1000
1001   encoding_buffer[k] = '\0';
1002   return encoding_buffer;
1003 }
1004
1005 /* The "encoded" form of DECODED, according to GNAT conventions.
1006    The result is valid until the next call to ada_encode.  */
1007
1008 char *
1009 ada_encode (const char *decoded)
1010 {
1011   return ada_encode_1 (decoded, true);
1012 }
1013
1014 /* Return NAME folded to lower case, or, if surrounded by single
1015    quotes, unfolded, but with the quotes stripped away.  Result good
1016    to next call.  */
1017
1018 static char *
1019 ada_fold_name (const char *name)
1020 {
1021   static char *fold_buffer = NULL;
1022   static size_t fold_buffer_size = 0;
1023
1024   int len = strlen (name);
1025   GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
1026
1027   if (name[0] == '\'')
1028     {
1029       strncpy (fold_buffer, name + 1, len - 2);
1030       fold_buffer[len - 2] = '\000';
1031     }
1032   else
1033     {
1034       int i;
1035
1036       for (i = 0; i <= len; i += 1)
1037         fold_buffer[i] = tolower (name[i]);
1038     }
1039
1040   return fold_buffer;
1041 }
1042
1043 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
1044
1045 static int
1046 is_lower_alphanum (const char c)
1047 {
1048   return (isdigit (c) || (isalpha (c) && islower (c)));
1049 }
1050
1051 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1052    This function saves in LEN the length of that same symbol name but
1053    without either of these suffixes:
1054      . .{DIGIT}+
1055      . ${DIGIT}+
1056      . ___{DIGIT}+
1057      . __{DIGIT}+.
1058
1059    These are suffixes introduced by the compiler for entities such as
1060    nested subprogram for instance, in order to avoid name clashes.
1061    They do not serve any purpose for the debugger.  */
1062
1063 static void
1064 ada_remove_trailing_digits (const char *encoded, int *len)
1065 {
1066   if (*len > 1 && isdigit (encoded[*len - 1]))
1067     {
1068       int i = *len - 2;
1069
1070       while (i > 0 && isdigit (encoded[i]))
1071         i--;
1072       if (i >= 0 && encoded[i] == '.')
1073         *len = i;
1074       else if (i >= 0 && encoded[i] == '$')
1075         *len = i;
1076       else if (i >= 2 && startswith (encoded + i - 2, "___"))
1077         *len = i - 2;
1078       else if (i >= 1 && startswith (encoded + i - 1, "__"))
1079         *len = i - 1;
1080     }
1081 }
1082
1083 /* Remove the suffix introduced by the compiler for protected object
1084    subprograms.  */
1085
1086 static void
1087 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1088 {
1089   /* Remove trailing N.  */
1090
1091   /* Protected entry subprograms are broken into two
1092      separate subprograms: The first one is unprotected, and has
1093      a 'N' suffix; the second is the protected version, and has
1094      the 'P' suffix.  The second calls the first one after handling
1095      the protection.  Since the P subprograms are internally generated,
1096      we leave these names undecoded, giving the user a clue that this
1097      entity is internal.  */
1098
1099   if (*len > 1
1100       && encoded[*len - 1] == 'N'
1101       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1102     *len = *len - 1;
1103 }
1104
1105 /* If ENCODED follows the GNAT entity encoding conventions, then return
1106    the decoded form of ENCODED.  Otherwise, return "<%s>" where "%s" is
1107    replaced by ENCODED.  */
1108
1109 std::string
1110 ada_decode (const char *encoded)
1111 {
1112   int i, j;
1113   int len0;
1114   const char *p;
1115   int at_start_name;
1116   std::string decoded;
1117
1118   /* With function descriptors on PPC64, the value of a symbol named
1119      ".FN", if it exists, is the entry point of the function "FN".  */
1120   if (encoded[0] == '.')
1121     encoded += 1;
1122
1123   /* The name of the Ada main procedure starts with "_ada_".
1124      This prefix is not part of the decoded name, so skip this part
1125      if we see this prefix.  */
1126   if (startswith (encoded, "_ada_"))
1127     encoded += 5;
1128
1129   /* If the name starts with '_', then it is not a properly encoded
1130      name, so do not attempt to decode it.  Similarly, if the name
1131      starts with '<', the name should not be decoded.  */
1132   if (encoded[0] == '_' || encoded[0] == '<')
1133     goto Suppress;
1134
1135   len0 = strlen (encoded);
1136
1137   ada_remove_trailing_digits (encoded, &len0);
1138   ada_remove_po_subprogram_suffix (encoded, &len0);
1139
1140   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1141      the suffix is located before the current "end" of ENCODED.  We want
1142      to avoid re-matching parts of ENCODED that have previously been
1143      marked as discarded (by decrementing LEN0).  */
1144   p = strstr (encoded, "___");
1145   if (p != NULL && p - encoded < len0 - 3)
1146     {
1147       if (p[3] == 'X')
1148         len0 = p - encoded;
1149       else
1150         goto Suppress;
1151     }
1152
1153   /* Remove any trailing TKB suffix.  It tells us that this symbol
1154      is for the body of a task, but that information does not actually
1155      appear in the decoded name.  */
1156
1157   if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1158     len0 -= 3;
1159
1160   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1161      from the TKB suffix because it is used for non-anonymous task
1162      bodies.  */
1163
1164   if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1165     len0 -= 2;
1166
1167   /* Remove trailing "B" suffixes.  */
1168   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1169
1170   if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1171     len0 -= 1;
1172
1173   /* Make decoded big enough for possible expansion by operator name.  */
1174
1175   decoded.resize (2 * len0 + 1, 'X');
1176
1177   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1178
1179   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1180     {
1181       i = len0 - 2;
1182       while ((i >= 0 && isdigit (encoded[i]))
1183              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1184         i -= 1;
1185       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1186         len0 = i - 1;
1187       else if (encoded[i] == '$')
1188         len0 = i;
1189     }
1190
1191   /* The first few characters that are not alphabetic are not part
1192      of any encoding we use, so we can copy them over verbatim.  */
1193
1194   for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1195     decoded[j] = encoded[i];
1196
1197   at_start_name = 1;
1198   while (i < len0)
1199     {
1200       /* Is this a symbol function?  */
1201       if (at_start_name && encoded[i] == 'O')
1202         {
1203           int k;
1204
1205           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1206             {
1207               int op_len = strlen (ada_opname_table[k].encoded);
1208               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1209                             op_len - 1) == 0)
1210                   && !isalnum (encoded[i + op_len]))
1211                 {
1212                   strcpy (&decoded.front() + j, ada_opname_table[k].decoded);
1213                   at_start_name = 0;
1214                   i += op_len;
1215                   j += strlen (ada_opname_table[k].decoded);
1216                   break;
1217                 }
1218             }
1219           if (ada_opname_table[k].encoded != NULL)
1220             continue;
1221         }
1222       at_start_name = 0;
1223
1224       /* Replace "TK__" with "__", which will eventually be translated
1225          into "." (just below).  */
1226
1227       if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1228         i += 2;
1229
1230       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1231          be translated into "." (just below).  These are internal names
1232          generated for anonymous blocks inside which our symbol is nested.  */
1233
1234       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1235           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1236           && isdigit (encoded [i+4]))
1237         {
1238           int k = i + 5;
1239           
1240           while (k < len0 && isdigit (encoded[k]))
1241             k++;  /* Skip any extra digit.  */
1242
1243           /* Double-check that the "__B_{DIGITS}+" sequence we found
1244              is indeed followed by "__".  */
1245           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1246             i = k;
1247         }
1248
1249       /* Remove _E{DIGITS}+[sb] */
1250
1251       /* Just as for protected object subprograms, there are 2 categories
1252          of subprograms created by the compiler for each entry.  The first
1253          one implements the actual entry code, and has a suffix following
1254          the convention above; the second one implements the barrier and
1255          uses the same convention as above, except that the 'E' is replaced
1256          by a 'B'.
1257
1258          Just as above, we do not decode the name of barrier functions
1259          to give the user a clue that the code he is debugging has been
1260          internally generated.  */
1261
1262       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1263           && isdigit (encoded[i+2]))
1264         {
1265           int k = i + 3;
1266
1267           while (k < len0 && isdigit (encoded[k]))
1268             k++;
1269
1270           if (k < len0
1271               && (encoded[k] == 'b' || encoded[k] == 's'))
1272             {
1273               k++;
1274               /* Just as an extra precaution, make sure that if this
1275                  suffix is followed by anything else, it is a '_'.
1276                  Otherwise, we matched this sequence by accident.  */
1277               if (k == len0
1278                   || (k < len0 && encoded[k] == '_'))
1279                 i = k;
1280             }
1281         }
1282
1283       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1284          the GNAT front-end in protected object subprograms.  */
1285
1286       if (i < len0 + 3
1287           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1288         {
1289           /* Backtrack a bit up until we reach either the begining of
1290              the encoded name, or "__".  Make sure that we only find
1291              digits or lowercase characters.  */
1292           const char *ptr = encoded + i - 1;
1293
1294           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1295             ptr--;
1296           if (ptr < encoded
1297               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1298             i++;
1299         }
1300
1301       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1302         {
1303           /* This is a X[bn]* sequence not separated from the previous
1304              part of the name with a non-alpha-numeric character (in other
1305              words, immediately following an alpha-numeric character), then
1306              verify that it is placed at the end of the encoded name.  If
1307              not, then the encoding is not valid and we should abort the
1308              decoding.  Otherwise, just skip it, it is used in body-nested
1309              package names.  */
1310           do
1311             i += 1;
1312           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1313           if (i < len0)
1314             goto Suppress;
1315         }
1316       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1317         {
1318          /* Replace '__' by '.'.  */
1319           decoded[j] = '.';
1320           at_start_name = 1;
1321           i += 2;
1322           j += 1;
1323         }
1324       else
1325         {
1326           /* It's a character part of the decoded name, so just copy it
1327              over.  */
1328           decoded[j] = encoded[i];
1329           i += 1;
1330           j += 1;
1331         }
1332     }
1333   decoded.resize (j);
1334
1335   /* Decoded names should never contain any uppercase character.
1336      Double-check this, and abort the decoding if we find one.  */
1337
1338   for (i = 0; i < decoded.length(); ++i)
1339     if (isupper (decoded[i]) || decoded[i] == ' ')
1340       goto Suppress;
1341
1342   return decoded;
1343
1344 Suppress:
1345   if (encoded[0] == '<')
1346     decoded = encoded;
1347   else
1348     decoded = '<' + std::string(encoded) + '>';
1349   return decoded;
1350
1351 }
1352
1353 /* Table for keeping permanent unique copies of decoded names.  Once
1354    allocated, names in this table are never released.  While this is a
1355    storage leak, it should not be significant unless there are massive
1356    changes in the set of decoded names in successive versions of a 
1357    symbol table loaded during a single session.  */
1358 static struct htab *decoded_names_store;
1359
1360 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1361    in the language-specific part of GSYMBOL, if it has not been
1362    previously computed.  Tries to save the decoded name in the same
1363    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1364    in any case, the decoded symbol has a lifetime at least that of
1365    GSYMBOL).
1366    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1367    const, but nevertheless modified to a semantically equivalent form
1368    when a decoded name is cached in it.  */
1369
1370 const char *
1371 ada_decode_symbol (const struct general_symbol_info *arg)
1372 {
1373   struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1374   const char **resultp =
1375     &gsymbol->language_specific.demangled_name;
1376
1377   if (!gsymbol->ada_mangled)
1378     {
1379       std::string decoded = ada_decode (gsymbol->linkage_name ());
1380       struct obstack *obstack = gsymbol->language_specific.obstack;
1381
1382       gsymbol->ada_mangled = 1;
1383
1384       if (obstack != NULL)
1385         *resultp = obstack_strdup (obstack, decoded.c_str ());
1386       else
1387         {
1388           /* Sometimes, we can't find a corresponding objfile, in
1389              which case, we put the result on the heap.  Since we only
1390              decode when needed, we hope this usually does not cause a
1391              significant memory leak (FIXME).  */
1392
1393           char **slot = (char **) htab_find_slot (decoded_names_store,
1394                                                   decoded.c_str (), INSERT);
1395
1396           if (*slot == NULL)
1397             *slot = xstrdup (decoded.c_str ());
1398           *resultp = *slot;
1399         }
1400     }
1401
1402   return *resultp;
1403 }
1404
1405 static char *
1406 ada_la_decode (const char *encoded, int options)
1407 {
1408   return xstrdup (ada_decode (encoded).c_str ());
1409 }
1410
1411 /* Implement la_sniff_from_mangled_name for Ada.  */
1412
1413 static int
1414 ada_sniff_from_mangled_name (const char *mangled, char **out)
1415 {
1416   std::string demangled = ada_decode (mangled);
1417
1418   *out = NULL;
1419
1420   if (demangled != mangled && demangled[0] != '<')
1421     {
1422       /* Set the gsymbol language to Ada, but still return 0.
1423          Two reasons for that:
1424
1425          1. For Ada, we prefer computing the symbol's decoded name
1426          on the fly rather than pre-compute it, in order to save
1427          memory (Ada projects are typically very large).
1428
1429          2. There are some areas in the definition of the GNAT
1430          encoding where, with a bit of bad luck, we might be able
1431          to decode a non-Ada symbol, generating an incorrect
1432          demangled name (Eg: names ending with "TB" for instance
1433          are identified as task bodies and so stripped from
1434          the decoded name returned).
1435
1436          Returning 1, here, but not setting *DEMANGLED, helps us get a
1437          little bit of the best of both worlds.  Because we're last,
1438          we should not affect any of the other languages that were
1439          able to demangle the symbol before us; we get to correctly
1440          tag Ada symbols as such; and even if we incorrectly tagged a
1441          non-Ada symbol, which should be rare, any routing through the
1442          Ada language should be transparent (Ada tries to behave much
1443          like C/C++ with non-Ada symbols).  */
1444       return 1;
1445     }
1446
1447   return 0;
1448 }
1449
1450 \f
1451
1452                                 /* Arrays */
1453
1454 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1455    generated by the GNAT compiler to describe the index type used
1456    for each dimension of an array, check whether it follows the latest
1457    known encoding.  If not, fix it up to conform to the latest encoding.
1458    Otherwise, do nothing.  This function also does nothing if
1459    INDEX_DESC_TYPE is NULL.
1460
1461    The GNAT encoding used to describe the array index type evolved a bit.
1462    Initially, the information would be provided through the name of each
1463    field of the structure type only, while the type of these fields was
1464    described as unspecified and irrelevant.  The debugger was then expected
1465    to perform a global type lookup using the name of that field in order
1466    to get access to the full index type description.  Because these global
1467    lookups can be very expensive, the encoding was later enhanced to make
1468    the global lookup unnecessary by defining the field type as being
1469    the full index type description.
1470
1471    The purpose of this routine is to allow us to support older versions
1472    of the compiler by detecting the use of the older encoding, and by
1473    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1474    we essentially replace each field's meaningless type by the associated
1475    index subtype).  */
1476
1477 void
1478 ada_fixup_array_indexes_type (struct type *index_desc_type)
1479 {
1480   int i;
1481
1482   if (index_desc_type == NULL)
1483     return;
1484   gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1485
1486   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1487      to check one field only, no need to check them all).  If not, return
1488      now.
1489
1490      If our INDEX_DESC_TYPE was generated using the older encoding,
1491      the field type should be a meaningless integer type whose name
1492      is not equal to the field name.  */
1493   if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1494       && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1495                  TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1496     return;
1497
1498   /* Fixup each field of INDEX_DESC_TYPE.  */
1499   for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1500    {
1501      const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1502      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1503
1504      if (raw_type)
1505        TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1506    }
1507 }
1508
1509 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors.  */
1510
1511 static const char *bound_name[] = {
1512   "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1513   "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1514 };
1515
1516 /* Maximum number of array dimensions we are prepared to handle.  */
1517
1518 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1519
1520
1521 /* The desc_* routines return primitive portions of array descriptors
1522    (fat pointers).  */
1523
1524 /* The descriptor or array type, if any, indicated by TYPE; removes
1525    level of indirection, if needed.  */
1526
1527 static struct type *
1528 desc_base_type (struct type *type)
1529 {
1530   if (type == NULL)
1531     return NULL;
1532   type = ada_check_typedef (type);
1533   if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1534     type = ada_typedef_target_type (type);
1535
1536   if (type != NULL
1537       && (TYPE_CODE (type) == TYPE_CODE_PTR
1538           || TYPE_CODE (type) == TYPE_CODE_REF))
1539     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1540   else
1541     return type;
1542 }
1543
1544 /* True iff TYPE indicates a "thin" array pointer type.  */
1545
1546 static int
1547 is_thin_pntr (struct type *type)
1548 {
1549   return
1550     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1551     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1552 }
1553
1554 /* The descriptor type for thin pointer type TYPE.  */
1555
1556 static struct type *
1557 thin_descriptor_type (struct type *type)
1558 {
1559   struct type *base_type = desc_base_type (type);
1560
1561   if (base_type == NULL)
1562     return NULL;
1563   if (is_suffix (ada_type_name (base_type), "___XVE"))
1564     return base_type;
1565   else
1566     {
1567       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1568
1569       if (alt_type == NULL)
1570         return base_type;
1571       else
1572         return alt_type;
1573     }
1574 }
1575
1576 /* A pointer to the array data for thin-pointer value VAL.  */
1577
1578 static struct value *
1579 thin_data_pntr (struct value *val)
1580 {
1581   struct type *type = ada_check_typedef (value_type (val));
1582   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1583
1584   data_type = lookup_pointer_type (data_type);
1585
1586   if (TYPE_CODE (type) == TYPE_CODE_PTR)
1587     return value_cast (data_type, value_copy (val));
1588   else
1589     return value_from_longest (data_type, value_address (val));
1590 }
1591
1592 /* True iff TYPE indicates a "thick" array pointer type.  */
1593
1594 static int
1595 is_thick_pntr (struct type *type)
1596 {
1597   type = desc_base_type (type);
1598   return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1599           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1600 }
1601
1602 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1603    pointer to one, the type of its bounds data; otherwise, NULL.  */
1604
1605 static struct type *
1606 desc_bounds_type (struct type *type)
1607 {
1608   struct type *r;
1609
1610   type = desc_base_type (type);
1611
1612   if (type == NULL)
1613     return NULL;
1614   else if (is_thin_pntr (type))
1615     {
1616       type = thin_descriptor_type (type);
1617       if (type == NULL)
1618         return NULL;
1619       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1620       if (r != NULL)
1621         return ada_check_typedef (r);
1622     }
1623   else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1624     {
1625       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1626       if (r != NULL)
1627         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1628     }
1629   return NULL;
1630 }
1631
1632 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1633    one, a pointer to its bounds data.   Otherwise NULL.  */
1634
1635 static struct value *
1636 desc_bounds (struct value *arr)
1637 {
1638   struct type *type = ada_check_typedef (value_type (arr));
1639
1640   if (is_thin_pntr (type))
1641     {
1642       struct type *bounds_type =
1643         desc_bounds_type (thin_descriptor_type (type));
1644       LONGEST addr;
1645
1646       if (bounds_type == NULL)
1647         error (_("Bad GNAT array descriptor"));
1648
1649       /* NOTE: The following calculation is not really kosher, but
1650          since desc_type is an XVE-encoded type (and shouldn't be),
1651          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1652       if (TYPE_CODE (type) == TYPE_CODE_PTR)
1653         addr = value_as_long (arr);
1654       else
1655         addr = value_address (arr);
1656
1657       return
1658         value_from_longest (lookup_pointer_type (bounds_type),
1659                             addr - TYPE_LENGTH (bounds_type));
1660     }
1661
1662   else if (is_thick_pntr (type))
1663     {
1664       struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1665                                                _("Bad GNAT array descriptor"));
1666       struct type *p_bounds_type = value_type (p_bounds);
1667
1668       if (p_bounds_type
1669           && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1670         {
1671           struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1672
1673           if (TYPE_STUB (target_type))
1674             p_bounds = value_cast (lookup_pointer_type
1675                                    (ada_check_typedef (target_type)),
1676                                    p_bounds);
1677         }
1678       else
1679         error (_("Bad GNAT array descriptor"));
1680
1681       return p_bounds;
1682     }
1683   else
1684     return NULL;
1685 }
1686
1687 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1688    position of the field containing the address of the bounds data.  */
1689
1690 static int
1691 fat_pntr_bounds_bitpos (struct type *type)
1692 {
1693   return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1694 }
1695
1696 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1697    size of the field containing the address of the bounds data.  */
1698
1699 static int
1700 fat_pntr_bounds_bitsize (struct type *type)
1701 {
1702   type = desc_base_type (type);
1703
1704   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1705     return TYPE_FIELD_BITSIZE (type, 1);
1706   else
1707     return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1708 }
1709
1710 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1711    pointer to one, the type of its array data (a array-with-no-bounds type);
1712    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1713    data.  */
1714
1715 static struct type *
1716 desc_data_target_type (struct type *type)
1717 {
1718   type = desc_base_type (type);
1719
1720   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1721   if (is_thin_pntr (type))
1722     return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
1723   else if (is_thick_pntr (type))
1724     {
1725       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1726
1727       if (data_type
1728           && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
1729         return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1730     }
1731
1732   return NULL;
1733 }
1734
1735 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1736    its array data.  */
1737
1738 static struct value *
1739 desc_data (struct value *arr)
1740 {
1741   struct type *type = value_type (arr);
1742
1743   if (is_thin_pntr (type))
1744     return thin_data_pntr (arr);
1745   else if (is_thick_pntr (type))
1746     return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1747                              _("Bad GNAT array descriptor"));
1748   else
1749     return NULL;
1750 }
1751
1752
1753 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1754    position of the field containing the address of the data.  */
1755
1756 static int
1757 fat_pntr_data_bitpos (struct type *type)
1758 {
1759   return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1760 }
1761
1762 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1763    size of the field containing the address of the data.  */
1764
1765 static int
1766 fat_pntr_data_bitsize (struct type *type)
1767 {
1768   type = desc_base_type (type);
1769
1770   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1771     return TYPE_FIELD_BITSIZE (type, 0);
1772   else
1773     return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1774 }
1775
1776 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1777    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1778    bound, if WHICH is 1.  The first bound is I=1.  */
1779
1780 static struct value *
1781 desc_one_bound (struct value *bounds, int i, int which)
1782 {
1783   return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1784                            _("Bad GNAT array descriptor bounds"));
1785 }
1786
1787 /* If BOUNDS is an array-bounds structure type, return the bit position
1788    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1789    bound, if WHICH is 1.  The first bound is I=1.  */
1790
1791 static int
1792 desc_bound_bitpos (struct type *type, int i, int which)
1793 {
1794   return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1795 }
1796
1797 /* If BOUNDS is an array-bounds structure type, return the bit field size
1798    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1799    bound, if WHICH is 1.  The first bound is I=1.  */
1800
1801 static int
1802 desc_bound_bitsize (struct type *type, int i, int which)
1803 {
1804   type = desc_base_type (type);
1805
1806   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1807     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1808   else
1809     return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1810 }
1811
1812 /* If TYPE is the type of an array-bounds structure, the type of its
1813    Ith bound (numbering from 1).  Otherwise, NULL.  */
1814
1815 static struct type *
1816 desc_index_type (struct type *type, int i)
1817 {
1818   type = desc_base_type (type);
1819
1820   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1821     return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1822   else
1823     return NULL;
1824 }
1825
1826 /* The number of index positions in the array-bounds type TYPE.
1827    Return 0 if TYPE is NULL.  */
1828
1829 static int
1830 desc_arity (struct type *type)
1831 {
1832   type = desc_base_type (type);
1833
1834   if (type != NULL)
1835     return TYPE_NFIELDS (type) / 2;
1836   return 0;
1837 }
1838
1839 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
1840    an array descriptor type (representing an unconstrained array
1841    type).  */
1842
1843 static int
1844 ada_is_direct_array_type (struct type *type)
1845 {
1846   if (type == NULL)
1847     return 0;
1848   type = ada_check_typedef (type);
1849   return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1850           || ada_is_array_descriptor_type (type));
1851 }
1852
1853 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1854  * to one.  */
1855
1856 static int
1857 ada_is_array_type (struct type *type)
1858 {
1859   while (type != NULL 
1860          && (TYPE_CODE (type) == TYPE_CODE_PTR 
1861              || TYPE_CODE (type) == TYPE_CODE_REF))
1862     type = TYPE_TARGET_TYPE (type);
1863   return ada_is_direct_array_type (type);
1864 }
1865
1866 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
1867
1868 int
1869 ada_is_simple_array_type (struct type *type)
1870 {
1871   if (type == NULL)
1872     return 0;
1873   type = ada_check_typedef (type);
1874   return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1875           || (TYPE_CODE (type) == TYPE_CODE_PTR
1876               && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1877                  == TYPE_CODE_ARRAY));
1878 }
1879
1880 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
1881
1882 int
1883 ada_is_array_descriptor_type (struct type *type)
1884 {
1885   struct type *data_type = desc_data_target_type (type);
1886
1887   if (type == NULL)
1888     return 0;
1889   type = ada_check_typedef (type);
1890   return (data_type != NULL
1891           && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1892           && desc_arity (desc_bounds_type (type)) > 0);
1893 }
1894
1895 /* Non-zero iff type is a partially mal-formed GNAT array
1896    descriptor.  FIXME: This is to compensate for some problems with
1897    debugging output from GNAT.  Re-examine periodically to see if it
1898    is still needed.  */
1899
1900 int
1901 ada_is_bogus_array_descriptor (struct type *type)
1902 {
1903   return
1904     type != NULL
1905     && TYPE_CODE (type) == TYPE_CODE_STRUCT
1906     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1907         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1908     && !ada_is_array_descriptor_type (type);
1909 }
1910
1911
1912 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1913    (fat pointer) returns the type of the array data described---specifically,
1914    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
1915    in from the descriptor; otherwise, they are left unspecified.  If
1916    the ARR denotes a null array descriptor and BOUNDS is non-zero,
1917    returns NULL.  The result is simply the type of ARR if ARR is not
1918    a descriptor.  */
1919
1920 static struct type *
1921 ada_type_of_array (struct value *arr, int bounds)
1922 {
1923   if (ada_is_constrained_packed_array_type (value_type (arr)))
1924     return decode_constrained_packed_array_type (value_type (arr));
1925
1926   if (!ada_is_array_descriptor_type (value_type (arr)))
1927     return value_type (arr);
1928
1929   if (!bounds)
1930     {
1931       struct type *array_type =
1932         ada_check_typedef (desc_data_target_type (value_type (arr)));
1933
1934       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1935         TYPE_FIELD_BITSIZE (array_type, 0) =
1936           decode_packed_array_bitsize (value_type (arr));
1937       
1938       return array_type;
1939     }
1940   else
1941     {
1942       struct type *elt_type;
1943       int arity;
1944       struct value *descriptor;
1945
1946       elt_type = ada_array_element_type (value_type (arr), -1);
1947       arity = ada_array_arity (value_type (arr));
1948
1949       if (elt_type == NULL || arity == 0)
1950         return ada_check_typedef (value_type (arr));
1951
1952       descriptor = desc_bounds (arr);
1953       if (value_as_long (descriptor) == 0)
1954         return NULL;
1955       while (arity > 0)
1956         {
1957           struct type *range_type = alloc_type_copy (value_type (arr));
1958           struct type *array_type = alloc_type_copy (value_type (arr));
1959           struct value *low = desc_one_bound (descriptor, arity, 0);
1960           struct value *high = desc_one_bound (descriptor, arity, 1);
1961
1962           arity -= 1;
1963           create_static_range_type (range_type, value_type (low),
1964                                     longest_to_int (value_as_long (low)),
1965                                     longest_to_int (value_as_long (high)));
1966           elt_type = create_array_type (array_type, elt_type, range_type);
1967
1968           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1969             {
1970               /* We need to store the element packed bitsize, as well as
1971                  recompute the array size, because it was previously
1972                  computed based on the unpacked element size.  */
1973               LONGEST lo = value_as_long (low);
1974               LONGEST hi = value_as_long (high);
1975
1976               TYPE_FIELD_BITSIZE (elt_type, 0) =
1977                 decode_packed_array_bitsize (value_type (arr));
1978               /* If the array has no element, then the size is already
1979                  zero, and does not need to be recomputed.  */
1980               if (lo < hi)
1981                 {
1982                   int array_bitsize =
1983                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1984
1985                   TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1986                 }
1987             }
1988         }
1989
1990       return lookup_pointer_type (elt_type);
1991     }
1992 }
1993
1994 /* If ARR does not represent an array, returns ARR unchanged.
1995    Otherwise, returns either a standard GDB array with bounds set
1996    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1997    GDB array.  Returns NULL if ARR is a null fat pointer.  */
1998
1999 struct value *
2000 ada_coerce_to_simple_array_ptr (struct value *arr)
2001 {
2002   if (ada_is_array_descriptor_type (value_type (arr)))
2003     {
2004       struct type *arrType = ada_type_of_array (arr, 1);
2005
2006       if (arrType == NULL)
2007         return NULL;
2008       return value_cast (arrType, value_copy (desc_data (arr)));
2009     }
2010   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2011     return decode_constrained_packed_array (arr);
2012   else
2013     return arr;
2014 }
2015
2016 /* If ARR does not represent an array, returns ARR unchanged.
2017    Otherwise, returns a standard GDB array describing ARR (which may
2018    be ARR itself if it already is in the proper form).  */
2019
2020 struct value *
2021 ada_coerce_to_simple_array (struct value *arr)
2022 {
2023   if (ada_is_array_descriptor_type (value_type (arr)))
2024     {
2025       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2026
2027       if (arrVal == NULL)
2028         error (_("Bounds unavailable for null array pointer."));
2029       ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
2030       return value_ind (arrVal);
2031     }
2032   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2033     return decode_constrained_packed_array (arr);
2034   else
2035     return arr;
2036 }
2037
2038 /* If TYPE represents a GNAT array type, return it translated to an
2039    ordinary GDB array type (possibly with BITSIZE fields indicating
2040    packing).  For other types, is the identity.  */
2041
2042 struct type *
2043 ada_coerce_to_simple_array_type (struct type *type)
2044 {
2045   if (ada_is_constrained_packed_array_type (type))
2046     return decode_constrained_packed_array_type (type);
2047
2048   if (ada_is_array_descriptor_type (type))
2049     return ada_check_typedef (desc_data_target_type (type));
2050
2051   return type;
2052 }
2053
2054 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
2055
2056 static int
2057 ada_is_packed_array_type  (struct type *type)
2058 {
2059   if (type == NULL)
2060     return 0;
2061   type = desc_base_type (type);
2062   type = ada_check_typedef (type);
2063   return
2064     ada_type_name (type) != NULL
2065     && strstr (ada_type_name (type), "___XP") != NULL;
2066 }
2067
2068 /* Non-zero iff TYPE represents a standard GNAT constrained
2069    packed-array type.  */
2070
2071 int
2072 ada_is_constrained_packed_array_type (struct type *type)
2073 {
2074   return ada_is_packed_array_type (type)
2075     && !ada_is_array_descriptor_type (type);
2076 }
2077
2078 /* Non-zero iff TYPE represents an array descriptor for a
2079    unconstrained packed-array type.  */
2080
2081 static int
2082 ada_is_unconstrained_packed_array_type (struct type *type)
2083 {
2084   return ada_is_packed_array_type (type)
2085     && ada_is_array_descriptor_type (type);
2086 }
2087
2088 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2089    return the size of its elements in bits.  */
2090
2091 static long
2092 decode_packed_array_bitsize (struct type *type)
2093 {
2094   const char *raw_name;
2095   const char *tail;
2096   long bits;
2097
2098   /* Access to arrays implemented as fat pointers are encoded as a typedef
2099      of the fat pointer type.  We need the name of the fat pointer type
2100      to do the decoding, so strip the typedef layer.  */
2101   if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2102     type = ada_typedef_target_type (type);
2103
2104   raw_name = ada_type_name (ada_check_typedef (type));
2105   if (!raw_name)
2106     raw_name = ada_type_name (desc_base_type (type));
2107
2108   if (!raw_name)
2109     return 0;
2110
2111   tail = strstr (raw_name, "___XP");
2112   gdb_assert (tail != NULL);
2113
2114   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2115     {
2116       lim_warning
2117         (_("could not understand bit size information on packed array"));
2118       return 0;
2119     }
2120
2121   return bits;
2122 }
2123
2124 /* Given that TYPE is a standard GDB array type with all bounds filled
2125    in, and that the element size of its ultimate scalar constituents
2126    (that is, either its elements, or, if it is an array of arrays, its
2127    elements' elements, etc.) is *ELT_BITS, return an identical type,
2128    but with the bit sizes of its elements (and those of any
2129    constituent arrays) recorded in the BITSIZE components of its
2130    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2131    in bits.
2132
2133    Note that, for arrays whose index type has an XA encoding where
2134    a bound references a record discriminant, getting that discriminant,
2135    and therefore the actual value of that bound, is not possible
2136    because none of the given parameters gives us access to the record.
2137    This function assumes that it is OK in the context where it is being
2138    used to return an array whose bounds are still dynamic and where
2139    the length is arbitrary.  */
2140
2141 static struct type *
2142 constrained_packed_array_type (struct type *type, long *elt_bits)
2143 {
2144   struct type *new_elt_type;
2145   struct type *new_type;
2146   struct type *index_type_desc;
2147   struct type *index_type;
2148   LONGEST low_bound, high_bound;
2149
2150   type = ada_check_typedef (type);
2151   if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2152     return type;
2153
2154   index_type_desc = ada_find_parallel_type (type, "___XA");
2155   if (index_type_desc)
2156     index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2157                                       NULL);
2158   else
2159     index_type = TYPE_INDEX_TYPE (type);
2160
2161   new_type = alloc_type_copy (type);
2162   new_elt_type =
2163     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2164                                    elt_bits);
2165   create_array_type (new_type, new_elt_type, index_type);
2166   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2167   TYPE_NAME (new_type) = ada_type_name (type);
2168
2169   if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2170        && is_dynamic_type (check_typedef (index_type)))
2171       || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
2172     low_bound = high_bound = 0;
2173   if (high_bound < low_bound)
2174     *elt_bits = TYPE_LENGTH (new_type) = 0;
2175   else
2176     {
2177       *elt_bits *= (high_bound - low_bound + 1);
2178       TYPE_LENGTH (new_type) =
2179         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2180     }
2181
2182   TYPE_FIXED_INSTANCE (new_type) = 1;
2183   return new_type;
2184 }
2185
2186 /* The array type encoded by TYPE, where
2187    ada_is_constrained_packed_array_type (TYPE).  */
2188
2189 static struct type *
2190 decode_constrained_packed_array_type (struct type *type)
2191 {
2192   const char *raw_name = ada_type_name (ada_check_typedef (type));
2193   char *name;
2194   const char *tail;
2195   struct type *shadow_type;
2196   long bits;
2197
2198   if (!raw_name)
2199     raw_name = ada_type_name (desc_base_type (type));
2200
2201   if (!raw_name)
2202     return NULL;
2203
2204   name = (char *) alloca (strlen (raw_name) + 1);
2205   tail = strstr (raw_name, "___XP");
2206   type = desc_base_type (type);
2207
2208   memcpy (name, raw_name, tail - raw_name);
2209   name[tail - raw_name] = '\000';
2210
2211   shadow_type = ada_find_parallel_type_with_name (type, name);
2212
2213   if (shadow_type == NULL)
2214     {
2215       lim_warning (_("could not find bounds information on packed array"));
2216       return NULL;
2217     }
2218   shadow_type = check_typedef (shadow_type);
2219
2220   if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2221     {
2222       lim_warning (_("could not understand bounds "
2223                      "information on packed array"));
2224       return NULL;
2225     }
2226
2227   bits = decode_packed_array_bitsize (type);
2228   return constrained_packed_array_type (shadow_type, &bits);
2229 }
2230
2231 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2232    array, returns a simple array that denotes that array.  Its type is a
2233    standard GDB array type except that the BITSIZEs of the array
2234    target types are set to the number of bits in each element, and the
2235    type length is set appropriately.  */
2236
2237 static struct value *
2238 decode_constrained_packed_array (struct value *arr)
2239 {
2240   struct type *type;
2241
2242   /* If our value is a pointer, then dereference it. Likewise if
2243      the value is a reference.  Make sure that this operation does not
2244      cause the target type to be fixed, as this would indirectly cause
2245      this array to be decoded.  The rest of the routine assumes that
2246      the array hasn't been decoded yet, so we use the basic "coerce_ref"
2247      and "value_ind" routines to perform the dereferencing, as opposed
2248      to using "ada_coerce_ref" or "ada_value_ind".  */
2249   arr = coerce_ref (arr);
2250   if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
2251     arr = value_ind (arr);
2252
2253   type = decode_constrained_packed_array_type (value_type (arr));
2254   if (type == NULL)
2255     {
2256       error (_("can't unpack array"));
2257       return NULL;
2258     }
2259
2260   if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
2261       && ada_is_modular_type (value_type (arr)))
2262     {
2263        /* This is a (right-justified) modular type representing a packed
2264          array with no wrapper.  In order to interpret the value through
2265          the (left-justified) packed array type we just built, we must
2266          first left-justify it.  */
2267       int bit_size, bit_pos;
2268       ULONGEST mod;
2269
2270       mod = ada_modulus (value_type (arr)) - 1;
2271       bit_size = 0;
2272       while (mod > 0)
2273         {
2274           bit_size += 1;
2275           mod >>= 1;
2276         }
2277       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2278       arr = ada_value_primitive_packed_val (arr, NULL,
2279                                             bit_pos / HOST_CHAR_BIT,
2280                                             bit_pos % HOST_CHAR_BIT,
2281                                             bit_size,
2282                                             type);
2283     }
2284
2285   return coerce_unspec_val_to_type (arr, type);
2286 }
2287
2288
2289 /* The value of the element of packed array ARR at the ARITY indices
2290    given in IND.   ARR must be a simple array.  */
2291
2292 static struct value *
2293 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2294 {
2295   int i;
2296   int bits, elt_off, bit_off;
2297   long elt_total_bit_offset;
2298   struct type *elt_type;
2299   struct value *v;
2300
2301   bits = 0;
2302   elt_total_bit_offset = 0;
2303   elt_type = ada_check_typedef (value_type (arr));
2304   for (i = 0; i < arity; i += 1)
2305     {
2306       if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
2307           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2308         error
2309           (_("attempt to do packed indexing of "
2310              "something other than a packed array"));
2311       else
2312         {
2313           struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2314           LONGEST lowerbound, upperbound;
2315           LONGEST idx;
2316
2317           if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2318             {
2319               lim_warning (_("don't know bounds of array"));
2320               lowerbound = upperbound = 0;
2321             }
2322
2323           idx = pos_atr (ind[i]);
2324           if (idx < lowerbound || idx > upperbound)
2325             lim_warning (_("packed array index %ld out of bounds"),
2326                          (long) idx);
2327           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2328           elt_total_bit_offset += (idx - lowerbound) * bits;
2329           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2330         }
2331     }
2332   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2333   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2334
2335   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2336                                       bits, elt_type);
2337   return v;
2338 }
2339
2340 /* Non-zero iff TYPE includes negative integer values.  */
2341
2342 static int
2343 has_negatives (struct type *type)
2344 {
2345   switch (TYPE_CODE (type))
2346     {
2347     default:
2348       return 0;
2349     case TYPE_CODE_INT:
2350       return !TYPE_UNSIGNED (type);
2351     case TYPE_CODE_RANGE:
2352       return TYPE_LOW_BOUND (type) - TYPE_RANGE_DATA (type)->bias < 0;
2353     }
2354 }
2355
2356 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2357    unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
2358    the unpacked buffer.
2359
2360    The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2361    enough to contain at least BIT_OFFSET bits.  If not, an error is raised.
2362
2363    IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2364    zero otherwise.
2365
2366    IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2367
2368    IS_SCALAR is nonzero if the data corresponds to a signed type.  */
2369
2370 static void
2371 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2372                           gdb_byte *unpacked, int unpacked_len,
2373                           int is_big_endian, int is_signed_type,
2374                           int is_scalar)
2375 {
2376   int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2377   int src_idx;                  /* Index into the source area */
2378   int src_bytes_left;           /* Number of source bytes left to process.  */
2379   int srcBitsLeft;              /* Number of source bits left to move */
2380   int unusedLS;                 /* Number of bits in next significant
2381                                    byte of source that are unused */
2382
2383   int unpacked_idx;             /* Index into the unpacked buffer */
2384   int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */
2385
2386   unsigned long accum;          /* Staging area for bits being transferred */
2387   int accumSize;                /* Number of meaningful bits in accum */
2388   unsigned char sign;
2389
2390   /* Transmit bytes from least to most significant; delta is the direction
2391      the indices move.  */
2392   int delta = is_big_endian ? -1 : 1;
2393
2394   /* Make sure that unpacked is large enough to receive the BIT_SIZE
2395      bits from SRC.  .*/
2396   if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2397     error (_("Cannot unpack %d bits into buffer of %d bytes"),
2398            bit_size, unpacked_len);
2399
2400   srcBitsLeft = bit_size;
2401   src_bytes_left = src_len;
2402   unpacked_bytes_left = unpacked_len;
2403   sign = 0;
2404
2405   if (is_big_endian)
2406     {
2407       src_idx = src_len - 1;
2408       if (is_signed_type
2409           && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2410         sign = ~0;
2411
2412       unusedLS =
2413         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2414         % HOST_CHAR_BIT;
2415
2416       if (is_scalar)
2417         {
2418           accumSize = 0;
2419           unpacked_idx = unpacked_len - 1;
2420         }
2421       else
2422         {
2423           /* Non-scalar values must be aligned at a byte boundary...  */
2424           accumSize =
2425             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2426           /* ... And are placed at the beginning (most-significant) bytes
2427              of the target.  */
2428           unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2429           unpacked_bytes_left = unpacked_idx + 1;
2430         }
2431     }
2432   else
2433     {
2434       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2435
2436       src_idx = unpacked_idx = 0;
2437       unusedLS = bit_offset;
2438       accumSize = 0;
2439
2440       if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2441         sign = ~0;
2442     }
2443
2444   accum = 0;
2445   while (src_bytes_left > 0)
2446     {
2447       /* Mask for removing bits of the next source byte that are not
2448          part of the value.  */
2449       unsigned int unusedMSMask =
2450         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2451         1;
2452       /* Sign-extend bits for this byte.  */
2453       unsigned int signMask = sign & ~unusedMSMask;
2454
2455       accum |=
2456         (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2457       accumSize += HOST_CHAR_BIT - unusedLS;
2458       if (accumSize >= HOST_CHAR_BIT)
2459         {
2460           unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2461           accumSize -= HOST_CHAR_BIT;
2462           accum >>= HOST_CHAR_BIT;
2463           unpacked_bytes_left -= 1;
2464           unpacked_idx += delta;
2465         }
2466       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2467       unusedLS = 0;
2468       src_bytes_left -= 1;
2469       src_idx += delta;
2470     }
2471   while (unpacked_bytes_left > 0)
2472     {
2473       accum |= sign << accumSize;
2474       unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2475       accumSize -= HOST_CHAR_BIT;
2476       if (accumSize < 0)
2477         accumSize = 0;
2478       accum >>= HOST_CHAR_BIT;
2479       unpacked_bytes_left -= 1;
2480       unpacked_idx += delta;
2481     }
2482 }
2483
2484 /* Create a new value of type TYPE from the contents of OBJ starting
2485    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2486    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2487    assigning through the result will set the field fetched from.
2488    VALADDR is ignored unless OBJ is NULL, in which case,
2489    VALADDR+OFFSET must address the start of storage containing the 
2490    packed value.  The value returned  in this case is never an lval.
2491    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2492
2493 struct value *
2494 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2495                                 long offset, int bit_offset, int bit_size,
2496                                 struct type *type)
2497 {
2498   struct value *v;
2499   const gdb_byte *src;                /* First byte containing data to unpack */
2500   gdb_byte *unpacked;
2501   const int is_scalar = is_scalar_type (type);
2502   const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2503   gdb::byte_vector staging;
2504
2505   type = ada_check_typedef (type);
2506
2507   if (obj == NULL)
2508     src = valaddr + offset;
2509   else
2510     src = value_contents (obj) + offset;
2511
2512   if (is_dynamic_type (type))
2513     {
2514       /* The length of TYPE might by dynamic, so we need to resolve
2515          TYPE in order to know its actual size, which we then use
2516          to create the contents buffer of the value we return.
2517          The difficulty is that the data containing our object is
2518          packed, and therefore maybe not at a byte boundary.  So, what
2519          we do, is unpack the data into a byte-aligned buffer, and then
2520          use that buffer as our object's value for resolving the type.  */
2521       int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2522       staging.resize (staging_len);
2523
2524       ada_unpack_from_contents (src, bit_offset, bit_size,
2525                                 staging.data (), staging.size (),
2526                                 is_big_endian, has_negatives (type),
2527                                 is_scalar);
2528       type = resolve_dynamic_type (type, staging.data (), 0);
2529       if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2530         {
2531           /* This happens when the length of the object is dynamic,
2532              and is actually smaller than the space reserved for it.
2533              For instance, in an array of variant records, the bit_size
2534              we're given is the array stride, which is constant and
2535              normally equal to the maximum size of its element.
2536              But, in reality, each element only actually spans a portion
2537              of that stride.  */
2538           bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2539         }
2540     }
2541
2542   if (obj == NULL)
2543     {
2544       v = allocate_value (type);
2545       src = valaddr + offset;
2546     }
2547   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2548     {
2549       int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2550       gdb_byte *buf;
2551
2552       v = value_at (type, value_address (obj) + offset);
2553       buf = (gdb_byte *) alloca (src_len);
2554       read_memory (value_address (v), buf, src_len);
2555       src = buf;
2556     }
2557   else
2558     {
2559       v = allocate_value (type);
2560       src = value_contents (obj) + offset;
2561     }
2562
2563   if (obj != NULL)
2564     {
2565       long new_offset = offset;
2566
2567       set_value_component_location (v, obj);
2568       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2569       set_value_bitsize (v, bit_size);
2570       if (value_bitpos (v) >= HOST_CHAR_BIT)
2571         {
2572           ++new_offset;
2573           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2574         }
2575       set_value_offset (v, new_offset);
2576
2577       /* Also set the parent value.  This is needed when trying to
2578          assign a new value (in inferior memory).  */
2579       set_value_parent (v, obj);
2580     }
2581   else
2582     set_value_bitsize (v, bit_size);
2583   unpacked = value_contents_writeable (v);
2584
2585   if (bit_size == 0)
2586     {
2587       memset (unpacked, 0, TYPE_LENGTH (type));
2588       return v;
2589     }
2590
2591   if (staging.size () == TYPE_LENGTH (type))
2592     {
2593       /* Small short-cut: If we've unpacked the data into a buffer
2594          of the same size as TYPE's length, then we can reuse that,
2595          instead of doing the unpacking again.  */
2596       memcpy (unpacked, staging.data (), staging.size ());
2597     }
2598   else
2599     ada_unpack_from_contents (src, bit_offset, bit_size,
2600                               unpacked, TYPE_LENGTH (type),
2601                               is_big_endian, has_negatives (type), is_scalar);
2602
2603   return v;
2604 }
2605
2606 /* Store the contents of FROMVAL into the location of TOVAL.
2607    Return a new value with the location of TOVAL and contents of
2608    FROMVAL.   Handles assignment into packed fields that have
2609    floating-point or non-scalar types.  */
2610
2611 static struct value *
2612 ada_value_assign (struct value *toval, struct value *fromval)
2613 {
2614   struct type *type = value_type (toval);
2615   int bits = value_bitsize (toval);
2616
2617   toval = ada_coerce_ref (toval);
2618   fromval = ada_coerce_ref (fromval);
2619
2620   if (ada_is_direct_array_type (value_type (toval)))
2621     toval = ada_coerce_to_simple_array (toval);
2622   if (ada_is_direct_array_type (value_type (fromval)))
2623     fromval = ada_coerce_to_simple_array (fromval);
2624
2625   if (!deprecated_value_modifiable (toval))
2626     error (_("Left operand of assignment is not a modifiable lvalue."));
2627
2628   if (VALUE_LVAL (toval) == lval_memory
2629       && bits > 0
2630       && (TYPE_CODE (type) == TYPE_CODE_FLT
2631           || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2632     {
2633       int len = (value_bitpos (toval)
2634                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2635       int from_size;
2636       gdb_byte *buffer = (gdb_byte *) alloca (len);
2637       struct value *val;
2638       CORE_ADDR to_addr = value_address (toval);
2639
2640       if (TYPE_CODE (type) == TYPE_CODE_FLT)
2641         fromval = value_cast (type, fromval);
2642
2643       read_memory (to_addr, buffer, len);
2644       from_size = value_bitsize (fromval);
2645       if (from_size == 0)
2646         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2647
2648       const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
2649       ULONGEST from_offset = 0;
2650       if (is_big_endian && is_scalar_type (value_type (fromval)))
2651         from_offset = from_size - bits;
2652       copy_bitwise (buffer, value_bitpos (toval),
2653                     value_contents (fromval), from_offset,
2654                     bits, is_big_endian);
2655       write_memory_with_notification (to_addr, buffer, len);
2656
2657       val = value_copy (toval);
2658       memcpy (value_contents_raw (val), value_contents (fromval),
2659               TYPE_LENGTH (type));
2660       deprecated_set_value_type (val, type);
2661
2662       return val;
2663     }
2664
2665   return value_assign (toval, fromval);
2666 }
2667
2668
2669 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2670    CONTAINER, assign the contents of VAL to COMPONENTS's place in
2671    CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2672    COMPONENT, and not the inferior's memory.  The current contents
2673    of COMPONENT are ignored.
2674
2675    Although not part of the initial design, this function also works
2676    when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2677    had a null address, and COMPONENT had an address which is equal to
2678    its offset inside CONTAINER.  */
2679
2680 static void
2681 value_assign_to_component (struct value *container, struct value *component,
2682                            struct value *val)
2683 {
2684   LONGEST offset_in_container =
2685     (LONGEST)  (value_address (component) - value_address (container));
2686   int bit_offset_in_container =
2687     value_bitpos (component) - value_bitpos (container);
2688   int bits;
2689
2690   val = value_cast (value_type (component), val);
2691
2692   if (value_bitsize (component) == 0)
2693     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2694   else
2695     bits = value_bitsize (component);
2696
2697   if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
2698     {
2699       int src_offset;
2700
2701       if (is_scalar_type (check_typedef (value_type (component))))
2702         src_offset
2703           = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2704       else
2705         src_offset = 0;
2706       copy_bitwise (value_contents_writeable (container) + offset_in_container,
2707                     value_bitpos (container) + bit_offset_in_container,
2708                     value_contents (val), src_offset, bits, 1);
2709     }
2710   else
2711     copy_bitwise (value_contents_writeable (container) + offset_in_container,
2712                   value_bitpos (container) + bit_offset_in_container,
2713                   value_contents (val), 0, bits, 0);
2714 }
2715
2716 /* Determine if TYPE is an access to an unconstrained array.  */
2717
2718 bool
2719 ada_is_access_to_unconstrained_array (struct type *type)
2720 {
2721   return (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
2722           && is_thick_pntr (ada_typedef_target_type (type)));
2723 }
2724
2725 /* The value of the element of array ARR at the ARITY indices given in IND.
2726    ARR may be either a simple array, GNAT array descriptor, or pointer
2727    thereto.  */
2728
2729 struct value *
2730 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2731 {
2732   int k;
2733   struct value *elt;
2734   struct type *elt_type;
2735
2736   elt = ada_coerce_to_simple_array (arr);
2737
2738   elt_type = ada_check_typedef (value_type (elt));
2739   if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2740       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2741     return value_subscript_packed (elt, arity, ind);
2742
2743   for (k = 0; k < arity; k += 1)
2744     {
2745       struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
2746
2747       if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2748         error (_("too many subscripts (%d expected)"), k);
2749
2750       elt = value_subscript (elt, pos_atr (ind[k]));
2751
2752       if (ada_is_access_to_unconstrained_array (saved_elt_type)
2753           && TYPE_CODE (value_type (elt)) != TYPE_CODE_TYPEDEF)
2754         {
2755           /* The element is a typedef to an unconstrained array,
2756              except that the value_subscript call stripped the
2757              typedef layer.  The typedef layer is GNAT's way to
2758              specify that the element is, at the source level, an
2759              access to the unconstrained array, rather than the
2760              unconstrained array.  So, we need to restore that
2761              typedef layer, which we can do by forcing the element's
2762              type back to its original type. Otherwise, the returned
2763              value is going to be printed as the array, rather
2764              than as an access.  Another symptom of the same issue
2765              would be that an expression trying to dereference the
2766              element would also be improperly rejected.  */
2767           deprecated_set_value_type (elt, saved_elt_type);
2768         }
2769
2770       elt_type = ada_check_typedef (value_type (elt));
2771     }
2772
2773   return elt;
2774 }
2775
2776 /* Assuming ARR is a pointer to a GDB array, the value of the element
2777    of *ARR at the ARITY indices given in IND.
2778    Does not read the entire array into memory.
2779
2780    Note: Unlike what one would expect, this function is used instead of
2781    ada_value_subscript for basically all non-packed array types.  The reason
2782    for this is that a side effect of doing our own pointer arithmetics instead
2783    of relying on value_subscript is that there is no implicit typedef peeling.
2784    This is important for arrays of array accesses, where it allows us to
2785    preserve the fact that the array's element is an array access, where the
2786    access part os encoded in a typedef layer.  */
2787
2788 static struct value *
2789 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2790 {
2791   int k;
2792   struct value *array_ind = ada_value_ind (arr);
2793   struct type *type
2794     = check_typedef (value_enclosing_type (array_ind));
2795
2796   if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2797       && TYPE_FIELD_BITSIZE (type, 0) > 0)
2798     return value_subscript_packed (array_ind, arity, ind);
2799
2800   for (k = 0; k < arity; k += 1)
2801     {
2802       LONGEST lwb, upb;
2803       struct value *lwb_value;
2804
2805       if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2806         error (_("too many subscripts (%d expected)"), k);
2807       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2808                         value_copy (arr));
2809       get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2810       lwb_value = value_from_longest (value_type(ind[k]), lwb);
2811       arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
2812       type = TYPE_TARGET_TYPE (type);
2813     }
2814
2815   return value_ind (arr);
2816 }
2817
2818 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2819    actual type of ARRAY_PTR is ignored), returns the Ada slice of
2820    HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
2821    this array is LOW, as per Ada rules.  */
2822 static struct value *
2823 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2824                           int low, int high)
2825 {
2826   struct type *type0 = ada_check_typedef (type);
2827   struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
2828   struct type *index_type
2829     = create_static_range_type (NULL, base_index_type, low, high);
2830   struct type *slice_type = create_array_type_with_stride
2831                               (NULL, TYPE_TARGET_TYPE (type0), index_type,
2832                                get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2833                                TYPE_FIELD_BITSIZE (type0, 0));
2834   int base_low =  ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2835   LONGEST base_low_pos, low_pos;
2836   CORE_ADDR base;
2837
2838   if (!discrete_position (base_index_type, low, &low_pos)
2839       || !discrete_position (base_index_type, base_low, &base_low_pos))
2840     {
2841       warning (_("unable to get positions in slice, use bounds instead"));
2842       low_pos = low;
2843       base_low_pos = base_low;
2844     }
2845
2846   base = value_as_address (array_ptr)
2847     + ((low_pos - base_low_pos)
2848        * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
2849   return value_at_lazy (slice_type, base);
2850 }
2851
2852
2853 static struct value *
2854 ada_value_slice (struct value *array, int low, int high)
2855 {
2856   struct type *type = ada_check_typedef (value_type (array));
2857   struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2858   struct type *index_type
2859     = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2860   struct type *slice_type = create_array_type_with_stride
2861                               (NULL, TYPE_TARGET_TYPE (type), index_type,
2862                                get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2863                                TYPE_FIELD_BITSIZE (type, 0));
2864   LONGEST low_pos, high_pos;
2865
2866   if (!discrete_position (base_index_type, low, &low_pos)
2867       || !discrete_position (base_index_type, high, &high_pos))
2868     {
2869       warning (_("unable to get positions in slice, use bounds instead"));
2870       low_pos = low;
2871       high_pos = high;
2872     }
2873
2874   return value_cast (slice_type,
2875                      value_slice (array, low, high_pos - low_pos + 1));
2876 }
2877
2878 /* If type is a record type in the form of a standard GNAT array
2879    descriptor, returns the number of dimensions for type.  If arr is a
2880    simple array, returns the number of "array of"s that prefix its
2881    type designation.  Otherwise, returns 0.  */
2882
2883 int
2884 ada_array_arity (struct type *type)
2885 {
2886   int arity;
2887
2888   if (type == NULL)
2889     return 0;
2890
2891   type = desc_base_type (type);
2892
2893   arity = 0;
2894   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2895     return desc_arity (desc_bounds_type (type));
2896   else
2897     while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2898       {
2899         arity += 1;
2900         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2901       }
2902
2903   return arity;
2904 }
2905
2906 /* If TYPE is a record type in the form of a standard GNAT array
2907    descriptor or a simple array type, returns the element type for
2908    TYPE after indexing by NINDICES indices, or by all indices if
2909    NINDICES is -1.  Otherwise, returns NULL.  */
2910
2911 struct type *
2912 ada_array_element_type (struct type *type, int nindices)
2913 {
2914   type = desc_base_type (type);
2915
2916   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2917     {
2918       int k;
2919       struct type *p_array_type;
2920
2921       p_array_type = desc_data_target_type (type);
2922
2923       k = ada_array_arity (type);
2924       if (k == 0)
2925         return NULL;
2926
2927       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
2928       if (nindices >= 0 && k > nindices)
2929         k = nindices;
2930       while (k > 0 && p_array_type != NULL)
2931         {
2932           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2933           k -= 1;
2934         }
2935       return p_array_type;
2936     }
2937   else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2938     {
2939       while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
2940         {
2941           type = TYPE_TARGET_TYPE (type);
2942           nindices -= 1;
2943         }
2944       return type;
2945     }
2946
2947   return NULL;
2948 }
2949
2950 /* The type of nth index in arrays of given type (n numbering from 1).
2951    Does not examine memory.  Throws an error if N is invalid or TYPE
2952    is not an array type.  NAME is the name of the Ada attribute being
2953    evaluated ('range, 'first, 'last, or 'length); it is used in building
2954    the error message.  */
2955
2956 static struct type *
2957 ada_index_type (struct type *type, int n, const char *name)
2958 {
2959   struct type *result_type;
2960
2961   type = desc_base_type (type);
2962
2963   if (n < 0 || n > ada_array_arity (type))
2964     error (_("invalid dimension number to '%s"), name);
2965
2966   if (ada_is_simple_array_type (type))
2967     {
2968       int i;
2969
2970       for (i = 1; i < n; i += 1)
2971         type = TYPE_TARGET_TYPE (type);
2972       result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2973       /* FIXME: The stabs type r(0,0);bound;bound in an array type
2974          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
2975          perhaps stabsread.c would make more sense.  */
2976       if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2977         result_type = NULL;
2978     }
2979   else
2980     {
2981       result_type = desc_index_type (desc_bounds_type (type), n);
2982       if (result_type == NULL)
2983         error (_("attempt to take bound of something that is not an array"));
2984     }
2985
2986   return result_type;
2987 }
2988
2989 /* Given that arr is an array type, returns the lower bound of the
2990    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2991    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
2992    array-descriptor type.  It works for other arrays with bounds supplied
2993    by run-time quantities other than discriminants.  */
2994
2995 static LONGEST
2996 ada_array_bound_from_type (struct type *arr_type, int n, int which)
2997 {
2998   struct type *type, *index_type_desc, *index_type;
2999   int i;
3000
3001   gdb_assert (which == 0 || which == 1);
3002
3003   if (ada_is_constrained_packed_array_type (arr_type))
3004     arr_type = decode_constrained_packed_array_type (arr_type);
3005
3006   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3007     return (LONGEST) - which;
3008
3009   if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3010     type = TYPE_TARGET_TYPE (arr_type);
3011   else
3012     type = arr_type;
3013
3014   if (TYPE_FIXED_INSTANCE (type))
3015     {
3016       /* The array has already been fixed, so we do not need to
3017          check the parallel ___XA type again.  That encoding has
3018          already been applied, so ignore it now.  */
3019       index_type_desc = NULL;
3020     }
3021   else
3022     {
3023       index_type_desc = ada_find_parallel_type (type, "___XA");
3024       ada_fixup_array_indexes_type (index_type_desc);
3025     }
3026
3027   if (index_type_desc != NULL)
3028     index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3029                                       NULL);
3030   else
3031     {
3032       struct type *elt_type = check_typedef (type);
3033
3034       for (i = 1; i < n; i++)
3035         elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3036
3037       index_type = TYPE_INDEX_TYPE (elt_type);
3038     }
3039
3040   return
3041     (LONGEST) (which == 0
3042                ? ada_discrete_type_low_bound (index_type)
3043                : ada_discrete_type_high_bound (index_type));
3044 }
3045
3046 /* Given that arr is an array value, returns the lower bound of the
3047    nth index (numbering from 1) if WHICH is 0, and the upper bound if
3048    WHICH is 1.  This routine will also work for arrays with bounds
3049    supplied by run-time quantities other than discriminants.  */
3050
3051 static LONGEST
3052 ada_array_bound (struct value *arr, int n, int which)
3053 {
3054   struct type *arr_type;
3055
3056   if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3057     arr = value_ind (arr);
3058   arr_type = value_enclosing_type (arr);
3059
3060   if (ada_is_constrained_packed_array_type (arr_type))
3061     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3062   else if (ada_is_simple_array_type (arr_type))
3063     return ada_array_bound_from_type (arr_type, n, which);
3064   else
3065     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3066 }
3067
3068 /* Given that arr is an array value, returns the length of the
3069    nth index.  This routine will also work for arrays with bounds
3070    supplied by run-time quantities other than discriminants.
3071    Does not work for arrays indexed by enumeration types with representation
3072    clauses at the moment.  */
3073
3074 static LONGEST
3075 ada_array_length (struct value *arr, int n)
3076 {
3077   struct type *arr_type, *index_type;
3078   int low, high;
3079
3080   if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3081     arr = value_ind (arr);
3082   arr_type = value_enclosing_type (arr);
3083
3084   if (ada_is_constrained_packed_array_type (arr_type))
3085     return ada_array_length (decode_constrained_packed_array (arr), n);
3086
3087   if (ada_is_simple_array_type (arr_type))
3088     {
3089       low = ada_array_bound_from_type (arr_type, n, 0);
3090       high = ada_array_bound_from_type (arr_type, n, 1);
3091     }
3092   else
3093     {
3094       low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3095       high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3096     }
3097
3098   arr_type = check_typedef (arr_type);
3099   index_type = ada_index_type (arr_type, n, "length");
3100   if (index_type != NULL)
3101     {
3102       struct type *base_type;
3103       if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3104         base_type = TYPE_TARGET_TYPE (index_type);
3105       else
3106         base_type = index_type;
3107
3108       low = pos_atr (value_from_longest (base_type, low));
3109       high = pos_atr (value_from_longest (base_type, high));
3110     }
3111   return high - low + 1;
3112 }
3113
3114 /* An array whose type is that of ARR_TYPE (an array type), with
3115    bounds LOW to HIGH, but whose contents are unimportant.  If HIGH is
3116    less than LOW, then LOW-1 is used.  */
3117
3118 static struct value *
3119 empty_array (struct type *arr_type, int low, int high)
3120 {
3121   struct type *arr_type0 = ada_check_typedef (arr_type);
3122   struct type *index_type
3123     = create_static_range_type
3124         (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low,
3125          high < low ? low - 1 : high);
3126   struct type *elt_type = ada_array_element_type (arr_type0, 1);
3127
3128   return allocate_value (create_array_type (NULL, elt_type, index_type));
3129 }
3130 \f
3131
3132                                 /* Name resolution */
3133
3134 /* The "decoded" name for the user-definable Ada operator corresponding
3135    to OP.  */
3136
3137 static const char *
3138 ada_decoded_op_name (enum exp_opcode op)
3139 {
3140   int i;
3141
3142   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3143     {
3144       if (ada_opname_table[i].op == op)
3145         return ada_opname_table[i].decoded;
3146     }
3147   error (_("Could not find operator name for opcode"));
3148 }
3149
3150 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3151    in a listing of choices during disambiguation (see sort_choices, below).
3152    The idea is that overloadings of a subprogram name from the
3153    same package should sort in their source order.  We settle for ordering
3154    such symbols by their trailing number (__N  or $N).  */
3155
3156 static int
3157 encoded_ordered_before (const char *N0, const char *N1)
3158 {
3159   if (N1 == NULL)
3160     return 0;
3161   else if (N0 == NULL)
3162     return 1;
3163   else
3164     {
3165       int k0, k1;
3166
3167       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3168         ;
3169       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3170         ;
3171       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3172           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3173         {
3174           int n0, n1;
3175
3176           n0 = k0;
3177           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3178             n0 -= 1;
3179           n1 = k1;
3180           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3181             n1 -= 1;
3182           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3183             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3184         }
3185       return (strcmp (N0, N1) < 0);
3186     }
3187 }
3188
3189 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3190    encoded names.  */
3191
3192 static void
3193 sort_choices (struct block_symbol syms[], int nsyms)
3194 {
3195   int i;
3196
3197   for (i = 1; i < nsyms; i += 1)
3198     {
3199       struct block_symbol sym = syms[i];
3200       int j;
3201
3202       for (j = i - 1; j >= 0; j -= 1)
3203         {
3204           if (encoded_ordered_before (syms[j].symbol->linkage_name (),
3205                                       sym.symbol->linkage_name ()))
3206             break;
3207           syms[j + 1] = syms[j];
3208         }
3209       syms[j + 1] = sym;
3210     }
3211 }
3212
3213 /* Whether GDB should display formals and return types for functions in the
3214    overloads selection menu.  */
3215 static bool print_signatures = true;
3216
3217 /* Print the signature for SYM on STREAM according to the FLAGS options.  For
3218    all but functions, the signature is just the name of the symbol.  For
3219    functions, this is the name of the function, the list of types for formals
3220    and the return type (if any).  */
3221
3222 static void
3223 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3224                             const struct type_print_options *flags)
3225 {
3226   struct type *type = SYMBOL_TYPE (sym);
3227
3228   fprintf_filtered (stream, "%s", sym->print_name ());
3229   if (!print_signatures
3230       || type == NULL
3231       || TYPE_CODE (type) != TYPE_CODE_FUNC)
3232     return;
3233
3234   if (TYPE_NFIELDS (type) > 0)
3235     {
3236       int i;
3237
3238       fprintf_filtered (stream, " (");
3239       for (i = 0; i < TYPE_NFIELDS (type); ++i)
3240         {
3241           if (i > 0)
3242             fprintf_filtered (stream, "; ");
3243           ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3244                           flags);
3245         }
3246       fprintf_filtered (stream, ")");
3247     }
3248   if (TYPE_TARGET_TYPE (type) != NULL
3249       && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3250     {
3251       fprintf_filtered (stream, " return ");
3252       ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3253     }
3254 }
3255
3256 /* Read and validate a set of numeric choices from the user in the
3257    range 0 .. N_CHOICES-1.  Place the results in increasing
3258    order in CHOICES[0 .. N-1], and return N.
3259
3260    The user types choices as a sequence of numbers on one line
3261    separated by blanks, encoding them as follows:
3262
3263      + A choice of 0 means to cancel the selection, throwing an error.
3264      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3265      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3266
3267    The user is not allowed to choose more than MAX_RESULTS values.
3268
3269    ANNOTATION_SUFFIX, if present, is used to annotate the input
3270    prompts (for use with the -f switch).  */
3271
3272 static int
3273 get_selections (int *choices, int n_choices, int max_results,
3274                 int is_all_choice, const char *annotation_suffix)
3275 {
3276   const char *args;
3277   const char *prompt;
3278   int n_chosen;
3279   int first_choice = is_all_choice ? 2 : 1;
3280
3281   prompt = getenv ("PS2");
3282   if (prompt == NULL)
3283     prompt = "> ";
3284
3285   args = command_line_input (prompt, annotation_suffix);
3286
3287   if (args == NULL)
3288     error_no_arg (_("one or more choice numbers"));
3289
3290   n_chosen = 0;
3291
3292   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3293      order, as given in args.  Choices are validated.  */
3294   while (1)
3295     {
3296       char *args2;
3297       int choice, j;
3298
3299       args = skip_spaces (args);
3300       if (*args == '\0' && n_chosen == 0)
3301         error_no_arg (_("one or more choice numbers"));
3302       else if (*args == '\0')
3303         break;
3304
3305       choice = strtol (args, &args2, 10);
3306       if (args == args2 || choice < 0
3307           || choice > n_choices + first_choice - 1)
3308         error (_("Argument must be choice number"));
3309       args = args2;
3310
3311       if (choice == 0)
3312         error (_("cancelled"));
3313
3314       if (choice < first_choice)
3315         {
3316           n_chosen = n_choices;
3317           for (j = 0; j < n_choices; j += 1)
3318             choices[j] = j;
3319           break;
3320         }
3321       choice -= first_choice;
3322
3323       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3324         {
3325         }
3326
3327       if (j < 0 || choice != choices[j])
3328         {
3329           int k;
3330
3331           for (k = n_chosen - 1; k > j; k -= 1)
3332             choices[k + 1] = choices[k];
3333           choices[j + 1] = choice;
3334           n_chosen += 1;
3335         }
3336     }
3337
3338   if (n_chosen > max_results)
3339     error (_("Select no more than %d of the above"), max_results);
3340
3341   return n_chosen;
3342 }
3343
3344 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3345    by asking the user (if necessary), returning the number selected,
3346    and setting the first elements of SYMS items.  Error if no symbols
3347    selected.  */
3348
3349 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3350    to be re-integrated one of these days.  */
3351
3352 static int
3353 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3354 {
3355   int i;
3356   int *chosen = XALLOCAVEC (int , nsyms);
3357   int n_chosen;
3358   int first_choice = (max_results == 1) ? 1 : 2;
3359   const char *select_mode = multiple_symbols_select_mode ();
3360
3361   if (max_results < 1)
3362     error (_("Request to select 0 symbols!"));
3363   if (nsyms <= 1)
3364     return nsyms;
3365
3366   if (select_mode == multiple_symbols_cancel)
3367     error (_("\
3368 canceled because the command is ambiguous\n\
3369 See set/show multiple-symbol."));
3370
3371   /* If select_mode is "all", then return all possible symbols.
3372      Only do that if more than one symbol can be selected, of course.
3373      Otherwise, display the menu as usual.  */
3374   if (select_mode == multiple_symbols_all && max_results > 1)
3375     return nsyms;
3376
3377   printf_filtered (_("[0] cancel\n"));
3378   if (max_results > 1)
3379     printf_filtered (_("[1] all\n"));
3380
3381   sort_choices (syms, nsyms);
3382
3383   for (i = 0; i < nsyms; i += 1)
3384     {
3385       if (syms[i].symbol == NULL)
3386         continue;
3387
3388       if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
3389         {
3390           struct symtab_and_line sal =
3391             find_function_start_sal (syms[i].symbol, 1);
3392
3393           printf_filtered ("[%d] ", i + first_choice);
3394           ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3395                                       &type_print_raw_options);
3396           if (sal.symtab == NULL)
3397             printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3398                              metadata_style.style ().ptr (), nullptr, sal.line);
3399           else
3400             printf_filtered
3401               (_(" at %ps:%d\n"),
3402                styled_string (file_name_style.style (),
3403                               symtab_to_filename_for_display (sal.symtab)),
3404                sal.line);
3405           continue;
3406         }
3407       else
3408         {
3409           int is_enumeral =
3410             (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3411              && SYMBOL_TYPE (syms[i].symbol) != NULL
3412              && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
3413           struct symtab *symtab = NULL;
3414
3415           if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3416             symtab = symbol_symtab (syms[i].symbol);
3417
3418           if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
3419             {
3420               printf_filtered ("[%d] ", i + first_choice);
3421               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3422                                           &type_print_raw_options);
3423               printf_filtered (_(" at %s:%d\n"),
3424                                symtab_to_filename_for_display (symtab),
3425                                SYMBOL_LINE (syms[i].symbol));
3426             }
3427           else if (is_enumeral
3428                    && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
3429             {
3430               printf_filtered (("[%d] "), i + first_choice);
3431               ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
3432                               gdb_stdout, -1, 0, &type_print_raw_options);
3433               printf_filtered (_("'(%s) (enumeral)\n"),
3434                                syms[i].symbol->print_name ());
3435             }
3436           else
3437             {
3438               printf_filtered ("[%d] ", i + first_choice);
3439               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3440                                           &type_print_raw_options);
3441
3442               if (symtab != NULL)
3443                 printf_filtered (is_enumeral
3444                                  ? _(" in %s (enumeral)\n")
3445                                  : _(" at %s:?\n"),
3446                                  symtab_to_filename_for_display (symtab));
3447               else
3448                 printf_filtered (is_enumeral
3449                                  ? _(" (enumeral)\n")
3450                                  : _(" at ?\n"));
3451             }
3452         }
3453     }
3454
3455   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3456                              "overload-choice");
3457
3458   for (i = 0; i < n_chosen; i += 1)
3459     syms[i] = syms[chosen[i]];
3460
3461   return n_chosen;
3462 }
3463
3464 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3465    references (marked by OP_VAR_VALUE nodes in which the symbol has an
3466    undefined namespace) and converts operators that are
3467    user-defined into appropriate function calls.  If CONTEXT_TYPE is
3468    non-null, it provides a preferred result type [at the moment, only
3469    type void has any effect---causing procedures to be preferred over
3470    functions in calls].  A null CONTEXT_TYPE indicates that a non-void
3471    return type is preferred.  May change (expand) *EXP.  */
3472
3473 static void
3474 resolve (expression_up *expp, int void_context_p, int parse_completion,
3475          innermost_block_tracker *tracker)
3476 {
3477   struct type *context_type = NULL;
3478   int pc = 0;
3479
3480   if (void_context_p)
3481     context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3482
3483   resolve_subexp (expp, &pc, 1, context_type, parse_completion, tracker);
3484 }
3485
3486 /* Resolve the operator of the subexpression beginning at
3487    position *POS of *EXPP.  "Resolving" consists of replacing
3488    the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3489    with their resolutions, replacing built-in operators with
3490    function calls to user-defined operators, where appropriate, and,
3491    when DEPROCEDURE_P is non-zero, converting function-valued variables
3492    into parameterless calls.  May expand *EXPP.  The CONTEXT_TYPE functions
3493    are as in ada_resolve, above.  */
3494
3495 static struct value *
3496 resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
3497                 struct type *context_type, int parse_completion,
3498                 innermost_block_tracker *tracker)
3499 {
3500   int pc = *pos;
3501   int i;
3502   struct expression *exp;       /* Convenience: == *expp.  */
3503   enum exp_opcode op = (*expp)->elts[pc].opcode;
3504   struct value **argvec;        /* Vector of operand types (alloca'ed).  */
3505   int nargs;                    /* Number of operands.  */
3506   int oplen;
3507
3508   argvec = NULL;
3509   nargs = 0;
3510   exp = expp->get ();
3511
3512   /* Pass one: resolve operands, saving their types and updating *pos,
3513      if needed.  */
3514   switch (op)
3515     {
3516     case OP_FUNCALL:
3517       if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3518           && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3519         *pos += 7;
3520       else
3521         {
3522           *pos += 3;
3523           resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
3524         }
3525       nargs = longest_to_int (exp->elts[pc + 1].longconst);
3526       break;
3527
3528     case UNOP_ADDR:
3529       *pos += 1;
3530       resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
3531       break;
3532
3533     case UNOP_QUAL:
3534       *pos += 3;
3535       resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type),
3536                       parse_completion, tracker);
3537       break;
3538
3539     case OP_ATR_MODULUS:
3540     case OP_ATR_SIZE:
3541     case OP_ATR_TAG:
3542     case OP_ATR_FIRST:
3543     case OP_ATR_LAST:
3544     case OP_ATR_LENGTH:
3545     case OP_ATR_POS:
3546     case OP_ATR_VAL:
3547     case OP_ATR_MIN:
3548     case OP_ATR_MAX:
3549     case TERNOP_IN_RANGE:
3550     case BINOP_IN_BOUNDS:
3551     case UNOP_IN_RANGE:
3552     case OP_AGGREGATE:
3553     case OP_OTHERS:
3554     case OP_CHOICES:
3555     case OP_POSITIONAL:
3556     case OP_DISCRETE_RANGE:
3557     case OP_NAME:
3558       ada_forward_operator_length (exp, pc, &oplen, &nargs);
3559       *pos += oplen;
3560       break;
3561
3562     case BINOP_ASSIGN:
3563       {
3564         struct value *arg1;
3565
3566         *pos += 1;
3567         arg1 = resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
3568         if (arg1 == NULL)
3569           resolve_subexp (expp, pos, 1, NULL, parse_completion, tracker);
3570         else
3571           resolve_subexp (expp, pos, 1, value_type (arg1), parse_completion,
3572                           tracker);
3573         break;
3574       }
3575
3576     case UNOP_CAST:
3577       *pos += 3;
3578       nargs = 1;
3579       break;
3580
3581     case BINOP_ADD:
3582     case BINOP_SUB:
3583     case BINOP_MUL:
3584     case BINOP_DIV:
3585     case BINOP_REM:
3586     case BINOP_MOD:
3587     case BINOP_EXP:
3588     case BINOP_CONCAT:
3589     case BINOP_LOGICAL_AND:
3590     case BINOP_LOGICAL_OR:
3591     case BINOP_BITWISE_AND:
3592     case BINOP_BITWISE_IOR:
3593     case BINOP_BITWISE_XOR:
3594
3595     case BINOP_EQUAL:
3596     case BINOP_NOTEQUAL:
3597     case BINOP_LESS:
3598     case BINOP_GTR:
3599     case BINOP_LEQ:
3600     case BINOP_GEQ:
3601
3602     case BINOP_REPEAT:
3603     case BINOP_SUBSCRIPT:
3604     case BINOP_COMMA:
3605       *pos += 1;
3606       nargs = 2;
3607       break;
3608
3609     case UNOP_NEG:
3610     case UNOP_PLUS:
3611     case UNOP_LOGICAL_NOT:
3612     case UNOP_ABS:
3613     case UNOP_IND:
3614       *pos += 1;
3615       nargs = 1;
3616       break;
3617
3618     case OP_LONG:
3619     case OP_FLOAT:
3620     case OP_VAR_VALUE:
3621     case OP_VAR_MSYM_VALUE:
3622       *pos += 4;
3623       break;
3624
3625     case OP_TYPE:
3626     case OP_BOOL:
3627     case OP_LAST:
3628     case OP_INTERNALVAR:
3629       *pos += 3;
3630       break;
3631
3632     case UNOP_MEMVAL:
3633       *pos += 3;
3634       nargs = 1;
3635       break;
3636
3637     case OP_REGISTER:
3638       *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3639       break;
3640
3641     case STRUCTOP_STRUCT:
3642       *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3643       nargs = 1;
3644       break;
3645
3646     case TERNOP_SLICE:
3647       *pos += 1;
3648       nargs = 3;
3649       break;
3650
3651     case OP_STRING:
3652       break;
3653
3654     default:
3655       error (_("Unexpected operator during name resolution"));
3656     }
3657
3658   argvec = XALLOCAVEC (struct value *, nargs + 1);
3659   for (i = 0; i < nargs; i += 1)
3660     argvec[i] = resolve_subexp (expp, pos, 1, NULL, parse_completion,
3661                                 tracker);
3662   argvec[i] = NULL;
3663   exp = expp->get ();
3664
3665   /* Pass two: perform any resolution on principal operator.  */
3666   switch (op)
3667     {
3668     default:
3669       break;
3670
3671     case OP_VAR_VALUE:
3672       if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
3673         {
3674           std::vector<struct block_symbol> candidates;
3675           int n_candidates;
3676
3677           n_candidates =
3678             ada_lookup_symbol_list (exp->elts[pc + 2].symbol->linkage_name (),
3679                                     exp->elts[pc + 1].block, VAR_DOMAIN,
3680                                     &candidates);
3681
3682           if (n_candidates > 1)
3683             {
3684               /* Types tend to get re-introduced locally, so if there
3685                  are any local symbols that are not types, first filter
3686                  out all types.  */
3687               int j;
3688               for (j = 0; j < n_candidates; j += 1)
3689                 switch (SYMBOL_CLASS (candidates[j].symbol))
3690                   {
3691                   case LOC_REGISTER:
3692                   case LOC_ARG:
3693                   case LOC_REF_ARG:
3694                   case LOC_REGPARM_ADDR:
3695                   case LOC_LOCAL:
3696                   case LOC_COMPUTED:
3697                     goto FoundNonType;
3698                   default:
3699                     break;
3700                   }
3701             FoundNonType:
3702               if (j < n_candidates)
3703                 {
3704                   j = 0;
3705                   while (j < n_candidates)
3706                     {
3707                       if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
3708                         {
3709                           candidates[j] = candidates[n_candidates - 1];
3710                           n_candidates -= 1;
3711                         }
3712                       else
3713                         j += 1;
3714                     }
3715                 }
3716             }
3717
3718           if (n_candidates == 0)
3719             error (_("No definition found for %s"),
3720                    exp->elts[pc + 2].symbol->print_name ());
3721           else if (n_candidates == 1)
3722             i = 0;
3723           else if (deprocedure_p
3724                    && !is_nonfunction (candidates.data (), n_candidates))
3725             {
3726               i = ada_resolve_function
3727                 (candidates.data (), n_candidates, NULL, 0,
3728                  exp->elts[pc + 2].symbol->linkage_name (),
3729                  context_type, parse_completion);
3730               if (i < 0)
3731                 error (_("Could not find a match for %s"),
3732                        exp->elts[pc + 2].symbol->print_name ());
3733             }
3734           else
3735             {
3736               printf_filtered (_("Multiple matches for %s\n"),
3737                                exp->elts[pc + 2].symbol->print_name ());
3738               user_select_syms (candidates.data (), n_candidates, 1);
3739               i = 0;
3740             }
3741
3742           exp->elts[pc + 1].block = candidates[i].block;
3743           exp->elts[pc + 2].symbol = candidates[i].symbol;
3744           tracker->update (candidates[i]);
3745         }
3746
3747       if (deprocedure_p
3748           && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3749               == TYPE_CODE_FUNC))
3750         {
3751           replace_operator_with_call (expp, pc, 0, 4,
3752                                       exp->elts[pc + 2].symbol,
3753                                       exp->elts[pc + 1].block);
3754           exp = expp->get ();
3755         }
3756       break;
3757
3758     case OP_FUNCALL:
3759       {
3760         if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3761             && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3762           {
3763             std::vector<struct block_symbol> candidates;
3764             int n_candidates;
3765
3766             n_candidates =
3767               ada_lookup_symbol_list (exp->elts[pc + 5].symbol->linkage_name (),
3768                                       exp->elts[pc + 4].block, VAR_DOMAIN,
3769                                       &candidates);
3770
3771             if (n_candidates == 1)
3772               i = 0;
3773             else
3774               {
3775                 i = ada_resolve_function
3776                   (candidates.data (), n_candidates,
3777                    argvec, nargs,
3778                    exp->elts[pc + 5].symbol->linkage_name (),
3779                    context_type, parse_completion);
3780                 if (i < 0)
3781                   error (_("Could not find a match for %s"),
3782                          exp->elts[pc + 5].symbol->print_name ());
3783               }
3784
3785             exp->elts[pc + 4].block = candidates[i].block;
3786             exp->elts[pc + 5].symbol = candidates[i].symbol;
3787             tracker->update (candidates[i]);
3788           }
3789       }
3790       break;
3791     case BINOP_ADD:
3792     case BINOP_SUB:
3793     case BINOP_MUL:
3794     case BINOP_DIV:
3795     case BINOP_REM:
3796     case BINOP_MOD:
3797     case BINOP_CONCAT:
3798     case BINOP_BITWISE_AND:
3799     case BINOP_BITWISE_IOR:
3800     case BINOP_BITWISE_XOR:
3801     case BINOP_EQUAL:
3802     case BINOP_NOTEQUAL:
3803     case BINOP_LESS:
3804     case BINOP_GTR:
3805     case BINOP_LEQ:
3806     case BINOP_GEQ:
3807     case BINOP_EXP:
3808     case UNOP_NEG:
3809     case UNOP_PLUS:
3810     case UNOP_LOGICAL_NOT:
3811     case UNOP_ABS:
3812       if (possible_user_operator_p (op, argvec))
3813         {
3814           std::vector<struct block_symbol> candidates;
3815           int n_candidates;
3816
3817           n_candidates =
3818             ada_lookup_symbol_list (ada_decoded_op_name (op),
3819                                     NULL, VAR_DOMAIN,
3820                                     &candidates);
3821
3822           i = ada_resolve_function (candidates.data (), n_candidates, argvec,
3823                                     nargs, ada_decoded_op_name (op), NULL,
3824                                     parse_completion);
3825           if (i < 0)
3826             break;
3827
3828           replace_operator_with_call (expp, pc, nargs, 1,
3829                                       candidates[i].symbol,
3830                                       candidates[i].block);
3831           exp = expp->get ();
3832         }
3833       break;
3834
3835     case OP_TYPE:
3836     case OP_REGISTER:
3837       return NULL;
3838     }
3839
3840   *pos = pc;
3841   if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3842     return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3843                                     exp->elts[pc + 1].objfile,
3844                                     exp->elts[pc + 2].msymbol);
3845   else
3846     return evaluate_subexp_type (exp, pos);
3847 }
3848
3849 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  If
3850    MAY_DEREF is non-zero, the formal may be a pointer and the actual
3851    a non-pointer.  */
3852 /* The term "match" here is rather loose.  The match is heuristic and
3853    liberal.  */
3854
3855 static int
3856 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3857 {
3858   ftype = ada_check_typedef (ftype);
3859   atype = ada_check_typedef (atype);
3860
3861   if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3862     ftype = TYPE_TARGET_TYPE (ftype);
3863   if (TYPE_CODE (atype) == TYPE_CODE_REF)
3864     atype = TYPE_TARGET_TYPE (atype);
3865
3866   switch (TYPE_CODE (ftype))
3867     {
3868     default:
3869       return TYPE_CODE (ftype) == TYPE_CODE (atype);
3870     case TYPE_CODE_PTR:
3871       if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3872         return ada_type_match (TYPE_TARGET_TYPE (ftype),
3873                                TYPE_TARGET_TYPE (atype), 0);
3874       else
3875         return (may_deref
3876                 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3877     case TYPE_CODE_INT:
3878     case TYPE_CODE_ENUM:
3879     case TYPE_CODE_RANGE:
3880       switch (TYPE_CODE (atype))
3881         {
3882         case TYPE_CODE_INT:
3883         case TYPE_CODE_ENUM:
3884         case TYPE_CODE_RANGE:
3885           return 1;
3886         default:
3887           return 0;
3888         }
3889
3890     case TYPE_CODE_ARRAY:
3891       return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3892               || ada_is_array_descriptor_type (atype));
3893
3894     case TYPE_CODE_STRUCT:
3895       if (ada_is_array_descriptor_type (ftype))
3896         return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3897                 || ada_is_array_descriptor_type (atype));
3898       else
3899         return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3900                 && !ada_is_array_descriptor_type (atype));
3901
3902     case TYPE_CODE_UNION:
3903     case TYPE_CODE_FLT:
3904       return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3905     }
3906 }
3907
3908 /* Return non-zero if the formals of FUNC "sufficiently match" the
3909    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3910    may also be an enumeral, in which case it is treated as a 0-
3911    argument function.  */
3912
3913 static int
3914 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3915 {
3916   int i;
3917   struct type *func_type = SYMBOL_TYPE (func);
3918
3919   if (SYMBOL_CLASS (func) == LOC_CONST
3920       && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3921     return (n_actuals == 0);
3922   else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3923     return 0;
3924
3925   if (TYPE_NFIELDS (func_type) != n_actuals)
3926     return 0;
3927
3928   for (i = 0; i < n_actuals; i += 1)
3929     {
3930       if (actuals[i] == NULL)
3931         return 0;
3932       else
3933         {
3934           struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3935                                                                    i));
3936           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3937
3938           if (!ada_type_match (ftype, atype, 1))
3939             return 0;
3940         }
3941     }
3942   return 1;
3943 }
3944
3945 /* False iff function type FUNC_TYPE definitely does not produce a value
3946    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3947    FUNC_TYPE is not a valid function type with a non-null return type
3948    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3949
3950 static int
3951 return_match (struct type *func_type, struct type *context_type)
3952 {
3953   struct type *return_type;
3954
3955   if (func_type == NULL)
3956     return 1;
3957
3958   if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3959     return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3960   else
3961     return_type = get_base_type (func_type);
3962   if (return_type == NULL)
3963     return 1;
3964
3965   context_type = get_base_type (context_type);
3966
3967   if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3968     return context_type == NULL || return_type == context_type;
3969   else if (context_type == NULL)
3970     return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3971   else
3972     return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3973 }
3974
3975
3976 /* Returns the index in SYMS[0..NSYMS-1] that contains  the symbol for the
3977    function (if any) that matches the types of the NARGS arguments in
3978    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
3979    that returns that type, then eliminate matches that don't.  If
3980    CONTEXT_TYPE is void and there is at least one match that does not
3981    return void, eliminate all matches that do.
3982
3983    Asks the user if there is more than one match remaining.  Returns -1
3984    if there is no such symbol or none is selected.  NAME is used
3985    solely for messages.  May re-arrange and modify SYMS in
3986    the process; the index returned is for the modified vector.  */
3987
3988 static int
3989 ada_resolve_function (struct block_symbol syms[],
3990                       int nsyms, struct value **args, int nargs,
3991                       const char *name, struct type *context_type,
3992                       int parse_completion)
3993 {
3994   int fallback;
3995   int k;
3996   int m;                        /* Number of hits */
3997
3998   m = 0;
3999   /* In the first pass of the loop, we only accept functions matching
4000      context_type.  If none are found, we add a second pass of the loop
4001      where every function is accepted.  */
4002   for (fallback = 0; m == 0 && fallback < 2; fallback++)
4003     {
4004       for (k = 0; k < nsyms; k += 1)
4005         {
4006           struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
4007
4008           if (ada_args_match (syms[k].symbol, args, nargs)
4009               && (fallback || return_match (type, context_type)))
4010             {
4011               syms[m] = syms[k];
4012               m += 1;
4013             }
4014         }
4015     }
4016
4017   /* If we got multiple matches, ask the user which one to use.  Don't do this
4018      interactive thing during completion, though, as the purpose of the
4019      completion is providing a list of all possible matches.  Prompting the
4020      user to filter it down would be completely unexpected in this case.  */
4021   if (m == 0)
4022     return -1;
4023   else if (m > 1 && !parse_completion)
4024     {
4025       printf_filtered (_("Multiple matches for %s\n"), name);
4026       user_select_syms (syms, m, 1);
4027       return 0;
4028     }
4029   return 0;
4030 }
4031
4032 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4033    on the function identified by SYM and BLOCK, and taking NARGS
4034    arguments.  Update *EXPP as needed to hold more space.  */
4035
4036 static void
4037 replace_operator_with_call (expression_up *expp, int pc, int nargs,
4038                             int oplen, struct symbol *sym,
4039                             const struct block *block)
4040 {
4041   /* A new expression, with 6 more elements (3 for funcall, 4 for function
4042      symbol, -oplen for operator being replaced).  */
4043   struct expression *newexp = (struct expression *)
4044     xzalloc (sizeof (struct expression)
4045              + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
4046   struct expression *exp = expp->get ();
4047
4048   newexp->nelts = exp->nelts + 7 - oplen;
4049   newexp->language_defn = exp->language_defn;
4050   newexp->gdbarch = exp->gdbarch;
4051   memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
4052   memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4053           EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
4054
4055   newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4056   newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4057
4058   newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4059   newexp->elts[pc + 4].block = block;
4060   newexp->elts[pc + 5].symbol = sym;
4061
4062   expp->reset (newexp);
4063 }
4064
4065 /* Type-class predicates */
4066
4067 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4068    or FLOAT).  */
4069
4070 static int
4071 numeric_type_p (struct type *type)
4072 {
4073   if (type == NULL)
4074     return 0;
4075   else
4076     {
4077       switch (TYPE_CODE (type))
4078         {
4079         case TYPE_CODE_INT:
4080         case TYPE_CODE_FLT:
4081           return 1;
4082         case TYPE_CODE_RANGE:
4083           return (type == TYPE_TARGET_TYPE (type)
4084                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
4085         default:
4086           return 0;
4087         }
4088     }
4089 }
4090
4091 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
4092
4093 static int
4094 integer_type_p (struct type *type)
4095 {
4096   if (type == NULL)
4097     return 0;
4098   else
4099     {
4100       switch (TYPE_CODE (type))
4101         {
4102         case TYPE_CODE_INT:
4103           return 1;
4104         case TYPE_CODE_RANGE:
4105           return (type == TYPE_TARGET_TYPE (type)
4106                   || integer_type_p (TYPE_TARGET_TYPE (type)));
4107         default:
4108           return 0;
4109         }
4110     }
4111 }
4112
4113 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
4114
4115 static int
4116 scalar_type_p (struct type *type)
4117 {
4118   if (type == NULL)
4119     return 0;
4120   else
4121     {
4122       switch (TYPE_CODE (type))
4123         {
4124         case TYPE_CODE_INT:
4125         case TYPE_CODE_RANGE:
4126         case TYPE_CODE_ENUM:
4127         case TYPE_CODE_FLT:
4128           return 1;
4129         default:
4130           return 0;
4131         }
4132     }
4133 }
4134
4135 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
4136
4137 static int
4138 discrete_type_p (struct type *type)
4139 {
4140   if (type == NULL)
4141     return 0;
4142   else
4143     {
4144       switch (TYPE_CODE (type))
4145         {
4146         case TYPE_CODE_INT:
4147         case TYPE_CODE_RANGE:
4148         case TYPE_CODE_ENUM:
4149         case TYPE_CODE_BOOL:
4150           return 1;
4151         default:
4152           return 0;
4153         }
4154     }
4155 }
4156
4157 /* Returns non-zero if OP with operands in the vector ARGS could be
4158    a user-defined function.  Errs on the side of pre-defined operators
4159    (i.e., result 0).  */
4160
4161 static int
4162 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4163 {
4164   struct type *type0 =
4165     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4166   struct type *type1 =
4167     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4168
4169   if (type0 == NULL)
4170     return 0;
4171
4172   switch (op)
4173     {
4174     default:
4175       return 0;
4176
4177     case BINOP_ADD:
4178     case BINOP_SUB:
4179     case BINOP_MUL:
4180     case BINOP_DIV:
4181       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4182
4183     case BINOP_REM:
4184     case BINOP_MOD:
4185     case BINOP_BITWISE_AND:
4186     case BINOP_BITWISE_IOR:
4187     case BINOP_BITWISE_XOR:
4188       return (!(integer_type_p (type0) && integer_type_p (type1)));
4189
4190     case BINOP_EQUAL:
4191     case BINOP_NOTEQUAL:
4192     case BINOP_LESS:
4193     case BINOP_GTR:
4194     case BINOP_LEQ:
4195     case BINOP_GEQ:
4196       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4197
4198     case BINOP_CONCAT:
4199       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4200
4201     case BINOP_EXP:
4202       return (!(numeric_type_p (type0) && integer_type_p (type1)));
4203
4204     case UNOP_NEG:
4205     case UNOP_PLUS:
4206     case UNOP_LOGICAL_NOT:
4207     case UNOP_ABS:
4208       return (!numeric_type_p (type0));
4209
4210     }
4211 }
4212 \f
4213                                 /* Renaming */
4214
4215 /* NOTES: 
4216
4217    1. In the following, we assume that a renaming type's name may
4218       have an ___XD suffix.  It would be nice if this went away at some
4219       point.
4220    2. We handle both the (old) purely type-based representation of 
4221       renamings and the (new) variable-based encoding.  At some point,
4222       it is devoutly to be hoped that the former goes away 
4223       (FIXME: hilfinger-2007-07-09).
4224    3. Subprogram renamings are not implemented, although the XRS
4225       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
4226
4227 /* If SYM encodes a renaming, 
4228
4229        <renaming> renames <renamed entity>,
4230
4231    sets *LEN to the length of the renamed entity's name,
4232    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4233    the string describing the subcomponent selected from the renamed
4234    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4235    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4236    are undefined).  Otherwise, returns a value indicating the category
4237    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4238    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4239    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
4240    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4241    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4242    may be NULL, in which case they are not assigned.
4243
4244    [Currently, however, GCC does not generate subprogram renamings.]  */
4245
4246 enum ada_renaming_category
4247 ada_parse_renaming (struct symbol *sym,
4248                     const char **renamed_entity, int *len, 
4249                     const char **renaming_expr)
4250 {
4251   enum ada_renaming_category kind;
4252   const char *info;
4253   const char *suffix;
4254
4255   if (sym == NULL)
4256     return ADA_NOT_RENAMING;
4257   switch (SYMBOL_CLASS (sym)) 
4258     {
4259     default:
4260       return ADA_NOT_RENAMING;
4261     case LOC_LOCAL:
4262     case LOC_STATIC:
4263     case LOC_COMPUTED:
4264     case LOC_OPTIMIZED_OUT:
4265       info = strstr (sym->linkage_name (), "___XR");
4266       if (info == NULL)
4267         return ADA_NOT_RENAMING;
4268       switch (info[5])
4269         {
4270         case '_':
4271           kind = ADA_OBJECT_RENAMING;
4272           info += 6;
4273           break;
4274         case 'E':
4275           kind = ADA_EXCEPTION_RENAMING;
4276           info += 7;
4277           break;
4278         case 'P':
4279           kind = ADA_PACKAGE_RENAMING;
4280           info += 7;
4281           break;
4282         case 'S':
4283           kind = ADA_SUBPROGRAM_RENAMING;
4284           info += 7;
4285           break;
4286         default:
4287           return ADA_NOT_RENAMING;
4288         }
4289     }
4290
4291   if (renamed_entity != NULL)
4292     *renamed_entity = info;
4293   suffix = strstr (info, "___XE");
4294   if (suffix == NULL || suffix == info)
4295     return ADA_NOT_RENAMING;
4296   if (len != NULL)
4297     *len = strlen (info) - strlen (suffix);
4298   suffix += 5;
4299   if (renaming_expr != NULL)
4300     *renaming_expr = suffix;
4301   return kind;
4302 }
4303
4304 /* Compute the value of the given RENAMING_SYM, which is expected to
4305    be a symbol encoding a renaming expression.  BLOCK is the block
4306    used to evaluate the renaming.  */
4307
4308 static struct value *
4309 ada_read_renaming_var_value (struct symbol *renaming_sym,
4310                              const struct block *block)
4311 {
4312   const char *sym_name;
4313
4314   sym_name = renaming_sym->linkage_name ();
4315   expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4316   return evaluate_expression (expr.get ());
4317 }
4318 \f
4319
4320                                 /* Evaluation: Function Calls */
4321
4322 /* Return an lvalue containing the value VAL.  This is the identity on
4323    lvalues, and otherwise has the side-effect of allocating memory
4324    in the inferior where a copy of the value contents is copied.  */
4325
4326 static struct value *
4327 ensure_lval (struct value *val)
4328 {
4329   if (VALUE_LVAL (val) == not_lval
4330       || VALUE_LVAL (val) == lval_internalvar)
4331     {
4332       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4333       const CORE_ADDR addr =
4334         value_as_long (value_allocate_space_in_inferior (len));
4335
4336       VALUE_LVAL (val) = lval_memory;
4337       set_value_address (val, addr);
4338       write_memory (addr, value_contents (val), len);
4339     }
4340
4341   return val;
4342 }
4343
4344 /* Given ARG, a value of type (pointer or reference to a)*
4345    structure/union, extract the component named NAME from the ultimate
4346    target structure/union and return it as a value with its
4347    appropriate type.
4348
4349    The routine searches for NAME among all members of the structure itself
4350    and (recursively) among all members of any wrapper members
4351    (e.g., '_parent').
4352
4353    If NO_ERR, then simply return NULL in case of error, rather than
4354    calling error.  */
4355
4356 static struct value *
4357 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
4358 {
4359   struct type *t, *t1;
4360   struct value *v;
4361   int check_tag;
4362
4363   v = NULL;
4364   t1 = t = ada_check_typedef (value_type (arg));
4365   if (TYPE_CODE (t) == TYPE_CODE_REF)
4366     {
4367       t1 = TYPE_TARGET_TYPE (t);
4368       if (t1 == NULL)
4369         goto BadValue;
4370       t1 = ada_check_typedef (t1);
4371       if (TYPE_CODE (t1) == TYPE_CODE_PTR)
4372         {
4373           arg = coerce_ref (arg);
4374           t = t1;
4375         }
4376     }
4377
4378   while (TYPE_CODE (t) == TYPE_CODE_PTR)
4379     {
4380       t1 = TYPE_TARGET_TYPE (t);
4381       if (t1 == NULL)
4382         goto BadValue;
4383       t1 = ada_check_typedef (t1);
4384       if (TYPE_CODE (t1) == TYPE_CODE_PTR)
4385         {
4386           arg = value_ind (arg);
4387           t = t1;
4388         }
4389       else
4390         break;
4391     }
4392
4393   if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
4394     goto BadValue;
4395
4396   if (t1 == t)
4397     v = ada_search_struct_field (name, arg, 0, t);
4398   else
4399     {
4400       int bit_offset, bit_size, byte_offset;
4401       struct type *field_type;
4402       CORE_ADDR address;
4403
4404       if (TYPE_CODE (t) == TYPE_CODE_PTR)
4405         address = value_address (ada_value_ind (arg));
4406       else
4407         address = value_address (ada_coerce_ref (arg));
4408
4409       /* Check to see if this is a tagged type.  We also need to handle
4410          the case where the type is a reference to a tagged type, but
4411          we have to be careful to exclude pointers to tagged types.
4412          The latter should be shown as usual (as a pointer), whereas
4413          a reference should mostly be transparent to the user.  */
4414
4415       if (ada_is_tagged_type (t1, 0)
4416           || (TYPE_CODE (t1) == TYPE_CODE_REF
4417               && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
4418         {
4419           /* We first try to find the searched field in the current type.
4420              If not found then let's look in the fixed type.  */
4421
4422           if (!find_struct_field (name, t1, 0,
4423                                   &field_type, &byte_offset, &bit_offset,
4424                                   &bit_size, NULL))
4425             check_tag = 1;
4426           else
4427             check_tag = 0;
4428         }
4429       else
4430         check_tag = 0;
4431
4432       /* Convert to fixed type in all cases, so that we have proper
4433          offsets to each field in unconstrained record types.  */
4434       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
4435                               address, NULL, check_tag);
4436
4437       if (find_struct_field (name, t1, 0,
4438                              &field_type, &byte_offset, &bit_offset,
4439                              &bit_size, NULL))
4440         {
4441           if (bit_size != 0)
4442             {
4443               if (TYPE_CODE (t) == TYPE_CODE_REF)
4444                 arg = ada_coerce_ref (arg);
4445               else
4446                 arg = ada_value_ind (arg);
4447               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
4448                                                   bit_offset, bit_size,
4449                                                   field_type);
4450             }
4451           else
4452             v = value_at_lazy (field_type, address + byte_offset);
4453         }
4454     }
4455
4456   if (v != NULL || no_err)
4457     return v;
4458   else
4459     error (_("There is no member named %s."), name);
4460
4461  BadValue:
4462   if (no_err)
4463     return NULL;
4464   else
4465     error (_("Attempt to extract a component of "
4466              "a value that is not a record."));
4467 }
4468
4469 /* Return the value ACTUAL, converted to be an appropriate value for a
4470    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4471    allocating any necessary descriptors (fat pointers), or copies of
4472    values not residing in memory, updating it as needed.  */
4473
4474 struct value *
4475 ada_convert_actual (struct value *actual, struct type *formal_type0)
4476 {
4477   struct type *actual_type = ada_check_typedef (value_type (actual));
4478   struct type *formal_type = ada_check_typedef (formal_type0);
4479   struct type *formal_target =
4480     TYPE_CODE (formal_type) == TYPE_CODE_PTR
4481     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4482   struct type *actual_target =
4483     TYPE_CODE (actual_type) == TYPE_CODE_PTR
4484     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4485
4486   if (ada_is_array_descriptor_type (formal_target)
4487       && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
4488     return make_array_descriptor (formal_type, actual);
4489   else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4490            || TYPE_CODE (formal_type) == TYPE_CODE_REF)
4491     {
4492       struct value *result;
4493
4494       if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4495           && ada_is_array_descriptor_type (actual_target))
4496         result = desc_data (actual);
4497       else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4498         {
4499           if (VALUE_LVAL (actual) != lval_memory)
4500             {
4501               struct value *val;
4502
4503               actual_type = ada_check_typedef (value_type (actual));
4504               val = allocate_value (actual_type);
4505               memcpy ((char *) value_contents_raw (val),
4506                       (char *) value_contents (actual),
4507                       TYPE_LENGTH (actual_type));
4508               actual = ensure_lval (val);
4509             }
4510           result = value_addr (actual);
4511         }
4512       else
4513         return actual;
4514       return value_cast_pointers (formal_type, result, 0);
4515     }
4516   else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4517     return ada_value_ind (actual);
4518   else if (ada_is_aligner_type (formal_type))
4519     {
4520       /* We need to turn this parameter into an aligner type
4521          as well.  */
4522       struct value *aligner = allocate_value (formal_type);
4523       struct value *component = ada_value_struct_elt (aligner, "F", 0);
4524
4525       value_assign_to_component (aligner, component, actual);
4526       return aligner;
4527     }
4528
4529   return actual;
4530 }
4531
4532 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4533    type TYPE.  This is usually an inefficient no-op except on some targets
4534    (such as AVR) where the representation of a pointer and an address
4535    differs.  */
4536
4537 static CORE_ADDR
4538 value_pointer (struct value *value, struct type *type)
4539 {
4540   struct gdbarch *gdbarch = get_type_arch (type);
4541   unsigned len = TYPE_LENGTH (type);
4542   gdb_byte *buf = (gdb_byte *) alloca (len);
4543   CORE_ADDR addr;
4544
4545   addr = value_address (value);
4546   gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4547   addr = extract_unsigned_integer (buf, len, type_byte_order (type));
4548   return addr;
4549 }
4550
4551
4552 /* Push a descriptor of type TYPE for array value ARR on the stack at
4553    *SP, updating *SP to reflect the new descriptor.  Return either
4554    an lvalue representing the new descriptor, or (if TYPE is a pointer-
4555    to-descriptor type rather than a descriptor type), a struct value *
4556    representing a pointer to this descriptor.  */
4557
4558 static struct value *
4559 make_array_descriptor (struct type *type, struct value *arr)
4560 {
4561   struct type *bounds_type = desc_bounds_type (type);
4562   struct type *desc_type = desc_base_type (type);
4563   struct value *descriptor = allocate_value (desc_type);
4564   struct value *bounds = allocate_value (bounds_type);
4565   int i;
4566
4567   for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4568        i > 0; i -= 1)
4569     {
4570       modify_field (value_type (bounds), value_contents_writeable (bounds),
4571                     ada_array_bound (arr, i, 0),
4572                     desc_bound_bitpos (bounds_type, i, 0),
4573                     desc_bound_bitsize (bounds_type, i, 0));
4574       modify_field (value_type (bounds), value_contents_writeable (bounds),
4575                     ada_array_bound (arr, i, 1),
4576                     desc_bound_bitpos (bounds_type, i, 1),
4577                     desc_bound_bitsize (bounds_type, i, 1));
4578     }
4579
4580   bounds = ensure_lval (bounds);
4581
4582   modify_field (value_type (descriptor),
4583                 value_contents_writeable (descriptor),
4584                 value_pointer (ensure_lval (arr),
4585                                TYPE_FIELD_TYPE (desc_type, 0)),
4586                 fat_pntr_data_bitpos (desc_type),
4587                 fat_pntr_data_bitsize (desc_type));
4588
4589   modify_field (value_type (descriptor),
4590                 value_contents_writeable (descriptor),
4591                 value_pointer (bounds,
4592                                TYPE_FIELD_TYPE (desc_type, 1)),
4593                 fat_pntr_bounds_bitpos (desc_type),
4594                 fat_pntr_bounds_bitsize (desc_type));
4595
4596   descriptor = ensure_lval (descriptor);
4597
4598   if (TYPE_CODE (type) == TYPE_CODE_PTR)
4599     return value_addr (descriptor);
4600   else
4601     return descriptor;
4602 }
4603 \f
4604                                 /* Symbol Cache Module */
4605
4606 /* Performance measurements made as of 2010-01-15 indicate that
4607    this cache does bring some noticeable improvements.  Depending
4608    on the type of entity being printed, the cache can make it as much
4609    as an order of magnitude faster than without it.
4610
4611    The descriptive type DWARF extension has significantly reduced
4612    the need for this cache, at least when DWARF is being used.  However,
4613    even in this case, some expensive name-based symbol searches are still
4614    sometimes necessary - to find an XVZ variable, mostly.  */
4615
4616 /* Initialize the contents of SYM_CACHE.  */
4617
4618 static void
4619 ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4620 {
4621   obstack_init (&sym_cache->cache_space);
4622   memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4623 }
4624
4625 /* Free the memory used by SYM_CACHE.  */
4626
4627 static void
4628 ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
4629 {
4630   obstack_free (&sym_cache->cache_space, NULL);
4631   xfree (sym_cache);
4632 }
4633
4634 /* Return the symbol cache associated to the given program space PSPACE.
4635    If not allocated for this PSPACE yet, allocate and initialize one.  */
4636
4637 static struct ada_symbol_cache *
4638 ada_get_symbol_cache (struct program_space *pspace)
4639 {
4640   struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4641
4642   if (pspace_data->sym_cache == NULL)
4643     {
4644       pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4645       ada_init_symbol_cache (pspace_data->sym_cache);
4646     }
4647
4648   return pspace_data->sym_cache;
4649 }
4650
4651 /* Clear all entries from the symbol cache.  */
4652
4653 static void
4654 ada_clear_symbol_cache (void)
4655 {
4656   struct ada_symbol_cache *sym_cache
4657     = ada_get_symbol_cache (current_program_space);
4658
4659   obstack_free (&sym_cache->cache_space, NULL);
4660   ada_init_symbol_cache (sym_cache);
4661 }
4662
4663 /* Search our cache for an entry matching NAME and DOMAIN.
4664    Return it if found, or NULL otherwise.  */
4665
4666 static struct cache_entry **
4667 find_entry (const char *name, domain_enum domain)
4668 {
4669   struct ada_symbol_cache *sym_cache
4670     = ada_get_symbol_cache (current_program_space);
4671   int h = msymbol_hash (name) % HASH_SIZE;
4672   struct cache_entry **e;
4673
4674   for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4675     {
4676       if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4677         return e;
4678     }
4679   return NULL;
4680 }
4681
4682 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4683    Return 1 if found, 0 otherwise.
4684
4685    If an entry was found and SYM is not NULL, set *SYM to the entry's
4686    SYM.  Same principle for BLOCK if not NULL.  */
4687
4688 static int
4689 lookup_cached_symbol (const char *name, domain_enum domain,
4690                       struct symbol **sym, const struct block **block)
4691 {
4692   struct cache_entry **e = find_entry (name, domain);
4693
4694   if (e == NULL)
4695     return 0;
4696   if (sym != NULL)
4697     *sym = (*e)->sym;
4698   if (block != NULL)
4699     *block = (*e)->block;
4700   return 1;
4701 }
4702
4703 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4704    in domain DOMAIN, save this result in our symbol cache.  */
4705
4706 static void
4707 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4708               const struct block *block)
4709 {
4710   struct ada_symbol_cache *sym_cache
4711     = ada_get_symbol_cache (current_program_space);
4712   int h;
4713   char *copy;
4714   struct cache_entry *e;
4715
4716   /* Symbols for builtin types don't have a block.
4717      For now don't cache such symbols.  */
4718   if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4719     return;
4720
4721   /* If the symbol is a local symbol, then do not cache it, as a search
4722      for that symbol depends on the context.  To determine whether
4723      the symbol is local or not, we check the block where we found it
4724      against the global and static blocks of its associated symtab.  */
4725   if (sym
4726       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4727                             GLOBAL_BLOCK) != block
4728       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4729                             STATIC_BLOCK) != block)
4730     return;
4731
4732   h = msymbol_hash (name) % HASH_SIZE;
4733   e = XOBNEW (&sym_cache->cache_space, cache_entry);
4734   e->next = sym_cache->root[h];
4735   sym_cache->root[h] = e;
4736   e->name = copy
4737     = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
4738   strcpy (copy, name);
4739   e->sym = sym;
4740   e->domain = domain;
4741   e->block = block;
4742 }
4743 \f
4744                                 /* Symbol Lookup */
4745
4746 /* Return the symbol name match type that should be used used when
4747    searching for all symbols matching LOOKUP_NAME.
4748
4749    LOOKUP_NAME is expected to be a symbol name after transformation
4750    for Ada lookups.  */
4751
4752 static symbol_name_match_type
4753 name_match_type_from_name (const char *lookup_name)
4754 {
4755   return (strstr (lookup_name, "__") == NULL
4756           ? symbol_name_match_type::WILD
4757           : symbol_name_match_type::FULL);
4758 }
4759
4760 /* Return the result of a standard (literal, C-like) lookup of NAME in
4761    given DOMAIN, visible from lexical block BLOCK.  */
4762
4763 static struct symbol *
4764 standard_lookup (const char *name, const struct block *block,
4765                  domain_enum domain)
4766 {
4767   /* Initialize it just to avoid a GCC false warning.  */
4768   struct block_symbol sym = {};
4769
4770   if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4771     return sym.symbol;
4772   ada_lookup_encoded_symbol (name, block, domain, &sym);
4773   cache_symbol (name, domain, sym.symbol, sym.block);
4774   return sym.symbol;
4775 }
4776
4777
4778 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4779    in the symbol fields of SYMS[0..N-1].  We treat enumerals as functions, 
4780    since they contend in overloading in the same way.  */
4781 static int
4782 is_nonfunction (struct block_symbol syms[], int n)
4783 {
4784   int i;
4785
4786   for (i = 0; i < n; i += 1)
4787     if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4788         && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4789             || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
4790       return 1;
4791
4792   return 0;
4793 }
4794
4795 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4796    struct types.  Otherwise, they may not.  */
4797
4798 static int
4799 equiv_types (struct type *type0, struct type *type1)
4800 {
4801   if (type0 == type1)
4802     return 1;
4803   if (type0 == NULL || type1 == NULL
4804       || TYPE_CODE (type0) != TYPE_CODE (type1))
4805     return 0;
4806   if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
4807        || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4808       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4809       && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4810     return 1;
4811
4812   return 0;
4813 }
4814
4815 /* True iff SYM0 represents the same entity as SYM1, or one that is
4816    no more defined than that of SYM1.  */
4817
4818 static int
4819 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4820 {
4821   if (sym0 == sym1)
4822     return 1;
4823   if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4824       || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4825     return 0;
4826
4827   switch (SYMBOL_CLASS (sym0))
4828     {
4829     case LOC_UNDEF:
4830       return 1;
4831     case LOC_TYPEDEF:
4832       {
4833         struct type *type0 = SYMBOL_TYPE (sym0);
4834         struct type *type1 = SYMBOL_TYPE (sym1);
4835         const char *name0 = sym0->linkage_name ();
4836         const char *name1 = sym1->linkage_name ();
4837         int len0 = strlen (name0);
4838
4839         return
4840           TYPE_CODE (type0) == TYPE_CODE (type1)
4841           && (equiv_types (type0, type1)
4842               || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4843                   && startswith (name1 + len0, "___XV")));
4844       }
4845     case LOC_CONST:
4846       return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4847         && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4848
4849     case LOC_STATIC:
4850       {
4851         const char *name0 = sym0->linkage_name ();
4852         const char *name1 = sym1->linkage_name ();
4853         return (strcmp (name0, name1) == 0
4854                 && SYMBOL_VALUE_ADDRESS (sym0) == SYMBOL_VALUE_ADDRESS (sym1));
4855       }
4856
4857     default:
4858       return 0;
4859     }
4860 }
4861
4862 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4863    records in OBSTACKP.  Do nothing if SYM is a duplicate.  */
4864
4865 static void
4866 add_defn_to_vec (struct obstack *obstackp,
4867                  struct symbol *sym,
4868                  const struct block *block)
4869 {
4870   int i;
4871   struct block_symbol *prevDefns = defns_collected (obstackp, 0);
4872
4873   /* Do not try to complete stub types, as the debugger is probably
4874      already scanning all symbols matching a certain name at the
4875      time when this function is called.  Trying to replace the stub
4876      type by its associated full type will cause us to restart a scan
4877      which may lead to an infinite recursion.  Instead, the client
4878      collecting the matching symbols will end up collecting several
4879      matches, with at least one of them complete.  It can then filter
4880      out the stub ones if needed.  */
4881
4882   for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4883     {
4884       if (lesseq_defined_than (sym, prevDefns[i].symbol))
4885         return;
4886       else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4887         {
4888           prevDefns[i].symbol = sym;
4889           prevDefns[i].block = block;
4890           return;
4891         }
4892     }
4893
4894   {
4895     struct block_symbol info;
4896
4897     info.symbol = sym;
4898     info.block = block;
4899     obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4900   }
4901 }
4902
4903 /* Number of block_symbol structures currently collected in current vector in
4904    OBSTACKP.  */
4905
4906 static int
4907 num_defns_collected (struct obstack *obstackp)
4908 {
4909   return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4910 }
4911
4912 /* Vector of block_symbol structures currently collected in current vector in
4913    OBSTACKP.  If FINISH, close off the vector and return its final address.  */
4914
4915 static struct block_symbol *
4916 defns_collected (struct obstack *obstackp, int finish)
4917 {
4918   if (finish)
4919     return (struct block_symbol *) obstack_finish (obstackp);
4920   else
4921     return (struct block_symbol *) obstack_base (obstackp);
4922 }
4923
4924 /* Return a bound minimal symbol matching NAME according to Ada
4925    decoding rules.  Returns an invalid symbol if there is no such
4926    minimal symbol.  Names prefixed with "standard__" are handled
4927    specially: "standard__" is first stripped off, and only static and
4928    global symbols are searched.  */
4929
4930 struct bound_minimal_symbol
4931 ada_lookup_simple_minsym (const char *name)
4932 {
4933   struct bound_minimal_symbol result;
4934
4935   memset (&result, 0, sizeof (result));
4936
4937   symbol_name_match_type match_type = name_match_type_from_name (name);
4938   lookup_name_info lookup_name (name, match_type);
4939
4940   symbol_name_matcher_ftype *match_name
4941     = ada_get_symbol_name_matcher (lookup_name);
4942
4943   for (objfile *objfile : current_program_space->objfiles ())
4944     {
4945       for (minimal_symbol *msymbol : objfile->msymbols ())
4946         {
4947           if (match_name (msymbol->linkage_name (), lookup_name, NULL)
4948               && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4949             {
4950               result.minsym = msymbol;
4951               result.objfile = objfile;
4952               break;
4953             }
4954         }
4955     }
4956
4957   return result;
4958 }
4959
4960 /* For all subprograms that statically enclose the subprogram of the
4961    selected frame, add symbols matching identifier NAME in DOMAIN
4962    and their blocks to the list of data in OBSTACKP, as for
4963    ada_add_block_symbols (q.v.).   If WILD_MATCH_P, treat as NAME
4964    with a wildcard prefix.  */
4965
4966 static void
4967 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4968                                   const lookup_name_info &lookup_name,
4969                                   domain_enum domain)
4970 {
4971 }
4972
4973 /* True if TYPE is definitely an artificial type supplied to a symbol
4974    for which no debugging information was given in the symbol file.  */
4975
4976 static int
4977 is_nondebugging_type (struct type *type)
4978 {
4979   const char *name = ada_type_name (type);
4980
4981   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4982 }
4983
4984 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4985    that are deemed "identical" for practical purposes.
4986
4987    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4988    types and that their number of enumerals is identical (in other
4989    words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)).  */
4990
4991 static int
4992 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4993 {
4994   int i;
4995
4996   /* The heuristic we use here is fairly conservative.  We consider
4997      that 2 enumerate types are identical if they have the same
4998      number of enumerals and that all enumerals have the same
4999      underlying value and name.  */
5000
5001   /* All enums in the type should have an identical underlying value.  */
5002   for (i = 0; i < TYPE_NFIELDS (type1); i++)
5003     if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
5004       return 0;
5005
5006   /* All enumerals should also have the same name (modulo any numerical
5007      suffix).  */
5008   for (i = 0; i < TYPE_NFIELDS (type1); i++)
5009     {
5010       const char *name_1 = TYPE_FIELD_NAME (type1, i);
5011       const char *name_2 = TYPE_FIELD_NAME (type2, i);
5012       int len_1 = strlen (name_1);
5013       int len_2 = strlen (name_2);
5014
5015       ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
5016       ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
5017       if (len_1 != len_2
5018           || strncmp (TYPE_FIELD_NAME (type1, i),
5019                       TYPE_FIELD_NAME (type2, i),
5020                       len_1) != 0)
5021         return 0;
5022     }
5023
5024   return 1;
5025 }
5026
5027 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
5028    that are deemed "identical" for practical purposes.  Sometimes,
5029    enumerals are not strictly identical, but their types are so similar
5030    that they can be considered identical.
5031
5032    For instance, consider the following code:
5033
5034       type Color is (Black, Red, Green, Blue, White);
5035       type RGB_Color is new Color range Red .. Blue;
5036
5037    Type RGB_Color is a subrange of an implicit type which is a copy
5038    of type Color. If we call that implicit type RGB_ColorB ("B" is
5039    for "Base Type"), then type RGB_ColorB is a copy of type Color.
5040    As a result, when an expression references any of the enumeral
5041    by name (Eg. "print green"), the expression is technically
5042    ambiguous and the user should be asked to disambiguate. But
5043    doing so would only hinder the user, since it wouldn't matter
5044    what choice he makes, the outcome would always be the same.
5045    So, for practical purposes, we consider them as the same.  */
5046
5047 static int
5048 symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
5049 {
5050   int i;
5051
5052   /* Before performing a thorough comparison check of each type,
5053      we perform a series of inexpensive checks.  We expect that these
5054      checks will quickly fail in the vast majority of cases, and thus
5055      help prevent the unnecessary use of a more expensive comparison.
5056      Said comparison also expects us to make some of these checks
5057      (see ada_identical_enum_types_p).  */
5058
5059   /* Quick check: All symbols should have an enum type.  */
5060   for (i = 0; i < syms.size (); i++)
5061     if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
5062       return 0;
5063
5064   /* Quick check: They should all have the same value.  */
5065   for (i = 1; i < syms.size (); i++)
5066     if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
5067       return 0;
5068
5069   /* Quick check: They should all have the same number of enumerals.  */
5070   for (i = 1; i < syms.size (); i++)
5071     if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5072         != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
5073       return 0;
5074
5075   /* All the sanity checks passed, so we might have a set of
5076      identical enumeration types.  Perform a more complete
5077      comparison of the type of each symbol.  */
5078   for (i = 1; i < syms.size (); i++)
5079     if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5080                                      SYMBOL_TYPE (syms[0].symbol)))
5081       return 0;
5082
5083   return 1;
5084 }
5085
5086 /* Remove any non-debugging symbols in SYMS that definitely
5087    duplicate other symbols in the list (The only case I know of where
5088    this happens is when object files containing stabs-in-ecoff are
5089    linked with files containing ordinary ecoff debugging symbols (or no
5090    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.
5091    Returns the number of items in the modified list.  */
5092
5093 static int
5094 remove_extra_symbols (std::vector<struct block_symbol> *syms)
5095 {
5096   int i, j;
5097
5098   /* We should never be called with less than 2 symbols, as there
5099      cannot be any extra symbol in that case.  But it's easy to
5100      handle, since we have nothing to do in that case.  */
5101   if (syms->size () < 2)
5102     return syms->size ();
5103
5104   i = 0;
5105   while (i < syms->size ())
5106     {
5107       int remove_p = 0;
5108
5109       /* If two symbols have the same name and one of them is a stub type,
5110          the get rid of the stub.  */
5111
5112       if (TYPE_STUB (SYMBOL_TYPE ((*syms)[i].symbol))
5113           && (*syms)[i].symbol->linkage_name () != NULL)
5114         {
5115           for (j = 0; j < syms->size (); j++)
5116             {
5117               if (j != i
5118                   && !TYPE_STUB (SYMBOL_TYPE ((*syms)[j].symbol))
5119                   && (*syms)[j].symbol->linkage_name () != NULL
5120                   && strcmp ((*syms)[i].symbol->linkage_name (),
5121                              (*syms)[j].symbol->linkage_name ()) == 0)
5122                 remove_p = 1;
5123             }
5124         }
5125
5126       /* Two symbols with the same name, same class and same address
5127          should be identical.  */
5128
5129       else if ((*syms)[i].symbol->linkage_name () != NULL
5130           && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
5131           && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
5132         {
5133           for (j = 0; j < syms->size (); j += 1)
5134             {
5135               if (i != j
5136                   && (*syms)[j].symbol->linkage_name () != NULL
5137                   && strcmp ((*syms)[i].symbol->linkage_name (),
5138                              (*syms)[j].symbol->linkage_name ()) == 0
5139                   && SYMBOL_CLASS ((*syms)[i].symbol)
5140                        == SYMBOL_CLASS ((*syms)[j].symbol)
5141                   && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
5142                   == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
5143                 remove_p = 1;
5144             }
5145         }
5146       
5147       if (remove_p)
5148         syms->erase (syms->begin () + i);
5149
5150       i += 1;
5151     }
5152
5153   /* If all the remaining symbols are identical enumerals, then
5154      just keep the first one and discard the rest.
5155
5156      Unlike what we did previously, we do not discard any entry
5157      unless they are ALL identical.  This is because the symbol
5158      comparison is not a strict comparison, but rather a practical
5159      comparison.  If all symbols are considered identical, then
5160      we can just go ahead and use the first one and discard the rest.
5161      But if we cannot reduce the list to a single element, we have
5162      to ask the user to disambiguate anyways.  And if we have to
5163      present a multiple-choice menu, it's less confusing if the list
5164      isn't missing some choices that were identical and yet distinct.  */
5165   if (symbols_are_identical_enums (*syms))
5166     syms->resize (1);
5167
5168   return syms->size ();
5169 }
5170
5171 /* Given a type that corresponds to a renaming entity, use the type name
5172    to extract the scope (package name or function name, fully qualified,
5173    and following the GNAT encoding convention) where this renaming has been
5174    defined.  */
5175
5176 static std::string
5177 xget_renaming_scope (struct type *renaming_type)
5178 {
5179   /* The renaming types adhere to the following convention:
5180      <scope>__<rename>___<XR extension>.
5181      So, to extract the scope, we search for the "___XR" extension,
5182      and then backtrack until we find the first "__".  */
5183
5184   const char *name = TYPE_NAME (renaming_type);
5185   const char *suffix = strstr (name, "___XR");
5186   const char *last;
5187
5188   /* Now, backtrack a bit until we find the first "__".  Start looking
5189      at suffix - 3, as the <rename> part is at least one character long.  */
5190
5191   for (last = suffix - 3; last > name; last--)
5192     if (last[0] == '_' && last[1] == '_')
5193       break;
5194
5195   /* Make a copy of scope and return it.  */
5196   return std::string (name, last);
5197 }
5198
5199 /* Return nonzero if NAME corresponds to a package name.  */
5200
5201 static int
5202 is_package_name (const char *name)
5203 {
5204   /* Here, We take advantage of the fact that no symbols are generated
5205      for packages, while symbols are generated for each function.
5206      So the condition for NAME represent a package becomes equivalent
5207      to NAME not existing in our list of symbols.  There is only one
5208      small complication with library-level functions (see below).  */
5209
5210   /* If it is a function that has not been defined at library level,
5211      then we should be able to look it up in the symbols.  */
5212   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5213     return 0;
5214
5215   /* Library-level function names start with "_ada_".  See if function
5216      "_ada_" followed by NAME can be found.  */
5217
5218   /* Do a quick check that NAME does not contain "__", since library-level
5219      functions names cannot contain "__" in them.  */
5220   if (strstr (name, "__") != NULL)
5221     return 0;
5222
5223   std::string fun_name = string_printf ("_ada_%s", name);
5224
5225   return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
5226 }
5227
5228 /* Return nonzero if SYM corresponds to a renaming entity that is
5229    not visible from FUNCTION_NAME.  */
5230
5231 static int
5232 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5233 {
5234   if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5235     return 0;
5236
5237   std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
5238
5239   /* If the rename has been defined in a package, then it is visible.  */
5240   if (is_package_name (scope.c_str ()))
5241     return 0;
5242
5243   /* Check that the rename is in the current function scope by checking
5244      that its name starts with SCOPE.  */
5245
5246   /* If the function name starts with "_ada_", it means that it is
5247      a library-level function.  Strip this prefix before doing the
5248      comparison, as the encoding for the renaming does not contain
5249      this prefix.  */
5250   if (startswith (function_name, "_ada_"))
5251     function_name += 5;
5252
5253   return !startswith (function_name, scope.c_str ());
5254 }
5255
5256 /* Remove entries from SYMS that corresponds to a renaming entity that
5257    is not visible from the function associated with CURRENT_BLOCK or
5258    that is superfluous due to the presence of more specific renaming
5259    information.  Places surviving symbols in the initial entries of
5260    SYMS and returns the number of surviving symbols.
5261    
5262    Rationale:
5263    First, in cases where an object renaming is implemented as a
5264    reference variable, GNAT may produce both the actual reference
5265    variable and the renaming encoding.  In this case, we discard the
5266    latter.
5267
5268    Second, GNAT emits a type following a specified encoding for each renaming
5269    entity.  Unfortunately, STABS currently does not support the definition
5270    of types that are local to a given lexical block, so all renamings types
5271    are emitted at library level.  As a consequence, if an application
5272    contains two renaming entities using the same name, and a user tries to
5273    print the value of one of these entities, the result of the ada symbol
5274    lookup will also contain the wrong renaming type.
5275
5276    This function partially covers for this limitation by attempting to
5277    remove from the SYMS list renaming symbols that should be visible
5278    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
5279    method with the current information available.  The implementation
5280    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
5281    
5282       - When the user tries to print a rename in a function while there
5283         is another rename entity defined in a package:  Normally, the
5284         rename in the function has precedence over the rename in the
5285         package, so the latter should be removed from the list.  This is
5286         currently not the case.
5287         
5288       - This function will incorrectly remove valid renames if
5289         the CURRENT_BLOCK corresponds to a function which symbol name
5290         has been changed by an "Export" pragma.  As a consequence,
5291         the user will be unable to print such rename entities.  */
5292
5293 static int
5294 remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5295                              const struct block *current_block)
5296 {
5297   struct symbol *current_function;
5298   const char *current_function_name;
5299   int i;
5300   int is_new_style_renaming;
5301
5302   /* If there is both a renaming foo___XR... encoded as a variable and
5303      a simple variable foo in the same block, discard the latter.
5304      First, zero out such symbols, then compress.  */
5305   is_new_style_renaming = 0;
5306   for (i = 0; i < syms->size (); i += 1)
5307     {
5308       struct symbol *sym = (*syms)[i].symbol;
5309       const struct block *block = (*syms)[i].block;
5310       const char *name;
5311       const char *suffix;
5312
5313       if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5314         continue;
5315       name = sym->linkage_name ();
5316       suffix = strstr (name, "___XR");
5317
5318       if (suffix != NULL)
5319         {
5320           int name_len = suffix - name;
5321           int j;
5322
5323           is_new_style_renaming = 1;
5324           for (j = 0; j < syms->size (); j += 1)
5325             if (i != j && (*syms)[j].symbol != NULL
5326                 && strncmp (name, (*syms)[j].symbol->linkage_name (),
5327                             name_len) == 0
5328                 && block == (*syms)[j].block)
5329               (*syms)[j].symbol = NULL;
5330         }
5331     }
5332   if (is_new_style_renaming)
5333     {
5334       int j, k;
5335
5336       for (j = k = 0; j < syms->size (); j += 1)
5337         if ((*syms)[j].symbol != NULL)
5338             {
5339               (*syms)[k] = (*syms)[j];
5340               k += 1;
5341             }
5342       return k;
5343     }
5344
5345   /* Extract the function name associated to CURRENT_BLOCK.
5346      Abort if unable to do so.  */
5347
5348   if (current_block == NULL)
5349     return syms->size ();
5350
5351   current_function = block_linkage_function (current_block);
5352   if (current_function == NULL)
5353     return syms->size ();
5354
5355   current_function_name = current_function->linkage_name ();
5356   if (current_function_name == NULL)
5357     return syms->size ();
5358
5359   /* Check each of the symbols, and remove it from the list if it is
5360      a type corresponding to a renaming that is out of the scope of
5361      the current block.  */
5362
5363   i = 0;
5364   while (i < syms->size ())
5365     {
5366       if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
5367           == ADA_OBJECT_RENAMING
5368           && old_renaming_is_invisible ((*syms)[i].symbol,
5369                                         current_function_name))
5370         syms->erase (syms->begin () + i);
5371       else
5372         i += 1;
5373     }
5374
5375   return syms->size ();
5376 }
5377
5378 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5379    whose name and domain match NAME and DOMAIN respectively.
5380    If no match was found, then extend the search to "enclosing"
5381    routines (in other words, if we're inside a nested function,
5382    search the symbols defined inside the enclosing functions).
5383    If WILD_MATCH_P is nonzero, perform the naming matching in
5384    "wild" mode (see function "wild_match" for more info).
5385
5386    Note: This function assumes that OBSTACKP has 0 (zero) element in it.  */
5387
5388 static void
5389 ada_add_local_symbols (struct obstack *obstackp,
5390                        const lookup_name_info &lookup_name,
5391                        const struct block *block, domain_enum domain)
5392 {
5393   int block_depth = 0;
5394
5395   while (block != NULL)
5396     {
5397       block_depth += 1;
5398       ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5399
5400       /* If we found a non-function match, assume that's the one.  */
5401       if (is_nonfunction (defns_collected (obstackp, 0),
5402                           num_defns_collected (obstackp)))
5403         return;
5404
5405       block = BLOCK_SUPERBLOCK (block);
5406     }
5407
5408   /* If no luck so far, try to find NAME as a local symbol in some lexically
5409      enclosing subprogram.  */
5410   if (num_defns_collected (obstackp) == 0 && block_depth > 2)
5411     add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
5412 }
5413
5414 /* An object of this type is used as the user_data argument when
5415    calling the map_matching_symbols method.  */
5416
5417 struct match_data
5418 {
5419   struct objfile *objfile;
5420   struct obstack *obstackp;
5421   struct symbol *arg_sym;
5422   int found_sym;
5423 };
5424
5425 /* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
5426    to a list of symbols.  DATA is a pointer to a struct match_data *
5427    containing the obstack that collects the symbol list, the file that SYM
5428    must come from, a flag indicating whether a non-argument symbol has
5429    been found in the current block, and the last argument symbol
5430    passed in SYM within the current block (if any).  When SYM is null,
5431    marking the end of a block, the argument symbol is added if no
5432    other has been found.  */
5433
5434 static bool
5435 aux_add_nonlocal_symbols (struct block_symbol *bsym,
5436                           struct match_data *data)
5437 {
5438   const struct block *block = bsym->block;
5439   struct symbol *sym = bsym->symbol;
5440
5441   if (sym == NULL)
5442     {
5443       if (!data->found_sym && data->arg_sym != NULL) 
5444         add_defn_to_vec (data->obstackp,
5445                          fixup_symbol_section (data->arg_sym, data->objfile),
5446                          block);
5447       data->found_sym = 0;
5448       data->arg_sym = NULL;
5449     }
5450   else 
5451     {
5452       if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5453         return true;
5454       else if (SYMBOL_IS_ARGUMENT (sym))
5455         data->arg_sym = sym;
5456       else
5457         {
5458           data->found_sym = 1;
5459           add_defn_to_vec (data->obstackp,
5460                            fixup_symbol_section (sym, data->objfile),
5461                            block);
5462         }
5463     }
5464   return true;
5465 }
5466
5467 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5468    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5469    symbols to OBSTACKP.  Return whether we found such symbols.  */
5470
5471 static int
5472 ada_add_block_renamings (struct obstack *obstackp,
5473                          const struct block *block,
5474                          const lookup_name_info &lookup_name,
5475                          domain_enum domain)
5476 {
5477   struct using_direct *renaming;
5478   int defns_mark = num_defns_collected (obstackp);
5479
5480   symbol_name_matcher_ftype *name_match
5481     = ada_get_symbol_name_matcher (lookup_name);
5482
5483   for (renaming = block_using (block);
5484        renaming != NULL;
5485        renaming = renaming->next)
5486     {
5487       const char *r_name;
5488
5489       /* Avoid infinite recursions: skip this renaming if we are actually
5490          already traversing it.
5491
5492          Currently, symbol lookup in Ada don't use the namespace machinery from
5493          C++/Fortran support: skip namespace imports that use them.  */
5494       if (renaming->searched
5495           || (renaming->import_src != NULL
5496               && renaming->import_src[0] != '\0')
5497           || (renaming->import_dest != NULL
5498               && renaming->import_dest[0] != '\0'))
5499         continue;
5500       renaming->searched = 1;
5501
5502       /* TODO: here, we perform another name-based symbol lookup, which can
5503          pull its own multiple overloads.  In theory, we should be able to do
5504          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5505          not a simple name.  But in order to do this, we would need to enhance
5506          the DWARF reader to associate a symbol to this renaming, instead of a
5507          name.  So, for now, we do something simpler: re-use the C++/Fortran
5508          namespace machinery.  */
5509       r_name = (renaming->alias != NULL
5510                 ? renaming->alias
5511                 : renaming->declaration);
5512       if (name_match (r_name, lookup_name, NULL))
5513         {
5514           lookup_name_info decl_lookup_name (renaming->declaration,
5515                                              lookup_name.match_type ());
5516           ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5517                                1, NULL);
5518         }
5519       renaming->searched = 0;
5520     }
5521   return num_defns_collected (obstackp) != defns_mark;
5522 }
5523
5524 /* Implements compare_names, but only applying the comparision using
5525    the given CASING.  */
5526
5527 static int
5528 compare_names_with_case (const char *string1, const char *string2,
5529                          enum case_sensitivity casing)
5530 {
5531   while (*string1 != '\0' && *string2 != '\0')
5532     {
5533       char c1, c2;
5534
5535       if (isspace (*string1) || isspace (*string2))
5536         return strcmp_iw_ordered (string1, string2);
5537
5538       if (casing == case_sensitive_off)
5539         {
5540           c1 = tolower (*string1);
5541           c2 = tolower (*string2);
5542         }
5543       else
5544         {
5545           c1 = *string1;
5546           c2 = *string2;
5547         }
5548       if (c1 != c2)
5549         break;
5550
5551       string1 += 1;
5552       string2 += 1;
5553     }
5554
5555   switch (*string1)
5556     {
5557     case '(':
5558       return strcmp_iw_ordered (string1, string2);
5559     case '_':
5560       if (*string2 == '\0')
5561         {
5562           if (is_name_suffix (string1))
5563             return 0;
5564           else
5565             return 1;
5566         }
5567       /* FALLTHROUGH */
5568     default:
5569       if (*string2 == '(')
5570         return strcmp_iw_ordered (string1, string2);
5571       else
5572         {
5573           if (casing == case_sensitive_off)
5574             return tolower (*string1) - tolower (*string2);
5575           else
5576             return *string1 - *string2;
5577         }
5578     }
5579 }
5580
5581 /* Compare STRING1 to STRING2, with results as for strcmp.
5582    Compatible with strcmp_iw_ordered in that...
5583
5584        strcmp_iw_ordered (STRING1, STRING2) <= 0
5585
5586    ... implies...
5587
5588        compare_names (STRING1, STRING2) <= 0
5589
5590    (they may differ as to what symbols compare equal).  */
5591
5592 static int
5593 compare_names (const char *string1, const char *string2)
5594 {
5595   int result;
5596
5597   /* Similar to what strcmp_iw_ordered does, we need to perform
5598      a case-insensitive comparison first, and only resort to
5599      a second, case-sensitive, comparison if the first one was
5600      not sufficient to differentiate the two strings.  */
5601
5602   result = compare_names_with_case (string1, string2, case_sensitive_off);
5603   if (result == 0)
5604     result = compare_names_with_case (string1, string2, case_sensitive_on);
5605
5606   return result;
5607 }
5608
5609 /* Convenience function to get at the Ada encoded lookup name for
5610    LOOKUP_NAME, as a C string.  */
5611
5612 static const char *
5613 ada_lookup_name (const lookup_name_info &lookup_name)
5614 {
5615   return lookup_name.ada ().lookup_name ().c_str ();
5616 }
5617
5618 /* Add to OBSTACKP all non-local symbols whose name and domain match
5619    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5620    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5621    symbols otherwise.  */
5622
5623 static void
5624 add_nonlocal_symbols (struct obstack *obstackp,
5625                       const lookup_name_info &lookup_name,
5626                       domain_enum domain, int global)
5627 {
5628   struct match_data data;
5629
5630   memset (&data, 0, sizeof data);
5631   data.obstackp = obstackp;
5632
5633   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5634
5635   auto callback = [&] (struct block_symbol *bsym)
5636     {
5637       return aux_add_nonlocal_symbols (bsym, &data);
5638     };
5639
5640   for (objfile *objfile : current_program_space->objfiles ())
5641     {
5642       data.objfile = objfile;
5643
5644       objfile->sf->qf->map_matching_symbols (objfile, lookup_name,
5645                                              domain, global, callback,
5646                                              (is_wild_match
5647                                               ? NULL : compare_names));
5648
5649       for (compunit_symtab *cu : objfile->compunits ())
5650         {
5651           const struct block *global_block
5652             = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5653
5654           if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5655                                        domain))
5656             data.found_sym = 1;
5657         }
5658     }
5659
5660   if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5661     {
5662       const char *name = ada_lookup_name (lookup_name);
5663       lookup_name_info name1 (std::string ("<_ada_") + name + '>',
5664                               symbol_name_match_type::FULL);
5665
5666       for (objfile *objfile : current_program_space->objfiles ())
5667         {
5668           data.objfile = objfile;
5669           objfile->sf->qf->map_matching_symbols (objfile, name1,
5670                                                  domain, global, callback,
5671                                                  compare_names);
5672         }
5673     }           
5674 }
5675
5676 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5677    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5678    returning the number of matches.  Add these to OBSTACKP.
5679
5680    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5681    symbol match within the nest of blocks whose innermost member is BLOCK,
5682    is the one match returned (no other matches in that or
5683    enclosing blocks is returned).  If there are any matches in or
5684    surrounding BLOCK, then these alone are returned.
5685
5686    Names prefixed with "standard__" are handled specially:
5687    "standard__" is first stripped off (by the lookup_name
5688    constructor), and only static and global symbols are searched.
5689
5690    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5691    to lookup global symbols.  */
5692
5693 static void
5694 ada_add_all_symbols (struct obstack *obstackp,
5695                      const struct block *block,
5696                      const lookup_name_info &lookup_name,
5697                      domain_enum domain,
5698                      int full_search,
5699                      int *made_global_lookup_p)
5700 {
5701   struct symbol *sym;
5702
5703   if (made_global_lookup_p)
5704     *made_global_lookup_p = 0;
5705
5706   /* Special case: If the user specifies a symbol name inside package
5707      Standard, do a non-wild matching of the symbol name without
5708      the "standard__" prefix.  This was primarily introduced in order
5709      to allow the user to specifically access the standard exceptions
5710      using, for instance, Standard.Constraint_Error when Constraint_Error
5711      is ambiguous (due to the user defining its own Constraint_Error
5712      entity inside its program).  */
5713   if (lookup_name.ada ().standard_p ())
5714     block = NULL;
5715
5716   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5717
5718   if (block != NULL)
5719     {
5720       if (full_search)
5721         ada_add_local_symbols (obstackp, lookup_name, block, domain);
5722       else
5723         {
5724           /* In the !full_search case we're are being called by
5725              ada_iterate_over_symbols, and we don't want to search
5726              superblocks.  */
5727           ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5728         }
5729       if (num_defns_collected (obstackp) > 0 || !full_search)
5730         return;
5731     }
5732
5733   /* No non-global symbols found.  Check our cache to see if we have
5734      already performed this search before.  If we have, then return
5735      the same result.  */
5736
5737   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5738                             domain, &sym, &block))
5739     {
5740       if (sym != NULL)
5741         add_defn_to_vec (obstackp, sym, block);
5742       return;
5743     }
5744
5745   if (made_global_lookup_p)
5746     *made_global_lookup_p = 1;
5747
5748   /* Search symbols from all global blocks.  */
5749  
5750   add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
5751
5752   /* Now add symbols from all per-file blocks if we've gotten no hits
5753      (not strictly correct, but perhaps better than an error).  */
5754
5755   if (num_defns_collected (obstackp) == 0)
5756     add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
5757 }
5758
5759 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5760    is non-zero, enclosing scope and in global scopes, returning the number of
5761    matches.
5762    Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5763    found and the blocks and symbol tables (if any) in which they were
5764    found.
5765
5766    When full_search is non-zero, any non-function/non-enumeral
5767    symbol match within the nest of blocks whose innermost member is BLOCK,
5768    is the one match returned (no other matches in that or
5769    enclosing blocks is returned).  If there are any matches in or
5770    surrounding BLOCK, then these alone are returned.
5771
5772    Names prefixed with "standard__" are handled specially: "standard__"
5773    is first stripped off, and only static and global symbols are searched.  */
5774
5775 static int
5776 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5777                                const struct block *block,
5778                                domain_enum domain,
5779                                std::vector<struct block_symbol> *results,
5780                                int full_search)
5781 {
5782   int syms_from_global_search;
5783   int ndefns;
5784   auto_obstack obstack;
5785
5786   ada_add_all_symbols (&obstack, block, lookup_name,
5787                        domain, full_search, &syms_from_global_search);
5788
5789   ndefns = num_defns_collected (&obstack);
5790
5791   struct block_symbol *base = defns_collected (&obstack, 1);
5792   for (int i = 0; i < ndefns; ++i)
5793     results->push_back (base[i]);
5794
5795   ndefns = remove_extra_symbols (results);
5796
5797   if (ndefns == 0 && full_search && syms_from_global_search)
5798     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5799
5800   if (ndefns == 1 && full_search && syms_from_global_search)
5801     cache_symbol (ada_lookup_name (lookup_name), domain,
5802                   (*results)[0].symbol, (*results)[0].block);
5803
5804   ndefns = remove_irrelevant_renamings (results, block);
5805
5806   return ndefns;
5807 }
5808
5809 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5810    in global scopes, returning the number of matches, and filling *RESULTS
5811    with (SYM,BLOCK) tuples.
5812
5813    See ada_lookup_symbol_list_worker for further details.  */
5814
5815 int
5816 ada_lookup_symbol_list (const char *name, const struct block *block,
5817                         domain_enum domain,
5818                         std::vector<struct block_symbol> *results)
5819 {
5820   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5821   lookup_name_info lookup_name (name, name_match_type);
5822
5823   return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
5824 }
5825
5826 /* Implementation of the la_iterate_over_symbols method.  */
5827
5828 static bool
5829 ada_iterate_over_symbols
5830   (const struct block *block, const lookup_name_info &name,
5831    domain_enum domain,
5832    gdb::function_view<symbol_found_callback_ftype> callback)
5833 {
5834   int ndefs, i;
5835   std::vector<struct block_symbol> results;
5836
5837   ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5838
5839   for (i = 0; i < ndefs; ++i)
5840     {
5841       if (!callback (&results[i]))
5842         return false;
5843     }
5844
5845   return true;
5846 }
5847
5848 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5849    to 1, but choosing the first symbol found if there are multiple
5850    choices.
5851
5852    The result is stored in *INFO, which must be non-NULL.
5853    If no match is found, INFO->SYM is set to NULL.  */
5854
5855 void
5856 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5857                            domain_enum domain,
5858                            struct block_symbol *info)
5859 {
5860   /* Since we already have an encoded name, wrap it in '<>' to force a
5861      verbatim match.  Otherwise, if the name happens to not look like
5862      an encoded name (because it doesn't include a "__"),
5863      ada_lookup_name_info would re-encode/fold it again, and that
5864      would e.g., incorrectly lowercase object renaming names like
5865      "R28b" -> "r28b".  */
5866   std::string verbatim = std::string ("<") + name + '>';
5867
5868   gdb_assert (info != NULL);
5869   *info = ada_lookup_symbol (verbatim.c_str (), block, domain);
5870 }
5871
5872 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5873    scope and in global scopes, or NULL if none.  NAME is folded and
5874    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5875    choosing the first symbol if there are multiple choices.  */
5876
5877 struct block_symbol
5878 ada_lookup_symbol (const char *name, const struct block *block0,
5879                    domain_enum domain)
5880 {
5881   std::vector<struct block_symbol> candidates;
5882   int n_candidates;
5883
5884   n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
5885
5886   if (n_candidates == 0)
5887     return {};
5888
5889   block_symbol info = candidates[0];
5890   info.symbol = fixup_symbol_section (info.symbol, NULL);
5891   return info;
5892 }
5893
5894 static struct block_symbol
5895 ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5896                             const char *name,
5897                             const struct block *block,
5898                             const domain_enum domain)
5899 {
5900   struct block_symbol sym;
5901
5902   sym = ada_lookup_symbol (name, block_static_block (block), domain);
5903   if (sym.symbol != NULL)
5904     return sym;
5905
5906   /* If we haven't found a match at this point, try the primitive
5907      types.  In other languages, this search is performed before
5908      searching for global symbols in order to short-circuit that
5909      global-symbol search if it happens that the name corresponds
5910      to a primitive type.  But we cannot do the same in Ada, because
5911      it is perfectly legitimate for a program to declare a type which
5912      has the same name as a standard type.  If looking up a type in
5913      that situation, we have traditionally ignored the primitive type
5914      in favor of user-defined types.  This is why, unlike most other
5915      languages, we search the primitive types this late and only after
5916      having searched the global symbols without success.  */
5917
5918   if (domain == VAR_DOMAIN)
5919     {
5920       struct gdbarch *gdbarch;
5921
5922       if (block == NULL)
5923         gdbarch = target_gdbarch ();
5924       else
5925         gdbarch = block_gdbarch (block);
5926       sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5927       if (sym.symbol != NULL)
5928         return sym;
5929     }
5930
5931   return {};
5932 }
5933
5934
5935 /* True iff STR is a possible encoded suffix of a normal Ada name
5936    that is to be ignored for matching purposes.  Suffixes of parallel
5937    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5938    are given by any of the regular expressions:
5939
5940    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5941    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5942    TKB              [subprogram suffix for task bodies]
5943    _E[0-9]+[bs]$    [protected object entry suffixes]
5944    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5945
5946    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5947    match is performed.  This sequence is used to differentiate homonyms,
5948    is an optional part of a valid name suffix.  */
5949
5950 static int
5951 is_name_suffix (const char *str)
5952 {
5953   int k;
5954   const char *matching;
5955   const int len = strlen (str);
5956
5957   /* Skip optional leading __[0-9]+.  */
5958
5959   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5960     {
5961       str += 3;
5962       while (isdigit (str[0]))
5963         str += 1;
5964     }
5965   
5966   /* [.$][0-9]+ */
5967
5968   if (str[0] == '.' || str[0] == '$')
5969     {
5970       matching = str + 1;
5971       while (isdigit (matching[0]))
5972         matching += 1;
5973       if (matching[0] == '\0')
5974         return 1;
5975     }
5976
5977   /* ___[0-9]+ */
5978
5979   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5980     {
5981       matching = str + 3;
5982       while (isdigit (matching[0]))
5983         matching += 1;
5984       if (matching[0] == '\0')
5985         return 1;
5986     }
5987
5988   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
5989
5990   if (strcmp (str, "TKB") == 0)
5991     return 1;
5992
5993 #if 0
5994   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5995      with a N at the end.  Unfortunately, the compiler uses the same
5996      convention for other internal types it creates.  So treating
5997      all entity names that end with an "N" as a name suffix causes
5998      some regressions.  For instance, consider the case of an enumerated
5999      type.  To support the 'Image attribute, it creates an array whose
6000      name ends with N.
6001      Having a single character like this as a suffix carrying some
6002      information is a bit risky.  Perhaps we should change the encoding
6003      to be something like "_N" instead.  In the meantime, do not do
6004      the following check.  */
6005   /* Protected Object Subprograms */
6006   if (len == 1 && str [0] == 'N')
6007     return 1;
6008 #endif
6009
6010   /* _E[0-9]+[bs]$ */
6011   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
6012     {
6013       matching = str + 3;
6014       while (isdigit (matching[0]))
6015         matching += 1;
6016       if ((matching[0] == 'b' || matching[0] == 's')
6017           && matching [1] == '\0')
6018         return 1;
6019     }
6020
6021   /* ??? We should not modify STR directly, as we are doing below.  This
6022      is fine in this case, but may become problematic later if we find
6023      that this alternative did not work, and want to try matching
6024      another one from the begining of STR.  Since we modified it, we
6025      won't be able to find the begining of the string anymore!  */
6026   if (str[0] == 'X')
6027     {
6028       str += 1;
6029       while (str[0] != '_' && str[0] != '\0')
6030         {
6031           if (str[0] != 'n' && str[0] != 'b')
6032             return 0;
6033           str += 1;
6034         }
6035     }
6036
6037   if (str[0] == '\000')
6038     return 1;
6039
6040   if (str[0] == '_')
6041     {
6042       if (str[1] != '_' || str[2] == '\000')
6043         return 0;
6044       if (str[2] == '_')
6045         {
6046           if (strcmp (str + 3, "JM") == 0)
6047             return 1;
6048           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6049              the LJM suffix in favor of the JM one.  But we will
6050              still accept LJM as a valid suffix for a reasonable
6051              amount of time, just to allow ourselves to debug programs
6052              compiled using an older version of GNAT.  */
6053           if (strcmp (str + 3, "LJM") == 0)
6054             return 1;
6055           if (str[3] != 'X')
6056             return 0;
6057           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6058               || str[4] == 'U' || str[4] == 'P')
6059             return 1;
6060           if (str[4] == 'R' && str[5] != 'T')
6061             return 1;
6062           return 0;
6063         }
6064       if (!isdigit (str[2]))
6065         return 0;
6066       for (k = 3; str[k] != '\0'; k += 1)
6067         if (!isdigit (str[k]) && str[k] != '_')
6068           return 0;
6069       return 1;
6070     }
6071   if (str[0] == '$' && isdigit (str[1]))
6072     {
6073       for (k = 2; str[k] != '\0'; k += 1)
6074         if (!isdigit (str[k]) && str[k] != '_')
6075           return 0;
6076       return 1;
6077     }
6078   return 0;
6079 }
6080
6081 /* Return non-zero if the string starting at NAME and ending before
6082    NAME_END contains no capital letters.  */
6083
6084 static int
6085 is_valid_name_for_wild_match (const char *name0)
6086 {
6087   std::string decoded_name = ada_decode (name0);
6088   int i;
6089
6090   /* If the decoded name starts with an angle bracket, it means that
6091      NAME0 does not follow the GNAT encoding format.  It should then
6092      not be allowed as a possible wild match.  */
6093   if (decoded_name[0] == '<')
6094     return 0;
6095
6096   for (i=0; decoded_name[i] != '\0'; i++)
6097     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6098       return 0;
6099
6100   return 1;
6101 }
6102
6103 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6104    that could start a simple name.  Assumes that *NAMEP points into
6105    the string beginning at NAME0.  */
6106
6107 static int
6108 advance_wild_match (const char **namep, const char *name0, int target0)
6109 {
6110   const char *name = *namep;
6111
6112   while (1)
6113     {
6114       int t0, t1;
6115
6116       t0 = *name;
6117       if (t0 == '_')
6118         {
6119           t1 = name[1];
6120           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6121             {
6122               name += 1;
6123               if (name == name0 + 5 && startswith (name0, "_ada"))
6124                 break;
6125               else
6126                 name += 1;
6127             }
6128           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6129                                  || name[2] == target0))
6130             {
6131               name += 2;
6132               break;
6133             }
6134           else
6135             return 0;
6136         }
6137       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6138         name += 1;
6139       else
6140         return 0;
6141     }
6142
6143   *namep = name;
6144   return 1;
6145 }
6146
6147 /* Return true iff NAME encodes a name of the form prefix.PATN.
6148    Ignores any informational suffixes of NAME (i.e., for which
6149    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
6150    simple name.  */
6151
6152 static bool
6153 wild_match (const char *name, const char *patn)
6154 {
6155   const char *p;
6156   const char *name0 = name;
6157
6158   while (1)
6159     {
6160       const char *match = name;
6161
6162       if (*name == *patn)
6163         {
6164           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6165             if (*p != *name)
6166               break;
6167           if (*p == '\0' && is_name_suffix (name))
6168             return match == name0 || is_valid_name_for_wild_match (name0);
6169
6170           if (name[-1] == '_')
6171             name -= 1;
6172         }
6173       if (!advance_wild_match (&name, name0, *patn))
6174         return false;
6175     }
6176 }
6177
6178 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6179    any trailing suffixes that encode debugging information or leading
6180    _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6181    information that is ignored).  */
6182
6183 static bool
6184 full_match (const char *sym_name, const char *search_name)
6185 {
6186   size_t search_name_len = strlen (search_name);
6187
6188   if (strncmp (sym_name, search_name, search_name_len) == 0
6189       && is_name_suffix (sym_name + search_name_len))
6190     return true;
6191
6192   if (startswith (sym_name, "_ada_")
6193       && strncmp (sym_name + 5, search_name, search_name_len) == 0
6194       && is_name_suffix (sym_name + search_name_len + 5))
6195     return true;
6196
6197   return false;
6198 }
6199
6200 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6201    *defn_symbols, updating the list of symbols in OBSTACKP (if
6202    necessary).  OBJFILE is the section containing BLOCK.  */
6203
6204 static void
6205 ada_add_block_symbols (struct obstack *obstackp,
6206                        const struct block *block,
6207                        const lookup_name_info &lookup_name,
6208                        domain_enum domain, struct objfile *objfile)
6209 {
6210   struct block_iterator iter;
6211   /* A matching argument symbol, if any.  */
6212   struct symbol *arg_sym;
6213   /* Set true when we find a matching non-argument symbol.  */
6214   int found_sym;
6215   struct symbol *sym;
6216
6217   arg_sym = NULL;
6218   found_sym = 0;
6219   for (sym = block_iter_match_first (block, lookup_name, &iter);
6220        sym != NULL;
6221        sym = block_iter_match_next (lookup_name, &iter))
6222     {
6223       if (symbol_matches_domain (sym->language (), SYMBOL_DOMAIN (sym), domain))
6224         {
6225           if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6226             {
6227               if (SYMBOL_IS_ARGUMENT (sym))
6228                 arg_sym = sym;
6229               else
6230                 {
6231                   found_sym = 1;
6232                   add_defn_to_vec (obstackp,
6233                                    fixup_symbol_section (sym, objfile),
6234                                    block);
6235                 }
6236             }
6237         }
6238     }
6239
6240   /* Handle renamings.  */
6241
6242   if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
6243     found_sym = 1;
6244
6245   if (!found_sym && arg_sym != NULL)
6246     {
6247       add_defn_to_vec (obstackp,
6248                        fixup_symbol_section (arg_sym, objfile),
6249                        block);
6250     }
6251
6252   if (!lookup_name.ada ().wild_match_p ())
6253     {
6254       arg_sym = NULL;
6255       found_sym = 0;
6256       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6257       const char *name = ada_lookup_name.c_str ();
6258       size_t name_len = ada_lookup_name.size ();
6259
6260       ALL_BLOCK_SYMBOLS (block, iter, sym)
6261       {
6262         if (symbol_matches_domain (sym->language (),
6263                                    SYMBOL_DOMAIN (sym), domain))
6264           {
6265             int cmp;
6266
6267             cmp = (int) '_' - (int) sym->linkage_name ()[0];
6268             if (cmp == 0)
6269               {
6270                 cmp = !startswith (sym->linkage_name (), "_ada_");
6271                 if (cmp == 0)
6272                   cmp = strncmp (name, sym->linkage_name () + 5,
6273                                  name_len);
6274               }
6275
6276             if (cmp == 0
6277                 && is_name_suffix (sym->linkage_name () + name_len + 5))
6278               {
6279                 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6280                   {
6281                     if (SYMBOL_IS_ARGUMENT (sym))
6282                       arg_sym = sym;
6283                     else
6284                       {
6285                         found_sym = 1;
6286                         add_defn_to_vec (obstackp,
6287                                          fixup_symbol_section (sym, objfile),
6288                                          block);
6289                       }
6290                   }
6291               }
6292           }
6293       }
6294
6295       /* NOTE: This really shouldn't be needed for _ada_ symbols.
6296          They aren't parameters, right?  */
6297       if (!found_sym && arg_sym != NULL)
6298         {
6299           add_defn_to_vec (obstackp,
6300                            fixup_symbol_section (arg_sym, objfile),
6301                            block);
6302         }
6303     }
6304 }
6305 \f
6306
6307                                 /* Symbol Completion */
6308
6309 /* See symtab.h.  */
6310
6311 bool
6312 ada_lookup_name_info::matches
6313   (const char *sym_name,
6314    symbol_name_match_type match_type,
6315    completion_match_result *comp_match_res) const
6316 {
6317   bool match = false;
6318   const char *text = m_encoded_name.c_str ();
6319   size_t text_len = m_encoded_name.size ();
6320
6321   /* First, test against the fully qualified name of the symbol.  */
6322
6323   if (strncmp (sym_name, text, text_len) == 0)
6324     match = true;
6325
6326   std::string decoded_name = ada_decode (sym_name);
6327   if (match && !m_encoded_p)
6328     {
6329       /* One needed check before declaring a positive match is to verify
6330          that iff we are doing a verbatim match, the decoded version
6331          of the symbol name starts with '<'.  Otherwise, this symbol name
6332          is not a suitable completion.  */
6333
6334       bool has_angle_bracket = (decoded_name[0] == '<');
6335       match = (has_angle_bracket == m_verbatim_p);
6336     }
6337
6338   if (match && !m_verbatim_p)
6339     {
6340       /* When doing non-verbatim match, another check that needs to
6341          be done is to verify that the potentially matching symbol name
6342          does not include capital letters, because the ada-mode would
6343          not be able to understand these symbol names without the
6344          angle bracket notation.  */
6345       const char *tmp;
6346
6347       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6348       if (*tmp != '\0')
6349         match = false;
6350     }
6351
6352   /* Second: Try wild matching...  */
6353
6354   if (!match && m_wild_match_p)
6355     {
6356       /* Since we are doing wild matching, this means that TEXT
6357          may represent an unqualified symbol name.  We therefore must
6358          also compare TEXT against the unqualified name of the symbol.  */
6359       sym_name = ada_unqualified_name (decoded_name.c_str ());
6360
6361       if (strncmp (sym_name, text, text_len) == 0)
6362         match = true;
6363     }
6364
6365   /* Finally: If we found a match, prepare the result to return.  */
6366
6367   if (!match)
6368     return false;
6369
6370   if (comp_match_res != NULL)
6371     {
6372       std::string &match_str = comp_match_res->match.storage ();
6373
6374       if (!m_encoded_p)
6375         match_str = ada_decode (sym_name);
6376       else
6377         {
6378           if (m_verbatim_p)
6379             match_str = add_angle_brackets (sym_name);
6380           else
6381             match_str = sym_name;
6382
6383         }
6384
6385       comp_match_res->set_match (match_str.c_str ());
6386     }
6387
6388   return true;
6389 }
6390
6391 /* Add the list of possible symbol names completing TEXT to TRACKER.
6392    WORD is the entire command on which completion is made.  */
6393
6394 static void
6395 ada_collect_symbol_completion_matches (completion_tracker &tracker,
6396                                        complete_symbol_mode mode,
6397                                        symbol_name_match_type name_match_type,
6398                                        const char *text, const char *word,
6399                                        enum type_code code)
6400 {
6401   struct symbol *sym;
6402   const struct block *b, *surrounding_static_block = 0;
6403   struct block_iterator iter;
6404
6405   gdb_assert (code == TYPE_CODE_UNDEF);
6406
6407   lookup_name_info lookup_name (text, name_match_type, true);
6408
6409   /* First, look at the partial symtab symbols.  */
6410   expand_symtabs_matching (NULL,
6411                            lookup_name,
6412                            NULL,
6413                            NULL,
6414                            ALL_DOMAIN);
6415
6416   /* At this point scan through the misc symbol vectors and add each
6417      symbol you find to the list.  Eventually we want to ignore
6418      anything that isn't a text symbol (everything else will be
6419      handled by the psymtab code above).  */
6420
6421   for (objfile *objfile : current_program_space->objfiles ())
6422     {
6423       for (minimal_symbol *msymbol : objfile->msymbols ())
6424         {
6425           QUIT;
6426
6427           if (completion_skip_symbol (mode, msymbol))
6428             continue;
6429
6430           language symbol_language = msymbol->language ();
6431
6432           /* Ada minimal symbols won't have their language set to Ada.  If
6433              we let completion_list_add_name compare using the
6434              default/C-like matcher, then when completing e.g., symbols in a
6435              package named "pck", we'd match internal Ada symbols like
6436              "pckS", which are invalid in an Ada expression, unless you wrap
6437              them in '<' '>' to request a verbatim match.
6438
6439              Unfortunately, some Ada encoded names successfully demangle as
6440              C++ symbols (using an old mangling scheme), such as "name__2Xn"
6441              -> "Xn::name(void)" and thus some Ada minimal symbols end up
6442              with the wrong language set.  Paper over that issue here.  */
6443           if (symbol_language == language_auto
6444               || symbol_language == language_cplus)
6445             symbol_language = language_ada;
6446
6447           completion_list_add_name (tracker,
6448                                     symbol_language,
6449                                     msymbol->linkage_name (),
6450                                     lookup_name, text, word);
6451         }
6452     }
6453
6454   /* Search upwards from currently selected frame (so that we can
6455      complete on local vars.  */
6456
6457   for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6458     {
6459       if (!BLOCK_SUPERBLOCK (b))
6460         surrounding_static_block = b;   /* For elmin of dups */
6461
6462       ALL_BLOCK_SYMBOLS (b, iter, sym)
6463       {
6464         if (completion_skip_symbol (mode, sym))
6465           continue;
6466
6467         completion_list_add_name (tracker,
6468                                   sym->language (),
6469                                   sym->linkage_name (),
6470                                   lookup_name, text, word);
6471       }
6472     }
6473
6474   /* Go through the symtabs and check the externs and statics for
6475      symbols which match.  */
6476
6477   for (objfile *objfile : current_program_space->objfiles ())
6478     {
6479       for (compunit_symtab *s : objfile->compunits ())
6480         {
6481           QUIT;
6482           b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
6483           ALL_BLOCK_SYMBOLS (b, iter, sym)
6484             {
6485               if (completion_skip_symbol (mode, sym))
6486                 continue;
6487
6488               completion_list_add_name (tracker,
6489                                         sym->language (),
6490                                         sym->linkage_name (),
6491                                         lookup_name, text, word);
6492             }
6493         }
6494     }
6495
6496   for (objfile *objfile : current_program_space->objfiles ())
6497     {
6498       for (compunit_symtab *s : objfile->compunits ())
6499         {
6500           QUIT;
6501           b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
6502           /* Don't do this block twice.  */
6503           if (b == surrounding_static_block)
6504             continue;
6505           ALL_BLOCK_SYMBOLS (b, iter, sym)
6506             {
6507               if (completion_skip_symbol (mode, sym))
6508                 continue;
6509
6510               completion_list_add_name (tracker,
6511                                         sym->language (),
6512                                         sym->linkage_name (),
6513                                         lookup_name, text, word);
6514             }
6515         }
6516     }
6517 }
6518
6519                                 /* Field Access */
6520
6521 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6522    for tagged types.  */
6523
6524 static int
6525 ada_is_dispatch_table_ptr_type (struct type *type)
6526 {
6527   const char *name;
6528
6529   if (TYPE_CODE (type) != TYPE_CODE_PTR)
6530     return 0;
6531
6532   name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6533   if (name == NULL)
6534     return 0;
6535
6536   return (strcmp (name, "ada__tags__dispatch_table") == 0);
6537 }
6538
6539 /* Return non-zero if TYPE is an interface tag.  */
6540
6541 static int
6542 ada_is_interface_tag (struct type *type)
6543 {
6544   const char *name = TYPE_NAME (type);
6545
6546   if (name == NULL)
6547     return 0;
6548
6549   return (strcmp (name, "ada__tags__interface_tag") == 0);
6550 }
6551
6552 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6553    to be invisible to users.  */
6554
6555 int
6556 ada_is_ignored_field (struct type *type, int field_num)
6557 {
6558   if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6559     return 1;
6560
6561   /* Check the name of that field.  */
6562   {
6563     const char *name = TYPE_FIELD_NAME (type, field_num);
6564
6565     /* Anonymous field names should not be printed.
6566        brobecker/2007-02-20: I don't think this can actually happen
6567        but we don't want to print the value of anonymous fields anyway.  */
6568     if (name == NULL)
6569       return 1;
6570
6571     /* Normally, fields whose name start with an underscore ("_")
6572        are fields that have been internally generated by the compiler,
6573        and thus should not be printed.  The "_parent" field is special,
6574        however: This is a field internally generated by the compiler
6575        for tagged types, and it contains the components inherited from
6576        the parent type.  This field should not be printed as is, but
6577        should not be ignored either.  */
6578     if (name[0] == '_' && !startswith (name, "_parent"))
6579       return 1;
6580   }
6581
6582   /* If this is the dispatch table of a tagged type or an interface tag,
6583      then ignore.  */
6584   if (ada_is_tagged_type (type, 1)
6585       && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6586           || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
6587     return 1;
6588
6589   /* Not a special field, so it should not be ignored.  */
6590   return 0;
6591 }
6592
6593 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
6594    pointer or reference type whose ultimate target has a tag field.  */
6595
6596 int
6597 ada_is_tagged_type (struct type *type, int refok)
6598 {
6599   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6600 }
6601
6602 /* True iff TYPE represents the type of X'Tag */
6603
6604 int
6605 ada_is_tag_type (struct type *type)
6606 {
6607   type = ada_check_typedef (type);
6608
6609   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6610     return 0;
6611   else
6612     {
6613       const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6614
6615       return (name != NULL
6616               && strcmp (name, "ada__tags__dispatch_table") == 0);
6617     }
6618 }
6619
6620 /* The type of the tag on VAL.  */
6621
6622 static struct type *
6623 ada_tag_type (struct value *val)
6624 {
6625   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6626 }
6627
6628 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6629    retired at Ada 05).  */
6630
6631 static int
6632 is_ada95_tag (struct value *tag)
6633 {
6634   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6635 }
6636
6637 /* The value of the tag on VAL.  */
6638
6639 static struct value *
6640 ada_value_tag (struct value *val)
6641 {
6642   return ada_value_struct_elt (val, "_tag", 0);
6643 }
6644
6645 /* The value of the tag on the object of type TYPE whose contents are
6646    saved at VALADDR, if it is non-null, or is at memory address
6647    ADDRESS.  */
6648
6649 static struct value *
6650 value_tag_from_contents_and_address (struct type *type,
6651                                      const gdb_byte *valaddr,
6652                                      CORE_ADDR address)
6653 {
6654   int tag_byte_offset;
6655   struct type *tag_type;
6656
6657   if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
6658                          NULL, NULL, NULL))
6659     {
6660       const gdb_byte *valaddr1 = ((valaddr == NULL)
6661                                   ? NULL
6662                                   : valaddr + tag_byte_offset);
6663       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6664
6665       return value_from_contents_and_address (tag_type, valaddr1, address1);
6666     }
6667   return NULL;
6668 }
6669
6670 static struct type *
6671 type_from_tag (struct value *tag)
6672 {
6673   const char *type_name = ada_tag_name (tag);
6674
6675   if (type_name != NULL)
6676     return ada_find_any_type (ada_encode (type_name));
6677   return NULL;
6678 }
6679
6680 /* Given a value OBJ of a tagged type, return a value of this
6681    type at the base address of the object.  The base address, as
6682    defined in Ada.Tags, it is the address of the primary tag of
6683    the object, and therefore where the field values of its full
6684    view can be fetched.  */
6685
6686 struct value *
6687 ada_tag_value_at_base_address (struct value *obj)
6688 {
6689   struct value *val;
6690   LONGEST offset_to_top = 0;
6691   struct type *ptr_type, *obj_type;
6692   struct value *tag;
6693   CORE_ADDR base_address;
6694
6695   obj_type = value_type (obj);
6696
6697   /* It is the responsability of the caller to deref pointers.  */
6698
6699   if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6700       || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6701     return obj;
6702
6703   tag = ada_value_tag (obj);
6704   if (!tag)
6705     return obj;
6706
6707   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6708
6709   if (is_ada95_tag (tag))
6710     return obj;
6711
6712   ptr_type = language_lookup_primitive_type
6713     (language_def (language_ada), target_gdbarch(), "storage_offset");
6714   ptr_type = lookup_pointer_type (ptr_type);
6715   val = value_cast (ptr_type, tag);
6716   if (!val)
6717     return obj;
6718
6719   /* It is perfectly possible that an exception be raised while
6720      trying to determine the base address, just like for the tag;
6721      see ada_tag_name for more details.  We do not print the error
6722      message for the same reason.  */
6723
6724   try
6725     {
6726       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6727     }
6728
6729   catch (const gdb_exception_error &e)
6730     {
6731       return obj;
6732     }
6733
6734   /* If offset is null, nothing to do.  */
6735
6736   if (offset_to_top == 0)
6737     return obj;
6738
6739   /* -1 is a special case in Ada.Tags; however, what should be done
6740      is not quite clear from the documentation.  So do nothing for
6741      now.  */
6742
6743   if (offset_to_top == -1)
6744     return obj;
6745
6746   /* OFFSET_TO_TOP used to be a positive value to be subtracted
6747      from the base address.  This was however incompatible with
6748      C++ dispatch table: C++ uses a *negative* value to *add*
6749      to the base address.  Ada's convention has therefore been
6750      changed in GNAT 19.0w 20171023: since then, C++ and Ada
6751      use the same convention.  Here, we support both cases by
6752      checking the sign of OFFSET_TO_TOP.  */
6753
6754   if (offset_to_top > 0)
6755     offset_to_top = -offset_to_top;
6756
6757   base_address = value_address (obj) + offset_to_top;
6758   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6759
6760   /* Make sure that we have a proper tag at the new address.
6761      Otherwise, offset_to_top is bogus (which can happen when
6762      the object is not initialized yet).  */
6763
6764   if (!tag)
6765     return obj;
6766
6767   obj_type = type_from_tag (tag);
6768
6769   if (!obj_type)
6770     return obj;
6771
6772   return value_from_contents_and_address (obj_type, NULL, base_address);
6773 }
6774
6775 /* Return the "ada__tags__type_specific_data" type.  */
6776
6777 static struct type *
6778 ada_get_tsd_type (struct inferior *inf)
6779 {
6780   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6781
6782   if (data->tsd_type == 0)
6783     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6784   return data->tsd_type;
6785 }
6786
6787 /* Return the TSD (type-specific data) associated to the given TAG.
6788    TAG is assumed to be the tag of a tagged-type entity.
6789
6790    May return NULL if we are unable to get the TSD.  */
6791
6792 static struct value *
6793 ada_get_tsd_from_tag (struct value *tag)
6794 {
6795   struct value *val;
6796   struct type *type;
6797
6798   /* First option: The TSD is simply stored as a field of our TAG.
6799      Only older versions of GNAT would use this format, but we have
6800      to test it first, because there are no visible markers for
6801      the current approach except the absence of that field.  */
6802
6803   val = ada_value_struct_elt (tag, "tsd", 1);
6804   if (val)
6805     return val;
6806
6807   /* Try the second representation for the dispatch table (in which
6808      there is no explicit 'tsd' field in the referent of the tag pointer,
6809      and instead the tsd pointer is stored just before the dispatch
6810      table.  */
6811
6812   type = ada_get_tsd_type (current_inferior());
6813   if (type == NULL)
6814     return NULL;
6815   type = lookup_pointer_type (lookup_pointer_type (type));
6816   val = value_cast (type, tag);
6817   if (val == NULL)
6818     return NULL;
6819   return value_ind (value_ptradd (val, -1));
6820 }
6821
6822 /* Given the TSD of a tag (type-specific data), return a string
6823    containing the name of the associated type.
6824
6825    The returned value is good until the next call.  May return NULL
6826    if we are unable to determine the tag name.  */
6827
6828 static char *
6829 ada_tag_name_from_tsd (struct value *tsd)
6830 {
6831   static char name[1024];
6832   char *p;
6833   struct value *val;
6834
6835   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6836   if (val == NULL)
6837     return NULL;
6838   read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6839   for (p = name; *p != '\0'; p += 1)
6840     if (isalpha (*p))
6841       *p = tolower (*p);
6842   return name;
6843 }
6844
6845 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6846    a C string.
6847
6848    Return NULL if the TAG is not an Ada tag, or if we were unable to
6849    determine the name of that tag.  The result is good until the next
6850    call.  */
6851
6852 const char *
6853 ada_tag_name (struct value *tag)
6854 {
6855   char *name = NULL;
6856
6857   if (!ada_is_tag_type (value_type (tag)))
6858     return NULL;
6859
6860   /* It is perfectly possible that an exception be raised while trying
6861      to determine the TAG's name, even under normal circumstances:
6862      The associated variable may be uninitialized or corrupted, for
6863      instance. We do not let any exception propagate past this point.
6864      instead we return NULL.
6865
6866      We also do not print the error message either (which often is very
6867      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6868      the caller print a more meaningful message if necessary.  */
6869   try
6870     {
6871       struct value *tsd = ada_get_tsd_from_tag (tag);
6872
6873       if (tsd != NULL)
6874         name = ada_tag_name_from_tsd (tsd);
6875     }
6876   catch (const gdb_exception_error &e)
6877     {
6878     }
6879
6880   return name;
6881 }
6882
6883 /* The parent type of TYPE, or NULL if none.  */
6884
6885 struct type *
6886 ada_parent_type (struct type *type)
6887 {
6888   int i;
6889
6890   type = ada_check_typedef (type);
6891
6892   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6893     return NULL;
6894
6895   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6896     if (ada_is_parent_field (type, i))
6897       {
6898         struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6899
6900         /* If the _parent field is a pointer, then dereference it.  */
6901         if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6902           parent_type = TYPE_TARGET_TYPE (parent_type);
6903         /* If there is a parallel XVS type, get the actual base type.  */
6904         parent_type = ada_get_base_type (parent_type);
6905
6906         return ada_check_typedef (parent_type);
6907       }
6908
6909   return NULL;
6910 }
6911
6912 /* True iff field number FIELD_NUM of structure type TYPE contains the
6913    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6914    a structure type with at least FIELD_NUM+1 fields.  */
6915
6916 int
6917 ada_is_parent_field (struct type *type, int field_num)
6918 {
6919   const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
6920
6921   return (name != NULL
6922           && (startswith (name, "PARENT")
6923               || startswith (name, "_parent")));
6924 }
6925
6926 /* True iff field number FIELD_NUM of structure type TYPE is a
6927    transparent wrapper field (which should be silently traversed when doing
6928    field selection and flattened when printing).  Assumes TYPE is a
6929    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6930    structures.  */
6931
6932 int
6933 ada_is_wrapper_field (struct type *type, int field_num)
6934 {
6935   const char *name = TYPE_FIELD_NAME (type, field_num);
6936
6937   if (name != NULL && strcmp (name, "RETVAL") == 0)
6938     {
6939       /* This happens in functions with "out" or "in out" parameters
6940          which are passed by copy.  For such functions, GNAT describes
6941          the function's return type as being a struct where the return
6942          value is in a field called RETVAL, and where the other "out"
6943          or "in out" parameters are fields of that struct.  This is not
6944          a wrapper.  */
6945       return 0;
6946     }
6947
6948   return (name != NULL
6949           && (startswith (name, "PARENT")
6950               || strcmp (name, "REP") == 0
6951               || startswith (name, "_parent")
6952               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6953 }
6954
6955 /* True iff field number FIELD_NUM of structure or union type TYPE
6956    is a variant wrapper.  Assumes TYPE is a structure type with at least
6957    FIELD_NUM+1 fields.  */
6958
6959 int
6960 ada_is_variant_part (struct type *type, int field_num)
6961 {
6962   /* Only Ada types are eligible.  */
6963   if (!ADA_TYPE_P (type))
6964     return 0;
6965
6966   struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
6967
6968   return (TYPE_CODE (field_type) == TYPE_CODE_UNION
6969           || (is_dynamic_field (type, field_num)
6970               && (TYPE_CODE (TYPE_TARGET_TYPE (field_type)) 
6971                   == TYPE_CODE_UNION)));
6972 }
6973
6974 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6975    whose discriminants are contained in the record type OUTER_TYPE,
6976    returns the type of the controlling discriminant for the variant.
6977    May return NULL if the type could not be found.  */
6978
6979 struct type *
6980 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6981 {
6982   const char *name = ada_variant_discrim_name (var_type);
6983
6984   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
6985 }
6986
6987 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6988    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6989    represents a 'when others' clause; otherwise 0.  */
6990
6991 static int
6992 ada_is_others_clause (struct type *type, int field_num)
6993 {
6994   const char *name = TYPE_FIELD_NAME (type, field_num);
6995
6996   return (name != NULL && name[0] == 'O');
6997 }
6998
6999 /* Assuming that TYPE0 is the type of the variant part of a record,
7000    returns the name of the discriminant controlling the variant.
7001    The value is valid until the next call to ada_variant_discrim_name.  */
7002
7003 const char *
7004 ada_variant_discrim_name (struct type *type0)
7005 {
7006   static char *result = NULL;
7007   static size_t result_len = 0;
7008   struct type *type;
7009   const char *name;
7010   const char *discrim_end;
7011   const char *discrim_start;
7012
7013   if (TYPE_CODE (type0) == TYPE_CODE_PTR)
7014     type = TYPE_TARGET_TYPE (type0);
7015   else
7016     type = type0;
7017
7018   name = ada_type_name (type);
7019
7020   if (name == NULL || name[0] == '\000')
7021     return "";
7022
7023   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7024        discrim_end -= 1)
7025     {
7026       if (startswith (discrim_end, "___XVN"))
7027         break;
7028     }
7029   if (discrim_end == name)
7030     return "";
7031
7032   for (discrim_start = discrim_end; discrim_start != name + 3;
7033        discrim_start -= 1)
7034     {
7035       if (discrim_start == name + 1)
7036         return "";
7037       if ((discrim_start > name + 3
7038            && startswith (discrim_start - 3, "___"))
7039           || discrim_start[-1] == '.')
7040         break;
7041     }
7042
7043   GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7044   strncpy (result, discrim_start, discrim_end - discrim_start);
7045   result[discrim_end - discrim_start] = '\0';
7046   return result;
7047 }
7048
7049 /* Scan STR for a subtype-encoded number, beginning at position K.
7050    Put the position of the character just past the number scanned in
7051    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
7052    Return 1 if there was a valid number at the given position, and 0
7053    otherwise.  A "subtype-encoded" number consists of the absolute value
7054    in decimal, followed by the letter 'm' to indicate a negative number.
7055    Assumes 0m does not occur.  */
7056
7057 int
7058 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
7059 {
7060   ULONGEST RU;
7061
7062   if (!isdigit (str[k]))
7063     return 0;
7064
7065   /* Do it the hard way so as not to make any assumption about
7066      the relationship of unsigned long (%lu scan format code) and
7067      LONGEST.  */
7068   RU = 0;
7069   while (isdigit (str[k]))
7070     {
7071       RU = RU * 10 + (str[k] - '0');
7072       k += 1;
7073     }
7074
7075   if (str[k] == 'm')
7076     {
7077       if (R != NULL)
7078         *R = (-(LONGEST) (RU - 1)) - 1;
7079       k += 1;
7080     }
7081   else if (R != NULL)
7082     *R = (LONGEST) RU;
7083
7084   /* NOTE on the above: Technically, C does not say what the results of
7085      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7086      number representable as a LONGEST (although either would probably work
7087      in most implementations).  When RU>0, the locution in the then branch
7088      above is always equivalent to the negative of RU.  */
7089
7090   if (new_k != NULL)
7091     *new_k = k;
7092   return 1;
7093 }
7094
7095 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7096    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7097    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
7098
7099 static int
7100 ada_in_variant (LONGEST val, struct type *type, int field_num)
7101 {
7102   const char *name = TYPE_FIELD_NAME (type, field_num);
7103   int p;
7104
7105   p = 0;
7106   while (1)
7107     {
7108       switch (name[p])
7109         {
7110         case '\0':
7111           return 0;
7112         case 'S':
7113           {
7114             LONGEST W;
7115
7116             if (!ada_scan_number (name, p + 1, &W, &p))
7117               return 0;
7118             if (val == W)
7119               return 1;
7120             break;
7121           }
7122         case 'R':
7123           {
7124             LONGEST L, U;
7125
7126             if (!ada_scan_number (name, p + 1, &L, &p)
7127                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7128               return 0;
7129             if (val >= L && val <= U)
7130               return 1;
7131             break;
7132           }
7133         case 'O':
7134           return 1;
7135         default:
7136           return 0;
7137         }
7138     }
7139 }
7140
7141 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
7142
7143 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7144    ARG_TYPE, extract and return the value of one of its (non-static)
7145    fields.  FIELDNO says which field.   Differs from value_primitive_field
7146    only in that it can handle packed values of arbitrary type.  */
7147
7148 static struct value *
7149 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
7150                            struct type *arg_type)
7151 {
7152   struct type *type;
7153
7154   arg_type = ada_check_typedef (arg_type);
7155   type = TYPE_FIELD_TYPE (arg_type, fieldno);
7156
7157   /* Handle packed fields.  It might be that the field is not packed
7158      relative to its containing structure, but the structure itself is
7159      packed; in this case we must take the bit-field path.  */
7160   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
7161     {
7162       int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7163       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
7164
7165       return ada_value_primitive_packed_val (arg1, value_contents (arg1),
7166                                              offset + bit_pos / 8,
7167                                              bit_pos % 8, bit_size, type);
7168     }
7169   else
7170     return value_primitive_field (arg1, offset, fieldno, arg_type);
7171 }
7172
7173 /* Find field with name NAME in object of type TYPE.  If found, 
7174    set the following for each argument that is non-null:
7175     - *FIELD_TYPE_P to the field's type; 
7176     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
7177       an object of that type;
7178     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
7179     - *BIT_SIZE_P to its size in bits if the field is packed, and 
7180       0 otherwise;
7181    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7182    fields up to but not including the desired field, or by the total
7183    number of fields if not found.   A NULL value of NAME never
7184    matches; the function just counts visible fields in this case.
7185    
7186    Notice that we need to handle when a tagged record hierarchy
7187    has some components with the same name, like in this scenario:
7188
7189       type Top_T is tagged record
7190          N : Integer := 1;
7191          U : Integer := 974;
7192          A : Integer := 48;
7193       end record;
7194
7195       type Middle_T is new Top.Top_T with record
7196          N : Character := 'a';
7197          C : Integer := 3;
7198       end record;
7199
7200      type Bottom_T is new Middle.Middle_T with record
7201         N : Float := 4.0;
7202         C : Character := '5';
7203         X : Integer := 6;
7204         A : Character := 'J';
7205      end record;
7206
7207    Let's say we now have a variable declared and initialized as follow:
7208
7209      TC : Top_A := new Bottom_T;
7210
7211    And then we use this variable to call this function
7212
7213      procedure Assign (Obj: in out Top_T; TV : Integer);
7214
7215    as follow:
7216
7217       Assign (Top_T (B), 12);
7218
7219    Now, we're in the debugger, and we're inside that procedure
7220    then and we want to print the value of obj.c:
7221
7222    Usually, the tagged record or one of the parent type owns the
7223    component to print and there's no issue but in this particular
7224    case, what does it mean to ask for Obj.C? Since the actual
7225    type for object is type Bottom_T, it could mean two things: type
7226    component C from the Middle_T view, but also component C from
7227    Bottom_T.  So in that "undefined" case, when the component is
7228    not found in the non-resolved type (which includes all the
7229    components of the parent type), then resolve it and see if we
7230    get better luck once expanded.
7231
7232    In the case of homonyms in the derived tagged type, we don't
7233    guaranty anything, and pick the one that's easiest for us
7234    to program.
7235
7236    Returns 1 if found, 0 otherwise.  */
7237
7238 static int
7239 find_struct_field (const char *name, struct type *type, int offset,
7240                    struct type **field_type_p,
7241                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7242                    int *index_p)
7243 {
7244   int i;
7245   int parent_offset = -1;
7246
7247   type = ada_check_typedef (type);
7248
7249   if (field_type_p != NULL)
7250     *field_type_p = NULL;
7251   if (byte_offset_p != NULL)
7252     *byte_offset_p = 0;
7253   if (bit_offset_p != NULL)
7254     *bit_offset_p = 0;
7255   if (bit_size_p != NULL)
7256     *bit_size_p = 0;
7257
7258   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7259     {
7260       int bit_pos = TYPE_FIELD_BITPOS (type, i);
7261       int fld_offset = offset + bit_pos / 8;
7262       const char *t_field_name = TYPE_FIELD_NAME (type, i);
7263
7264       if (t_field_name == NULL)
7265         continue;
7266
7267       else if (ada_is_parent_field (type, i))
7268         {
7269           /* This is a field pointing us to the parent type of a tagged
7270              type.  As hinted in this function's documentation, we give
7271              preference to fields in the current record first, so what
7272              we do here is just record the index of this field before
7273              we skip it.  If it turns out we couldn't find our field
7274              in the current record, then we'll get back to it and search
7275              inside it whether the field might exist in the parent.  */
7276
7277           parent_offset = i;
7278           continue;
7279         }
7280
7281       else if (name != NULL && field_name_match (t_field_name, name))
7282         {
7283           int bit_size = TYPE_FIELD_BITSIZE (type, i);
7284
7285           if (field_type_p != NULL)
7286             *field_type_p = TYPE_FIELD_TYPE (type, i);
7287           if (byte_offset_p != NULL)
7288             *byte_offset_p = fld_offset;
7289           if (bit_offset_p != NULL)
7290             *bit_offset_p = bit_pos % 8;
7291           if (bit_size_p != NULL)
7292             *bit_size_p = bit_size;
7293           return 1;
7294         }
7295       else if (ada_is_wrapper_field (type, i))
7296         {
7297           if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7298                                  field_type_p, byte_offset_p, bit_offset_p,
7299                                  bit_size_p, index_p))
7300             return 1;
7301         }
7302       else if (ada_is_variant_part (type, i))
7303         {
7304           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
7305              fixed type?? */
7306           int j;
7307           struct type *field_type
7308             = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
7309
7310           for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7311             {
7312               if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7313                                      fld_offset
7314                                      + TYPE_FIELD_BITPOS (field_type, j) / 8,
7315                                      field_type_p, byte_offset_p,
7316                                      bit_offset_p, bit_size_p, index_p))
7317                 return 1;
7318             }
7319         }
7320       else if (index_p != NULL)
7321         *index_p += 1;
7322     }
7323
7324   /* Field not found so far.  If this is a tagged type which
7325      has a parent, try finding that field in the parent now.  */
7326
7327   if (parent_offset != -1)
7328     {
7329       int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7330       int fld_offset = offset + bit_pos / 8;
7331
7332       if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7333                              fld_offset, field_type_p, byte_offset_p,
7334                              bit_offset_p, bit_size_p, index_p))
7335         return 1;
7336     }
7337
7338   return 0;
7339 }
7340
7341 /* Number of user-visible fields in record type TYPE.  */
7342
7343 static int
7344 num_visible_fields (struct type *type)
7345 {
7346   int n;
7347
7348   n = 0;
7349   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7350   return n;
7351 }
7352
7353 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
7354    and search in it assuming it has (class) type TYPE.
7355    If found, return value, else return NULL.
7356
7357    Searches recursively through wrapper fields (e.g., '_parent').
7358
7359    In the case of homonyms in the tagged types, please refer to the
7360    long explanation in find_struct_field's function documentation.  */
7361
7362 static struct value *
7363 ada_search_struct_field (const char *name, struct value *arg, int offset,
7364                          struct type *type)
7365 {
7366   int i;
7367   int parent_offset = -1;
7368
7369   type = ada_check_typedef (type);
7370   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7371     {
7372       const char *t_field_name = TYPE_FIELD_NAME (type, i);
7373
7374       if (t_field_name == NULL)
7375         continue;
7376
7377       else if (ada_is_parent_field (type, i))
7378         {
7379           /* This is a field pointing us to the parent type of a tagged
7380              type.  As hinted in this function's documentation, we give
7381              preference to fields in the current record first, so what
7382              we do here is just record the index of this field before
7383              we skip it.  If it turns out we couldn't find our field
7384              in the current record, then we'll get back to it and search
7385              inside it whether the field might exist in the parent.  */
7386
7387           parent_offset = i;
7388           continue;
7389         }
7390
7391       else if (field_name_match (t_field_name, name))
7392         return ada_value_primitive_field (arg, offset, i, type);
7393
7394       else if (ada_is_wrapper_field (type, i))
7395         {
7396           struct value *v =     /* Do not let indent join lines here.  */
7397             ada_search_struct_field (name, arg,
7398                                      offset + TYPE_FIELD_BITPOS (type, i) / 8,
7399                                      TYPE_FIELD_TYPE (type, i));
7400
7401           if (v != NULL)
7402             return v;
7403         }
7404
7405       else if (ada_is_variant_part (type, i))
7406         {
7407           /* PNH: Do we ever get here?  See find_struct_field.  */
7408           int j;
7409           struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7410                                                                         i));
7411           int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7412
7413           for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7414             {
7415               struct value *v = ada_search_struct_field /* Force line
7416                                                            break.  */
7417                 (name, arg,
7418                  var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7419                  TYPE_FIELD_TYPE (field_type, j));
7420
7421               if (v != NULL)
7422                 return v;
7423             }
7424         }
7425     }
7426
7427   /* Field not found so far.  If this is a tagged type which
7428      has a parent, try finding that field in the parent now.  */
7429
7430   if (parent_offset != -1)
7431     {
7432       struct value *v = ada_search_struct_field (
7433         name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7434         TYPE_FIELD_TYPE (type, parent_offset));
7435
7436       if (v != NULL)
7437         return v;
7438     }
7439
7440   return NULL;
7441 }
7442
7443 static struct value *ada_index_struct_field_1 (int *, struct value *,
7444                                                int, struct type *);
7445
7446
7447 /* Return field #INDEX in ARG, where the index is that returned by
7448  * find_struct_field through its INDEX_P argument.  Adjust the address
7449  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7450  * If found, return value, else return NULL.  */
7451
7452 static struct value *
7453 ada_index_struct_field (int index, struct value *arg, int offset,
7454                         struct type *type)
7455 {
7456   return ada_index_struct_field_1 (&index, arg, offset, type);
7457 }
7458
7459
7460 /* Auxiliary function for ada_index_struct_field.  Like
7461  * ada_index_struct_field, but takes index from *INDEX_P and modifies
7462  * *INDEX_P.  */
7463
7464 static struct value *
7465 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7466                           struct type *type)
7467 {
7468   int i;
7469   type = ada_check_typedef (type);
7470
7471   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7472     {
7473       if (TYPE_FIELD_NAME (type, i) == NULL)
7474         continue;
7475       else if (ada_is_wrapper_field (type, i))
7476         {
7477           struct value *v =     /* Do not let indent join lines here.  */
7478             ada_index_struct_field_1 (index_p, arg,
7479                                       offset + TYPE_FIELD_BITPOS (type, i) / 8,
7480                                       TYPE_FIELD_TYPE (type, i));
7481
7482           if (v != NULL)
7483             return v;
7484         }
7485
7486       else if (ada_is_variant_part (type, i))
7487         {
7488           /* PNH: Do we ever get here?  See ada_search_struct_field,
7489              find_struct_field.  */
7490           error (_("Cannot assign this kind of variant record"));
7491         }
7492       else if (*index_p == 0)
7493         return ada_value_primitive_field (arg, offset, i, type);
7494       else
7495         *index_p -= 1;
7496     }
7497   return NULL;
7498 }
7499
7500 /* Return a string representation of type TYPE.  */
7501
7502 static std::string
7503 type_as_string (struct type *type)
7504 {
7505   string_file tmp_stream;
7506
7507   type_print (type, "", &tmp_stream, -1);
7508
7509   return std::move (tmp_stream.string ());
7510 }
7511
7512 /* Given a type TYPE, look up the type of the component of type named NAME.
7513    If DISPP is non-null, add its byte displacement from the beginning of a
7514    structure (pointed to by a value) of type TYPE to *DISPP (does not
7515    work for packed fields).
7516
7517    Matches any field whose name has NAME as a prefix, possibly
7518    followed by "___".
7519
7520    TYPE can be either a struct or union.  If REFOK, TYPE may also 
7521    be a (pointer or reference)+ to a struct or union, and the
7522    ultimate target type will be searched.
7523
7524    Looks recursively into variant clauses and parent types.
7525
7526    In the case of homonyms in the tagged types, please refer to the
7527    long explanation in find_struct_field's function documentation.
7528
7529    If NOERR is nonzero, return NULL if NAME is not suitably defined or
7530    TYPE is not a type of the right kind.  */
7531
7532 static struct type *
7533 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7534                             int noerr)
7535 {
7536   int i;
7537   int parent_offset = -1;
7538
7539   if (name == NULL)
7540     goto BadName;
7541
7542   if (refok && type != NULL)
7543     while (1)
7544       {
7545         type = ada_check_typedef (type);
7546         if (TYPE_CODE (type) != TYPE_CODE_PTR
7547             && TYPE_CODE (type) != TYPE_CODE_REF)
7548           break;
7549         type = TYPE_TARGET_TYPE (type);
7550       }
7551
7552   if (type == NULL
7553       || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7554           && TYPE_CODE (type) != TYPE_CODE_UNION))
7555     {
7556       if (noerr)
7557         return NULL;
7558
7559       error (_("Type %s is not a structure or union type"),
7560              type != NULL ? type_as_string (type).c_str () : _("(null)"));
7561     }
7562
7563   type = to_static_fixed_type (type);
7564
7565   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7566     {
7567       const char *t_field_name = TYPE_FIELD_NAME (type, i);
7568       struct type *t;
7569
7570       if (t_field_name == NULL)
7571         continue;
7572
7573       else if (ada_is_parent_field (type, i))
7574         {
7575           /* This is a field pointing us to the parent type of a tagged
7576              type.  As hinted in this function's documentation, we give
7577              preference to fields in the current record first, so what
7578              we do here is just record the index of this field before
7579              we skip it.  If it turns out we couldn't find our field
7580              in the current record, then we'll get back to it and search
7581              inside it whether the field might exist in the parent.  */
7582
7583           parent_offset = i;
7584           continue;
7585         }
7586
7587       else if (field_name_match (t_field_name, name))
7588         return TYPE_FIELD_TYPE (type, i);
7589
7590       else if (ada_is_wrapper_field (type, i))
7591         {
7592           t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7593                                           0, 1);
7594           if (t != NULL)
7595             return t;
7596         }
7597
7598       else if (ada_is_variant_part (type, i))
7599         {
7600           int j;
7601           struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7602                                                                         i));
7603
7604           for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7605             {
7606               /* FIXME pnh 2008/01/26: We check for a field that is
7607                  NOT wrapped in a struct, since the compiler sometimes
7608                  generates these for unchecked variant types.  Revisit
7609                  if the compiler changes this practice.  */
7610               const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
7611
7612               if (v_field_name != NULL 
7613                   && field_name_match (v_field_name, name))
7614                 t = TYPE_FIELD_TYPE (field_type, j);
7615               else
7616                 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7617                                                                  j),
7618                                                 name, 0, 1);
7619
7620               if (t != NULL)
7621                 return t;
7622             }
7623         }
7624
7625     }
7626
7627     /* Field not found so far.  If this is a tagged type which
7628        has a parent, try finding that field in the parent now.  */
7629
7630     if (parent_offset != -1)
7631       {
7632         struct type *t;
7633
7634         t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7635                                         name, 0, 1);
7636         if (t != NULL)
7637           return t;
7638       }
7639
7640 BadName:
7641   if (!noerr)
7642     {
7643       const char *name_str = name != NULL ? name : _("<null>");
7644
7645       error (_("Type %s has no component named %s"),
7646              type_as_string (type).c_str (), name_str);
7647     }
7648
7649   return NULL;
7650 }
7651
7652 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7653    within a value of type OUTER_TYPE, return true iff VAR_TYPE
7654    represents an unchecked union (that is, the variant part of a
7655    record that is named in an Unchecked_Union pragma).  */
7656
7657 static int
7658 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7659 {
7660   const char *discrim_name = ada_variant_discrim_name (var_type);
7661
7662   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7663 }
7664
7665
7666 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7667    within a value of type OUTER_TYPE that is stored in GDB at
7668    OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7669    numbering from 0) is applicable.  Returns -1 if none are.  */
7670
7671 int
7672 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
7673                            const gdb_byte *outer_valaddr)
7674 {
7675   int others_clause;
7676   int i;
7677   const char *discrim_name = ada_variant_discrim_name (var_type);
7678   struct value *outer;
7679   struct value *discrim;
7680   LONGEST discrim_val;
7681
7682   /* Using plain value_from_contents_and_address here causes problems
7683      because we will end up trying to resolve a type that is currently
7684      being constructed.  */
7685   outer = value_from_contents_and_address_unresolved (outer_type,
7686                                                       outer_valaddr, 0);
7687   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7688   if (discrim == NULL)
7689     return -1;
7690   discrim_val = value_as_long (discrim);
7691
7692   others_clause = -1;
7693   for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7694     {
7695       if (ada_is_others_clause (var_type, i))
7696         others_clause = i;
7697       else if (ada_in_variant (discrim_val, var_type, i))
7698         return i;
7699     }
7700
7701   return others_clause;
7702 }
7703 \f
7704
7705
7706                                 /* Dynamic-Sized Records */
7707
7708 /* Strategy: The type ostensibly attached to a value with dynamic size
7709    (i.e., a size that is not statically recorded in the debugging
7710    data) does not accurately reflect the size or layout of the value.
7711    Our strategy is to convert these values to values with accurate,
7712    conventional types that are constructed on the fly.  */
7713
7714 /* There is a subtle and tricky problem here.  In general, we cannot
7715    determine the size of dynamic records without its data.  However,
7716    the 'struct value' data structure, which GDB uses to represent
7717    quantities in the inferior process (the target), requires the size
7718    of the type at the time of its allocation in order to reserve space
7719    for GDB's internal copy of the data.  That's why the
7720    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7721    rather than struct value*s.
7722
7723    However, GDB's internal history variables ($1, $2, etc.) are
7724    struct value*s containing internal copies of the data that are not, in
7725    general, the same as the data at their corresponding addresses in
7726    the target.  Fortunately, the types we give to these values are all
7727    conventional, fixed-size types (as per the strategy described
7728    above), so that we don't usually have to perform the
7729    'to_fixed_xxx_type' conversions to look at their values.
7730    Unfortunately, there is one exception: if one of the internal
7731    history variables is an array whose elements are unconstrained
7732    records, then we will need to create distinct fixed types for each
7733    element selected.  */
7734
7735 /* The upshot of all of this is that many routines take a (type, host
7736    address, target address) triple as arguments to represent a value.
7737    The host address, if non-null, is supposed to contain an internal
7738    copy of the relevant data; otherwise, the program is to consult the
7739    target at the target address.  */
7740
7741 /* Assuming that VAL0 represents a pointer value, the result of
7742    dereferencing it.  Differs from value_ind in its treatment of
7743    dynamic-sized types.  */
7744
7745 struct value *
7746 ada_value_ind (struct value *val0)
7747 {
7748   struct value *val = value_ind (val0);
7749
7750   if (ada_is_tagged_type (value_type (val), 0))
7751     val = ada_tag_value_at_base_address (val);
7752
7753   return ada_to_fixed_value (val);
7754 }
7755
7756 /* The value resulting from dereferencing any "reference to"
7757    qualifiers on VAL0.  */
7758
7759 static struct value *
7760 ada_coerce_ref (struct value *val0)
7761 {
7762   if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
7763     {
7764       struct value *val = val0;
7765
7766       val = coerce_ref (val);
7767
7768       if (ada_is_tagged_type (value_type (val), 0))
7769         val = ada_tag_value_at_base_address (val);
7770
7771       return ada_to_fixed_value (val);
7772     }
7773   else
7774     return val0;
7775 }
7776
7777 /* Return OFF rounded upward if necessary to a multiple of
7778    ALIGNMENT (a power of 2).  */
7779
7780 static unsigned int
7781 align_value (unsigned int off, unsigned int alignment)
7782 {
7783   return (off + alignment - 1) & ~(alignment - 1);
7784 }
7785
7786 /* Return the bit alignment required for field #F of template type TYPE.  */
7787
7788 static unsigned int
7789 field_alignment (struct type *type, int f)
7790 {
7791   const char *name = TYPE_FIELD_NAME (type, f);
7792   int len;
7793   int align_offset;
7794
7795   /* The field name should never be null, unless the debugging information
7796      is somehow malformed.  In this case, we assume the field does not
7797      require any alignment.  */
7798   if (name == NULL)
7799     return 1;
7800
7801   len = strlen (name);
7802
7803   if (!isdigit (name[len - 1]))
7804     return 1;
7805
7806   if (isdigit (name[len - 2]))
7807     align_offset = len - 2;
7808   else
7809     align_offset = len - 1;
7810
7811   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7812     return TARGET_CHAR_BIT;
7813
7814   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7815 }
7816
7817 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7818
7819 static struct symbol *
7820 ada_find_any_type_symbol (const char *name)
7821 {
7822   struct symbol *sym;
7823
7824   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7825   if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7826     return sym;
7827
7828   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7829   return sym;
7830 }
7831
7832 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7833    solely for types defined by debug info, it will not search the GDB
7834    primitive types.  */
7835
7836 static struct type *
7837 ada_find_any_type (const char *name)
7838 {
7839   struct symbol *sym = ada_find_any_type_symbol (name);
7840
7841   if (sym != NULL)
7842     return SYMBOL_TYPE (sym);
7843
7844   return NULL;
7845 }
7846
7847 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7848    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
7849    symbol, in which case it is returned.  Otherwise, this looks for
7850    symbols whose name is that of NAME_SYM suffixed with  "___XR".
7851    Return symbol if found, and NULL otherwise.  */
7852
7853 static bool
7854 ada_is_renaming_symbol (struct symbol *name_sym)
7855 {
7856   const char *name = name_sym->linkage_name ();
7857   return strstr (name, "___XR") != NULL;
7858 }
7859
7860 /* Because of GNAT encoding conventions, several GDB symbols may match a
7861    given type name.  If the type denoted by TYPE0 is to be preferred to
7862    that of TYPE1 for purposes of type printing, return non-zero;
7863    otherwise return 0.  */
7864
7865 int
7866 ada_prefer_type (struct type *type0, struct type *type1)
7867 {
7868   if (type1 == NULL)
7869     return 1;
7870   else if (type0 == NULL)
7871     return 0;
7872   else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7873     return 1;
7874   else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7875     return 0;
7876   else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7877     return 1;
7878   else if (ada_is_constrained_packed_array_type (type0))
7879     return 1;
7880   else if (ada_is_array_descriptor_type (type0)
7881            && !ada_is_array_descriptor_type (type1))
7882     return 1;
7883   else
7884     {
7885       const char *type0_name = TYPE_NAME (type0);
7886       const char *type1_name = TYPE_NAME (type1);
7887
7888       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7889           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7890         return 1;
7891     }
7892   return 0;
7893 }
7894
7895 /* The name of TYPE, which is its TYPE_NAME.  Null if TYPE is
7896    null.  */
7897
7898 const char *
7899 ada_type_name (struct type *type)
7900 {
7901   if (type == NULL)
7902     return NULL;
7903   return TYPE_NAME (type);
7904 }
7905
7906 /* Search the list of "descriptive" types associated to TYPE for a type
7907    whose name is NAME.  */
7908
7909 static struct type *
7910 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7911 {
7912   struct type *result, *tmp;
7913
7914   if (ada_ignore_descriptive_types_p)
7915     return NULL;
7916
7917   /* If there no descriptive-type info, then there is no parallel type
7918      to be found.  */
7919   if (!HAVE_GNAT_AUX_INFO (type))
7920     return NULL;
7921
7922   result = TYPE_DESCRIPTIVE_TYPE (type);
7923   while (result != NULL)
7924     {
7925       const char *result_name = ada_type_name (result);
7926
7927       if (result_name == NULL)
7928         {
7929           warning (_("unexpected null name on descriptive type"));
7930           return NULL;
7931         }
7932
7933       /* If the names match, stop.  */
7934       if (strcmp (result_name, name) == 0)
7935         break;
7936
7937       /* Otherwise, look at the next item on the list, if any.  */
7938       if (HAVE_GNAT_AUX_INFO (result))
7939         tmp = TYPE_DESCRIPTIVE_TYPE (result);
7940       else
7941         tmp = NULL;
7942
7943       /* If not found either, try after having resolved the typedef.  */
7944       if (tmp != NULL)
7945         result = tmp;
7946       else
7947         {
7948           result = check_typedef (result);
7949           if (HAVE_GNAT_AUX_INFO (result))
7950             result = TYPE_DESCRIPTIVE_TYPE (result);
7951           else
7952             result = NULL;
7953         }
7954     }
7955
7956   /* If we didn't find a match, see whether this is a packed array.  With
7957      older compilers, the descriptive type information is either absent or
7958      irrelevant when it comes to packed arrays so the above lookup fails.
7959      Fall back to using a parallel lookup by name in this case.  */
7960   if (result == NULL && ada_is_constrained_packed_array_type (type))
7961     return ada_find_any_type (name);
7962
7963   return result;
7964 }
7965
7966 /* Find a parallel type to TYPE with the specified NAME, using the
7967    descriptive type taken from the debugging information, if available,
7968    and otherwise using the (slower) name-based method.  */
7969
7970 static struct type *
7971 ada_find_parallel_type_with_name (struct type *type, const char *name)
7972 {
7973   struct type *result = NULL;
7974
7975   if (HAVE_GNAT_AUX_INFO (type))
7976     result = find_parallel_type_by_descriptive_type (type, name);
7977   else
7978     result = ada_find_any_type (name);
7979
7980   return result;
7981 }
7982
7983 /* Same as above, but specify the name of the parallel type by appending
7984    SUFFIX to the name of TYPE.  */
7985
7986 struct type *
7987 ada_find_parallel_type (struct type *type, const char *suffix)
7988 {
7989   char *name;
7990   const char *type_name = ada_type_name (type);
7991   int len;
7992
7993   if (type_name == NULL)
7994     return NULL;
7995
7996   len = strlen (type_name);
7997
7998   name = (char *) alloca (len + strlen (suffix) + 1);
7999
8000   strcpy (name, type_name);
8001   strcpy (name + len, suffix);
8002
8003   return ada_find_parallel_type_with_name (type, name);
8004 }
8005
8006 /* If TYPE is a variable-size record type, return the corresponding template
8007    type describing its fields.  Otherwise, return NULL.  */
8008
8009 static struct type *
8010 dynamic_template_type (struct type *type)
8011 {
8012   type = ada_check_typedef (type);
8013
8014   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
8015       || ada_type_name (type) == NULL)
8016     return NULL;
8017   else
8018     {
8019       int len = strlen (ada_type_name (type));
8020
8021       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8022         return type;
8023       else
8024         return ada_find_parallel_type (type, "___XVE");
8025     }
8026 }
8027
8028 /* Assuming that TEMPL_TYPE is a union or struct type, returns
8029    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
8030
8031 static int
8032 is_dynamic_field (struct type *templ_type, int field_num)
8033 {
8034   const char *name = TYPE_FIELD_NAME (templ_type, field_num);
8035
8036   return name != NULL
8037     && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8038     && strstr (name, "___XVL") != NULL;
8039 }
8040
8041 /* The index of the variant field of TYPE, or -1 if TYPE does not
8042    represent a variant record type.  */
8043
8044 static int
8045 variant_field_index (struct type *type)
8046 {
8047   int f;
8048
8049   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8050     return -1;
8051
8052   for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8053     {
8054       if (ada_is_variant_part (type, f))
8055         return f;
8056     }
8057   return -1;
8058 }
8059
8060 /* A record type with no fields.  */
8061
8062 static struct type *
8063 empty_record (struct type *templ)
8064 {
8065   struct type *type = alloc_type_copy (templ);
8066
8067   TYPE_CODE (type) = TYPE_CODE_STRUCT;
8068   TYPE_NFIELDS (type) = 0;
8069   TYPE_FIELDS (type) = NULL;
8070   INIT_NONE_SPECIFIC (type);
8071   TYPE_NAME (type) = "<empty>";
8072   TYPE_LENGTH (type) = 0;
8073   return type;
8074 }
8075
8076 /* An ordinary record type (with fixed-length fields) that describes
8077    the value of type TYPE at VALADDR or ADDRESS (see comments at
8078    the beginning of this section) VAL according to GNAT conventions.
8079    DVAL0 should describe the (portion of a) record that contains any
8080    necessary discriminants.  It should be NULL if value_type (VAL) is
8081    an outer-level type (i.e., as opposed to a branch of a variant.)  A
8082    variant field (unless unchecked) is replaced by a particular branch
8083    of the variant.
8084
8085    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8086    length are not statically known are discarded.  As a consequence,
8087    VALADDR, ADDRESS and DVAL0 are ignored.
8088
8089    NOTE: Limitations: For now, we assume that dynamic fields and
8090    variants occupy whole numbers of bytes.  However, they need not be
8091    byte-aligned.  */
8092
8093 struct type *
8094 ada_template_to_fixed_record_type_1 (struct type *type,
8095                                      const gdb_byte *valaddr,
8096                                      CORE_ADDR address, struct value *dval0,
8097                                      int keep_dynamic_fields)
8098 {
8099   struct value *mark = value_mark ();
8100   struct value *dval;
8101   struct type *rtype;
8102   int nfields, bit_len;
8103   int variant_field;
8104   long off;
8105   int fld_bit_len;
8106   int f;
8107
8108   /* Compute the number of fields in this record type that are going
8109      to be processed: unless keep_dynamic_fields, this includes only
8110      fields whose position and length are static will be processed.  */
8111   if (keep_dynamic_fields)
8112     nfields = TYPE_NFIELDS (type);
8113   else
8114     {
8115       nfields = 0;
8116       while (nfields < TYPE_NFIELDS (type)
8117              && !ada_is_variant_part (type, nfields)
8118              && !is_dynamic_field (type, nfields))
8119         nfields++;
8120     }
8121
8122   rtype = alloc_type_copy (type);
8123   TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8124   INIT_NONE_SPECIFIC (rtype);
8125   TYPE_NFIELDS (rtype) = nfields;
8126   TYPE_FIELDS (rtype) = (struct field *)
8127     TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8128   memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8129   TYPE_NAME (rtype) = ada_type_name (type);
8130   TYPE_FIXED_INSTANCE (rtype) = 1;
8131
8132   off = 0;
8133   bit_len = 0;
8134   variant_field = -1;
8135
8136   for (f = 0; f < nfields; f += 1)
8137     {
8138       off = align_value (off, field_alignment (type, f))
8139         + TYPE_FIELD_BITPOS (type, f);
8140       SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
8141       TYPE_FIELD_BITSIZE (rtype, f) = 0;
8142
8143       if (ada_is_variant_part (type, f))
8144         {
8145           variant_field = f;
8146           fld_bit_len = 0;
8147         }
8148       else if (is_dynamic_field (type, f))
8149         {
8150           const gdb_byte *field_valaddr = valaddr;
8151           CORE_ADDR field_address = address;
8152           struct type *field_type =
8153             TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8154
8155           if (dval0 == NULL)
8156             {
8157               /* rtype's length is computed based on the run-time
8158                  value of discriminants.  If the discriminants are not
8159                  initialized, the type size may be completely bogus and
8160                  GDB may fail to allocate a value for it.  So check the
8161                  size first before creating the value.  */
8162               ada_ensure_varsize_limit (rtype);
8163               /* Using plain value_from_contents_and_address here
8164                  causes problems because we will end up trying to
8165                  resolve a type that is currently being
8166                  constructed.  */
8167               dval = value_from_contents_and_address_unresolved (rtype,
8168                                                                  valaddr,
8169                                                                  address);
8170               rtype = value_type (dval);
8171             }
8172           else
8173             dval = dval0;
8174
8175           /* If the type referenced by this field is an aligner type, we need
8176              to unwrap that aligner type, because its size might not be set.
8177              Keeping the aligner type would cause us to compute the wrong
8178              size for this field, impacting the offset of the all the fields
8179              that follow this one.  */
8180           if (ada_is_aligner_type (field_type))
8181             {
8182               long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8183
8184               field_valaddr = cond_offset_host (field_valaddr, field_offset);
8185               field_address = cond_offset_target (field_address, field_offset);
8186               field_type = ada_aligned_type (field_type);
8187             }
8188
8189           field_valaddr = cond_offset_host (field_valaddr,
8190                                             off / TARGET_CHAR_BIT);
8191           field_address = cond_offset_target (field_address,
8192                                               off / TARGET_CHAR_BIT);
8193
8194           /* Get the fixed type of the field.  Note that, in this case,
8195              we do not want to get the real type out of the tag: if
8196              the current field is the parent part of a tagged record,
8197              we will get the tag of the object.  Clearly wrong: the real
8198              type of the parent is not the real type of the child.  We
8199              would end up in an infinite loop.  */
8200           field_type = ada_get_base_type (field_type);
8201           field_type = ada_to_fixed_type (field_type, field_valaddr,
8202                                           field_address, dval, 0);
8203           /* If the field size is already larger than the maximum
8204              object size, then the record itself will necessarily
8205              be larger than the maximum object size.  We need to make
8206              this check now, because the size might be so ridiculously
8207              large (due to an uninitialized variable in the inferior)
8208              that it would cause an overflow when adding it to the
8209              record size.  */
8210           ada_ensure_varsize_limit (field_type);
8211
8212           TYPE_FIELD_TYPE (rtype, f) = field_type;
8213           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8214           /* The multiplication can potentially overflow.  But because
8215              the field length has been size-checked just above, and
8216              assuming that the maximum size is a reasonable value,
8217              an overflow should not happen in practice.  So rather than
8218              adding overflow recovery code to this already complex code,
8219              we just assume that it's not going to happen.  */
8220           fld_bit_len =
8221             TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8222         }
8223       else
8224         {
8225           /* Note: If this field's type is a typedef, it is important
8226              to preserve the typedef layer.
8227
8228              Otherwise, we might be transforming a typedef to a fat
8229              pointer (encoding a pointer to an unconstrained array),
8230              into a basic fat pointer (encoding an unconstrained
8231              array).  As both types are implemented using the same
8232              structure, the typedef is the only clue which allows us
8233              to distinguish between the two options.  Stripping it
8234              would prevent us from printing this field appropriately.  */
8235           TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
8236           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8237           if (TYPE_FIELD_BITSIZE (type, f) > 0)
8238             fld_bit_len =
8239               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8240           else
8241             {
8242               struct type *field_type = TYPE_FIELD_TYPE (type, f);
8243
8244               /* We need to be careful of typedefs when computing
8245                  the length of our field.  If this is a typedef,
8246                  get the length of the target type, not the length
8247                  of the typedef.  */
8248               if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8249                 field_type = ada_typedef_target_type (field_type);
8250
8251               fld_bit_len =
8252                 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8253             }
8254         }
8255       if (off + fld_bit_len > bit_len)
8256         bit_len = off + fld_bit_len;
8257       off += fld_bit_len;
8258       TYPE_LENGTH (rtype) =
8259         align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8260     }
8261
8262   /* We handle the variant part, if any, at the end because of certain
8263      odd cases in which it is re-ordered so as NOT to be the last field of
8264      the record.  This can happen in the presence of representation
8265      clauses.  */
8266   if (variant_field >= 0)
8267     {
8268       struct type *branch_type;
8269
8270       off = TYPE_FIELD_BITPOS (rtype, variant_field);
8271
8272       if (dval0 == NULL)
8273         {
8274           /* Using plain value_from_contents_and_address here causes
8275              problems because we will end up trying to resolve a type
8276              that is currently being constructed.  */
8277           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8278                                                              address);
8279           rtype = value_type (dval);
8280         }
8281       else
8282         dval = dval0;
8283
8284       branch_type =
8285         to_fixed_variant_branch_type
8286         (TYPE_FIELD_TYPE (type, variant_field),
8287          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8288          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8289       if (branch_type == NULL)
8290         {
8291           for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8292             TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8293           TYPE_NFIELDS (rtype) -= 1;
8294         }
8295       else
8296         {
8297           TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8298           TYPE_FIELD_NAME (rtype, variant_field) = "S";
8299           fld_bit_len =
8300             TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8301             TARGET_CHAR_BIT;
8302           if (off + fld_bit_len > bit_len)
8303             bit_len = off + fld_bit_len;
8304           TYPE_LENGTH (rtype) =
8305             align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8306         }
8307     }
8308
8309   /* According to exp_dbug.ads, the size of TYPE for variable-size records
8310      should contain the alignment of that record, which should be a strictly
8311      positive value.  If null or negative, then something is wrong, most
8312      probably in the debug info.  In that case, we don't round up the size
8313      of the resulting type.  If this record is not part of another structure,
8314      the current RTYPE length might be good enough for our purposes.  */
8315   if (TYPE_LENGTH (type) <= 0)
8316     {
8317       if (TYPE_NAME (rtype))
8318         warning (_("Invalid type size for `%s' detected: %s."),
8319                  TYPE_NAME (rtype), pulongest (TYPE_LENGTH (type)));
8320       else
8321         warning (_("Invalid type size for <unnamed> detected: %s."),
8322                  pulongest (TYPE_LENGTH (type)));
8323     }
8324   else
8325     {
8326       TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8327                                          TYPE_LENGTH (type));
8328     }
8329
8330   value_free_to_mark (mark);
8331   if (TYPE_LENGTH (rtype) > varsize_limit)
8332     error (_("record type with dynamic size is larger than varsize-limit"));
8333   return rtype;
8334 }
8335
8336 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8337    of 1.  */
8338
8339 static struct type *
8340 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8341                                CORE_ADDR address, struct value *dval0)
8342 {
8343   return ada_template_to_fixed_record_type_1 (type, valaddr,
8344                                               address, dval0, 1);
8345 }
8346
8347 /* An ordinary record type in which ___XVL-convention fields and
8348    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8349    static approximations, containing all possible fields.  Uses
8350    no runtime values.  Useless for use in values, but that's OK,
8351    since the results are used only for type determinations.   Works on both
8352    structs and unions.  Representation note: to save space, we memorize
8353    the result of this function in the TYPE_TARGET_TYPE of the
8354    template type.  */
8355
8356 static struct type *
8357 template_to_static_fixed_type (struct type *type0)
8358 {
8359   struct type *type;
8360   int nfields;
8361   int f;
8362
8363   /* No need no do anything if the input type is already fixed.  */
8364   if (TYPE_FIXED_INSTANCE (type0))
8365     return type0;
8366
8367   /* Likewise if we already have computed the static approximation.  */
8368   if (TYPE_TARGET_TYPE (type0) != NULL)
8369     return TYPE_TARGET_TYPE (type0);
8370
8371   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
8372   type = type0;
8373   nfields = TYPE_NFIELDS (type0);
8374
8375   /* Whether or not we cloned TYPE0, cache the result so that we don't do
8376      recompute all over next time.  */
8377   TYPE_TARGET_TYPE (type0) = type;
8378
8379   for (f = 0; f < nfields; f += 1)
8380     {
8381       struct type *field_type = TYPE_FIELD_TYPE (type0, f);
8382       struct type *new_type;
8383
8384       if (is_dynamic_field (type0, f))
8385         {
8386           field_type = ada_check_typedef (field_type);
8387           new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8388         }
8389       else
8390         new_type = static_unwrap_type (field_type);
8391
8392       if (new_type != field_type)
8393         {
8394           /* Clone TYPE0 only the first time we get a new field type.  */
8395           if (type == type0)
8396             {
8397               TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8398               TYPE_CODE (type) = TYPE_CODE (type0);
8399               INIT_NONE_SPECIFIC (type);
8400               TYPE_NFIELDS (type) = nfields;
8401               TYPE_FIELDS (type) = (struct field *)
8402                 TYPE_ALLOC (type, nfields * sizeof (struct field));
8403               memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8404                       sizeof (struct field) * nfields);
8405               TYPE_NAME (type) = ada_type_name (type0);
8406               TYPE_FIXED_INSTANCE (type) = 1;
8407               TYPE_LENGTH (type) = 0;
8408             }
8409           TYPE_FIELD_TYPE (type, f) = new_type;
8410           TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8411         }
8412     }
8413
8414   return type;
8415 }
8416
8417 /* Given an object of type TYPE whose contents are at VALADDR and
8418    whose address in memory is ADDRESS, returns a revision of TYPE,
8419    which should be a non-dynamic-sized record, in which the variant
8420    part, if any, is replaced with the appropriate branch.  Looks
8421    for discriminant values in DVAL0, which can be NULL if the record
8422    contains the necessary discriminant values.  */
8423
8424 static struct type *
8425 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8426                                    CORE_ADDR address, struct value *dval0)
8427 {
8428   struct value *mark = value_mark ();
8429   struct value *dval;
8430   struct type *rtype;
8431   struct type *branch_type;
8432   int nfields = TYPE_NFIELDS (type);
8433   int variant_field = variant_field_index (type);
8434
8435   if (variant_field == -1)
8436     return type;
8437
8438   if (dval0 == NULL)
8439     {
8440       dval = value_from_contents_and_address (type, valaddr, address);
8441       type = value_type (dval);
8442     }
8443   else
8444     dval = dval0;
8445
8446   rtype = alloc_type_copy (type);
8447   TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8448   INIT_NONE_SPECIFIC (rtype);
8449   TYPE_NFIELDS (rtype) = nfields;
8450   TYPE_FIELDS (rtype) =
8451     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8452   memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
8453           sizeof (struct field) * nfields);
8454   TYPE_NAME (rtype) = ada_type_name (type);
8455   TYPE_FIXED_INSTANCE (rtype) = 1;
8456   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8457
8458   branch_type = to_fixed_variant_branch_type
8459     (TYPE_FIELD_TYPE (type, variant_field),
8460      cond_offset_host (valaddr,
8461                        TYPE_FIELD_BITPOS (type, variant_field)
8462                        / TARGET_CHAR_BIT),
8463      cond_offset_target (address,
8464                          TYPE_FIELD_BITPOS (type, variant_field)
8465                          / TARGET_CHAR_BIT), dval);
8466   if (branch_type == NULL)
8467     {
8468       int f;
8469
8470       for (f = variant_field + 1; f < nfields; f += 1)
8471         TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8472       TYPE_NFIELDS (rtype) -= 1;
8473     }
8474   else
8475     {
8476       TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8477       TYPE_FIELD_NAME (rtype, variant_field) = "S";
8478       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8479       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8480     }
8481   TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
8482
8483   value_free_to_mark (mark);
8484   return rtype;
8485 }
8486
8487 /* An ordinary record type (with fixed-length fields) that describes
8488    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8489    beginning of this section].   Any necessary discriminants' values
8490    should be in DVAL, a record value; it may be NULL if the object
8491    at ADDR itself contains any necessary discriminant values.
8492    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8493    values from the record are needed.  Except in the case that DVAL,
8494    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8495    unchecked) is replaced by a particular branch of the variant.
8496
8497    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8498    is questionable and may be removed.  It can arise during the
8499    processing of an unconstrained-array-of-record type where all the
8500    variant branches have exactly the same size.  This is because in
8501    such cases, the compiler does not bother to use the XVS convention
8502    when encoding the record.  I am currently dubious of this
8503    shortcut and suspect the compiler should be altered.  FIXME.  */
8504
8505 static struct type *
8506 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8507                       CORE_ADDR address, struct value *dval)
8508 {
8509   struct type *templ_type;
8510
8511   if (TYPE_FIXED_INSTANCE (type0))
8512     return type0;
8513
8514   templ_type = dynamic_template_type (type0);
8515
8516   if (templ_type != NULL)
8517     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8518   else if (variant_field_index (type0) >= 0)
8519     {
8520       if (dval == NULL && valaddr == NULL && address == 0)
8521         return type0;
8522       return to_record_with_fixed_variant_part (type0, valaddr, address,
8523                                                 dval);
8524     }
8525   else
8526     {
8527       TYPE_FIXED_INSTANCE (type0) = 1;
8528       return type0;
8529     }
8530
8531 }
8532
8533 /* An ordinary record type (with fixed-length fields) that describes
8534    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8535    union type.  Any necessary discriminants' values should be in DVAL,
8536    a record value.  That is, this routine selects the appropriate
8537    branch of the union at ADDR according to the discriminant value
8538    indicated in the union's type name.  Returns VAR_TYPE0 itself if
8539    it represents a variant subject to a pragma Unchecked_Union.  */
8540
8541 static struct type *
8542 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8543                               CORE_ADDR address, struct value *dval)
8544 {
8545   int which;
8546   struct type *templ_type;
8547   struct type *var_type;
8548
8549   if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8550     var_type = TYPE_TARGET_TYPE (var_type0);
8551   else
8552     var_type = var_type0;
8553
8554   templ_type = ada_find_parallel_type (var_type, "___XVU");
8555
8556   if (templ_type != NULL)
8557     var_type = templ_type;
8558
8559   if (is_unchecked_variant (var_type, value_type (dval)))
8560       return var_type0;
8561   which =
8562     ada_which_variant_applies (var_type,
8563                                value_type (dval), value_contents (dval));
8564
8565   if (which < 0)
8566     return empty_record (var_type);
8567   else if (is_dynamic_field (var_type, which))
8568     return to_fixed_record_type
8569       (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8570        valaddr, address, dval);
8571   else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
8572     return
8573       to_fixed_record_type
8574       (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
8575   else
8576     return TYPE_FIELD_TYPE (var_type, which);
8577 }
8578
8579 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8580    ENCODING_TYPE, a type following the GNAT conventions for discrete
8581    type encodings, only carries redundant information.  */
8582
8583 static int
8584 ada_is_redundant_range_encoding (struct type *range_type,
8585                                  struct type *encoding_type)
8586 {
8587   const char *bounds_str;
8588   int n;
8589   LONGEST lo, hi;
8590
8591   gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8592
8593   if (TYPE_CODE (get_base_type (range_type))
8594       != TYPE_CODE (get_base_type (encoding_type)))
8595     {
8596       /* The compiler probably used a simple base type to describe
8597          the range type instead of the range's actual base type,
8598          expecting us to get the real base type from the encoding
8599          anyway.  In this situation, the encoding cannot be ignored
8600          as redundant.  */
8601       return 0;
8602     }
8603
8604   if (is_dynamic_type (range_type))
8605     return 0;
8606
8607   if (TYPE_NAME (encoding_type) == NULL)
8608     return 0;
8609
8610   bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8611   if (bounds_str == NULL)
8612     return 0;
8613
8614   n = 8; /* Skip "___XDLU_".  */
8615   if (!ada_scan_number (bounds_str, n, &lo, &n))
8616     return 0;
8617   if (TYPE_LOW_BOUND (range_type) != lo)
8618     return 0;
8619
8620   n += 2; /* Skip the "__" separator between the two bounds.  */
8621   if (!ada_scan_number (bounds_str, n, &hi, &n))
8622     return 0;
8623   if (TYPE_HIGH_BOUND (range_type) != hi)
8624     return 0;
8625
8626   return 1;
8627 }
8628
8629 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8630    a type following the GNAT encoding for describing array type
8631    indices, only carries redundant information.  */
8632
8633 static int
8634 ada_is_redundant_index_type_desc (struct type *array_type,
8635                                   struct type *desc_type)
8636 {
8637   struct type *this_layer = check_typedef (array_type);
8638   int i;
8639
8640   for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8641     {
8642       if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8643                                             TYPE_FIELD_TYPE (desc_type, i)))
8644         return 0;
8645       this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8646     }
8647
8648   return 1;
8649 }
8650
8651 /* Assuming that TYPE0 is an array type describing the type of a value
8652    at ADDR, and that DVAL describes a record containing any
8653    discriminants used in TYPE0, returns a type for the value that
8654    contains no dynamic components (that is, no components whose sizes
8655    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
8656    true, gives an error message if the resulting type's size is over
8657    varsize_limit.  */
8658
8659 static struct type *
8660 to_fixed_array_type (struct type *type0, struct value *dval,
8661                      int ignore_too_big)
8662 {
8663   struct type *index_type_desc;
8664   struct type *result;
8665   int constrained_packed_array_p;
8666   static const char *xa_suffix = "___XA";
8667
8668   type0 = ada_check_typedef (type0);
8669   if (TYPE_FIXED_INSTANCE (type0))
8670     return type0;
8671
8672   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8673   if (constrained_packed_array_p)
8674     type0 = decode_constrained_packed_array_type (type0);
8675
8676   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8677
8678   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8679      encoding suffixed with 'P' may still be generated.  If so,
8680      it should be used to find the XA type.  */
8681
8682   if (index_type_desc == NULL)
8683     {
8684       const char *type_name = ada_type_name (type0);
8685
8686       if (type_name != NULL)
8687         {
8688           const int len = strlen (type_name);
8689           char *name = (char *) alloca (len + strlen (xa_suffix));
8690
8691           if (type_name[len - 1] == 'P')
8692             {
8693               strcpy (name, type_name);
8694               strcpy (name + len - 1, xa_suffix);
8695               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8696             }
8697         }
8698     }
8699
8700   ada_fixup_array_indexes_type (index_type_desc);
8701   if (index_type_desc != NULL
8702       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8703     {
8704       /* Ignore this ___XA parallel type, as it does not bring any
8705          useful information.  This allows us to avoid creating fixed
8706          versions of the array's index types, which would be identical
8707          to the original ones.  This, in turn, can also help avoid
8708          the creation of fixed versions of the array itself.  */
8709       index_type_desc = NULL;
8710     }
8711
8712   if (index_type_desc == NULL)
8713     {
8714       struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8715
8716       /* NOTE: elt_type---the fixed version of elt_type0---should never
8717          depend on the contents of the array in properly constructed
8718          debugging data.  */
8719       /* Create a fixed version of the array element type.
8720          We're not providing the address of an element here,
8721          and thus the actual object value cannot be inspected to do
8722          the conversion.  This should not be a problem, since arrays of
8723          unconstrained objects are not allowed.  In particular, all
8724          the elements of an array of a tagged type should all be of
8725          the same type specified in the debugging info.  No need to
8726          consult the object tag.  */
8727       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8728
8729       /* Make sure we always create a new array type when dealing with
8730          packed array types, since we're going to fix-up the array
8731          type length and element bitsize a little further down.  */
8732       if (elt_type0 == elt_type && !constrained_packed_array_p)
8733         result = type0;
8734       else
8735         result = create_array_type (alloc_type_copy (type0),
8736                                     elt_type, TYPE_INDEX_TYPE (type0));
8737     }
8738   else
8739     {
8740       int i;
8741       struct type *elt_type0;
8742
8743       elt_type0 = type0;
8744       for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
8745         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8746
8747       /* NOTE: result---the fixed version of elt_type0---should never
8748          depend on the contents of the array in properly constructed
8749          debugging data.  */
8750       /* Create a fixed version of the array element type.
8751          We're not providing the address of an element here,
8752          and thus the actual object value cannot be inspected to do
8753          the conversion.  This should not be a problem, since arrays of
8754          unconstrained objects are not allowed.  In particular, all
8755          the elements of an array of a tagged type should all be of
8756          the same type specified in the debugging info.  No need to
8757          consult the object tag.  */
8758       result =
8759         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8760
8761       elt_type0 = type0;
8762       for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
8763         {
8764           struct type *range_type =
8765             to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
8766
8767           result = create_array_type (alloc_type_copy (elt_type0),
8768                                       result, range_type);
8769           elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8770         }
8771       if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
8772         error (_("array type with dynamic size is larger than varsize-limit"));
8773     }
8774
8775   /* We want to preserve the type name.  This can be useful when
8776      trying to get the type name of a value that has already been
8777      printed (for instance, if the user did "print VAR; whatis $".  */
8778   TYPE_NAME (result) = TYPE_NAME (type0);
8779
8780   if (constrained_packed_array_p)
8781     {
8782       /* So far, the resulting type has been created as if the original
8783          type was a regular (non-packed) array type.  As a result, the
8784          bitsize of the array elements needs to be set again, and the array
8785          length needs to be recomputed based on that bitsize.  */
8786       int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8787       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8788
8789       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8790       TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8791       if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8792         TYPE_LENGTH (result)++;
8793     }
8794
8795   TYPE_FIXED_INSTANCE (result) = 1;
8796   return result;
8797 }
8798
8799
8800 /* A standard type (containing no dynamically sized components)
8801    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8802    DVAL describes a record containing any discriminants used in TYPE0,
8803    and may be NULL if there are none, or if the object of type TYPE at
8804    ADDRESS or in VALADDR contains these discriminants.
8805    
8806    If CHECK_TAG is not null, in the case of tagged types, this function
8807    attempts to locate the object's tag and use it to compute the actual
8808    type.  However, when ADDRESS is null, we cannot use it to determine the
8809    location of the tag, and therefore compute the tagged type's actual type.
8810    So we return the tagged type without consulting the tag.  */
8811    
8812 static struct type *
8813 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8814                    CORE_ADDR address, struct value *dval, int check_tag)
8815 {
8816   type = ada_check_typedef (type);
8817
8818   /* Only un-fixed types need to be handled here.  */
8819   if (!HAVE_GNAT_AUX_INFO (type))
8820     return type;
8821
8822   switch (TYPE_CODE (type))
8823     {
8824     default:
8825       return type;
8826     case TYPE_CODE_STRUCT:
8827       {
8828         struct type *static_type = to_static_fixed_type (type);
8829         struct type *fixed_record_type =
8830           to_fixed_record_type (type, valaddr, address, NULL);
8831
8832         /* If STATIC_TYPE is a tagged type and we know the object's address,
8833            then we can determine its tag, and compute the object's actual
8834            type from there.  Note that we have to use the fixed record
8835            type (the parent part of the record may have dynamic fields
8836            and the way the location of _tag is expressed may depend on
8837            them).  */
8838
8839         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8840           {
8841             struct value *tag =
8842               value_tag_from_contents_and_address
8843               (fixed_record_type,
8844                valaddr,
8845                address);
8846             struct type *real_type = type_from_tag (tag);
8847             struct value *obj =
8848               value_from_contents_and_address (fixed_record_type,
8849                                                valaddr,
8850                                                address);
8851             fixed_record_type = value_type (obj);
8852             if (real_type != NULL)
8853               return to_fixed_record_type
8854                 (real_type, NULL,
8855                  value_address (ada_tag_value_at_base_address (obj)), NULL);
8856           }
8857
8858         /* Check to see if there is a parallel ___XVZ variable.
8859            If there is, then it provides the actual size of our type.  */
8860         else if (ada_type_name (fixed_record_type) != NULL)
8861           {
8862             const char *name = ada_type_name (fixed_record_type);
8863             char *xvz_name
8864               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8865             bool xvz_found = false;
8866             LONGEST size;
8867
8868             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8869             try
8870               {
8871                 xvz_found = get_int_var_value (xvz_name, size);
8872               }
8873             catch (const gdb_exception_error &except)
8874               {
8875                 /* We found the variable, but somehow failed to read
8876                    its value.  Rethrow the same error, but with a little
8877                    bit more information, to help the user understand
8878                    what went wrong (Eg: the variable might have been
8879                    optimized out).  */
8880                 throw_error (except.error,
8881                              _("unable to read value of %s (%s)"),
8882                              xvz_name, except.what ());
8883               }
8884
8885             if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8886               {
8887                 fixed_record_type = copy_type (fixed_record_type);
8888                 TYPE_LENGTH (fixed_record_type) = size;
8889
8890                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
8891                    observed this when the debugging info is STABS, and
8892                    apparently it is something that is hard to fix.
8893
8894                    In practice, we don't need the actual type definition
8895                    at all, because the presence of the XVZ variable allows us
8896                    to assume that there must be a XVS type as well, which we
8897                    should be able to use later, when we need the actual type
8898                    definition.
8899
8900                    In the meantime, pretend that the "fixed" type we are
8901                    returning is NOT a stub, because this can cause trouble
8902                    when using this type to create new types targeting it.
8903                    Indeed, the associated creation routines often check
8904                    whether the target type is a stub and will try to replace
8905                    it, thus using a type with the wrong size.  This, in turn,
8906                    might cause the new type to have the wrong size too.
8907                    Consider the case of an array, for instance, where the size
8908                    of the array is computed from the number of elements in
8909                    our array multiplied by the size of its element.  */
8910                 TYPE_STUB (fixed_record_type) = 0;
8911               }
8912           }
8913         return fixed_record_type;
8914       }
8915     case TYPE_CODE_ARRAY:
8916       return to_fixed_array_type (type, dval, 1);
8917     case TYPE_CODE_UNION:
8918       if (dval == NULL)
8919         return type;
8920       else
8921         return to_fixed_variant_branch_type (type, valaddr, address, dval);
8922     }
8923 }
8924
8925 /* The same as ada_to_fixed_type_1, except that it preserves the type
8926    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8927
8928    The typedef layer needs be preserved in order to differentiate between
8929    arrays and array pointers when both types are implemented using the same
8930    fat pointer.  In the array pointer case, the pointer is encoded as
8931    a typedef of the pointer type.  For instance, considering:
8932
8933           type String_Access is access String;
8934           S1 : String_Access := null;
8935
8936    To the debugger, S1 is defined as a typedef of type String.  But
8937    to the user, it is a pointer.  So if the user tries to print S1,
8938    we should not dereference the array, but print the array address
8939    instead.
8940
8941    If we didn't preserve the typedef layer, we would lose the fact that
8942    the type is to be presented as a pointer (needs de-reference before
8943    being printed).  And we would also use the source-level type name.  */
8944
8945 struct type *
8946 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8947                    CORE_ADDR address, struct value *dval, int check_tag)
8948
8949 {
8950   struct type *fixed_type =
8951     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8952
8953   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8954       then preserve the typedef layer.
8955
8956       Implementation note: We can only check the main-type portion of
8957       the TYPE and FIXED_TYPE, because eliminating the typedef layer
8958       from TYPE now returns a type that has the same instance flags
8959       as TYPE.  For instance, if TYPE is a "typedef const", and its
8960       target type is a "struct", then the typedef elimination will return
8961       a "const" version of the target type.  See check_typedef for more
8962       details about how the typedef layer elimination is done.
8963
8964       brobecker/2010-11-19: It seems to me that the only case where it is
8965       useful to preserve the typedef layer is when dealing with fat pointers.
8966       Perhaps, we could add a check for that and preserve the typedef layer
8967       only in that situation.  But this seems unnecessary so far, probably
8968       because we call check_typedef/ada_check_typedef pretty much everywhere.
8969       */
8970   if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8971       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8972           == TYPE_MAIN_TYPE (fixed_type)))
8973     return type;
8974
8975   return fixed_type;
8976 }
8977
8978 /* A standard (static-sized) type corresponding as well as possible to
8979    TYPE0, but based on no runtime data.  */
8980
8981 static struct type *
8982 to_static_fixed_type (struct type *type0)
8983 {
8984   struct type *type;
8985
8986   if (type0 == NULL)
8987     return NULL;
8988
8989   if (TYPE_FIXED_INSTANCE (type0))
8990     return type0;
8991
8992   type0 = ada_check_typedef (type0);
8993
8994   switch (TYPE_CODE (type0))
8995     {
8996     default:
8997       return type0;
8998     case TYPE_CODE_STRUCT:
8999       type = dynamic_template_type (type0);
9000       if (type != NULL)
9001         return template_to_static_fixed_type (type);
9002       else
9003         return template_to_static_fixed_type (type0);
9004     case TYPE_CODE_UNION:
9005       type = ada_find_parallel_type (type0, "___XVU");
9006       if (type != NULL)
9007         return template_to_static_fixed_type (type);
9008       else
9009         return template_to_static_fixed_type (type0);
9010     }
9011 }
9012
9013 /* A static approximation of TYPE with all type wrappers removed.  */
9014
9015 static struct type *
9016 static_unwrap_type (struct type *type)
9017 {
9018   if (ada_is_aligner_type (type))
9019     {
9020       struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
9021       if (ada_type_name (type1) == NULL)
9022         TYPE_NAME (type1) = ada_type_name (type);
9023
9024       return static_unwrap_type (type1);
9025     }
9026   else
9027     {
9028       struct type *raw_real_type = ada_get_base_type (type);
9029
9030       if (raw_real_type == type)
9031         return type;
9032       else
9033         return to_static_fixed_type (raw_real_type);
9034     }
9035 }
9036
9037 /* In some cases, incomplete and private types require
9038    cross-references that are not resolved as records (for example,
9039       type Foo;
9040       type FooP is access Foo;
9041       V: FooP;
9042       type Foo is array ...;
9043    ).  In these cases, since there is no mechanism for producing
9044    cross-references to such types, we instead substitute for FooP a
9045    stub enumeration type that is nowhere resolved, and whose tag is
9046    the name of the actual type.  Call these types "non-record stubs".  */
9047
9048 /* A type equivalent to TYPE that is not a non-record stub, if one
9049    exists, otherwise TYPE.  */
9050
9051 struct type *
9052 ada_check_typedef (struct type *type)
9053 {
9054   if (type == NULL)
9055     return NULL;
9056
9057   /* If our type is an access to an unconstrained array, which is encoded
9058      as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
9059      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9060      what allows us to distinguish between fat pointers that represent
9061      array types, and fat pointers that represent array access types
9062      (in both cases, the compiler implements them as fat pointers).  */
9063   if (ada_is_access_to_unconstrained_array (type))
9064     return type;
9065
9066   type = check_typedef (type);
9067   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
9068       || !TYPE_STUB (type)
9069       || TYPE_NAME (type) == NULL)
9070     return type;
9071   else
9072     {
9073       const char *name = TYPE_NAME (type);
9074       struct type *type1 = ada_find_any_type (name);
9075
9076       if (type1 == NULL)
9077         return type;
9078
9079       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9080          stubs pointing to arrays, as we don't create symbols for array
9081          types, only for the typedef-to-array types).  If that's the case,
9082          strip the typedef layer.  */
9083       if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9084         type1 = ada_check_typedef (type1);
9085
9086       return type1;
9087     }
9088 }
9089
9090 /* A value representing the data at VALADDR/ADDRESS as described by
9091    type TYPE0, but with a standard (static-sized) type that correctly
9092    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
9093    type, then return VAL0 [this feature is simply to avoid redundant
9094    creation of struct values].  */
9095
9096 static struct value *
9097 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9098                            struct value *val0)
9099 {
9100   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
9101
9102   if (type == type0 && val0 != NULL)
9103     return val0;
9104
9105   if (VALUE_LVAL (val0) != lval_memory)
9106     {
9107       /* Our value does not live in memory; it could be a convenience
9108          variable, for instance.  Create a not_lval value using val0's
9109          contents.  */
9110       return value_from_contents (type, value_contents (val0));
9111     }
9112
9113   return value_from_contents_and_address (type, 0, address);
9114 }
9115
9116 /* A value representing VAL, but with a standard (static-sized) type
9117    that correctly describes it.  Does not necessarily create a new
9118    value.  */
9119
9120 struct value *
9121 ada_to_fixed_value (struct value *val)
9122 {
9123   val = unwrap_value (val);
9124   val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
9125   return val;
9126 }
9127 \f
9128
9129 /* Attributes */
9130
9131 /* Table mapping attribute numbers to names.
9132    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
9133
9134 static const char *attribute_names[] = {
9135   "<?>",
9136
9137   "first",
9138   "last",
9139   "length",
9140   "image",
9141   "max",
9142   "min",
9143   "modulus",
9144   "pos",
9145   "size",
9146   "tag",
9147   "val",
9148   0
9149 };
9150
9151 static const char *
9152 ada_attribute_name (enum exp_opcode n)
9153 {
9154   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9155     return attribute_names[n - OP_ATR_FIRST + 1];
9156   else
9157     return attribute_names[0];
9158 }
9159
9160 /* Evaluate the 'POS attribute applied to ARG.  */
9161
9162 static LONGEST
9163 pos_atr (struct value *arg)
9164 {
9165   struct value *val = coerce_ref (arg);
9166   struct type *type = value_type (val);
9167   LONGEST result;
9168
9169   if (!discrete_type_p (type))
9170     error (_("'POS only defined on discrete types"));
9171
9172   if (!discrete_position (type, value_as_long (val), &result))
9173     error (_("enumeration value is invalid: can't find 'POS"));
9174
9175   return result;
9176 }
9177
9178 static struct value *
9179 value_pos_atr (struct type *type, struct value *arg)
9180 {
9181   return value_from_longest (type, pos_atr (arg));
9182 }
9183
9184 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
9185
9186 static struct value *
9187 value_val_atr (struct type *type, struct value *arg)
9188 {
9189   if (!discrete_type_p (type))
9190     error (_("'VAL only defined on discrete types"));
9191   if (!integer_type_p (value_type (arg)))
9192     error (_("'VAL requires integral argument"));
9193
9194   if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9195     {
9196       long pos = value_as_long (arg);
9197
9198       if (pos < 0 || pos >= TYPE_NFIELDS (type))
9199         error (_("argument to 'VAL out of range"));
9200       return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
9201     }
9202   else
9203     return value_from_longest (type, value_as_long (arg));
9204 }
9205 \f
9206
9207                                 /* Evaluation */
9208
9209 /* True if TYPE appears to be an Ada character type.
9210    [At the moment, this is true only for Character and Wide_Character;
9211    It is a heuristic test that could stand improvement].  */
9212
9213 bool
9214 ada_is_character_type (struct type *type)
9215 {
9216   const char *name;
9217
9218   /* If the type code says it's a character, then assume it really is,
9219      and don't check any further.  */
9220   if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9221     return true;
9222   
9223   /* Otherwise, assume it's a character type iff it is a discrete type
9224      with a known character type name.  */
9225   name = ada_type_name (type);
9226   return (name != NULL
9227           && (TYPE_CODE (type) == TYPE_CODE_INT
9228               || TYPE_CODE (type) == TYPE_CODE_RANGE)
9229           && (strcmp (name, "character") == 0
9230               || strcmp (name, "wide_character") == 0
9231               || strcmp (name, "wide_wide_character") == 0
9232               || strcmp (name, "unsigned char") == 0));
9233 }
9234
9235 /* True if TYPE appears to be an Ada string type.  */
9236
9237 bool
9238 ada_is_string_type (struct type *type)
9239 {
9240   type = ada_check_typedef (type);
9241   if (type != NULL
9242       && TYPE_CODE (type) != TYPE_CODE_PTR
9243       && (ada_is_simple_array_type (type)
9244           || ada_is_array_descriptor_type (type))
9245       && ada_array_arity (type) == 1)
9246     {
9247       struct type *elttype = ada_array_element_type (type, 1);
9248
9249       return ada_is_character_type (elttype);
9250     }
9251   else
9252     return false;
9253 }
9254
9255 /* The compiler sometimes provides a parallel XVS type for a given
9256    PAD type.  Normally, it is safe to follow the PAD type directly,
9257    but older versions of the compiler have a bug that causes the offset
9258    of its "F" field to be wrong.  Following that field in that case
9259    would lead to incorrect results, but this can be worked around
9260    by ignoring the PAD type and using the associated XVS type instead.
9261
9262    Set to True if the debugger should trust the contents of PAD types.
9263    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
9264 static bool trust_pad_over_xvs = true;
9265
9266 /* True if TYPE is a struct type introduced by the compiler to force the
9267    alignment of a value.  Such types have a single field with a
9268    distinctive name.  */
9269
9270 int
9271 ada_is_aligner_type (struct type *type)
9272 {
9273   type = ada_check_typedef (type);
9274
9275   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9276     return 0;
9277
9278   return (TYPE_CODE (type) == TYPE_CODE_STRUCT
9279           && TYPE_NFIELDS (type) == 1
9280           && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
9281 }
9282
9283 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9284    the parallel type.  */
9285
9286 struct type *
9287 ada_get_base_type (struct type *raw_type)
9288 {
9289   struct type *real_type_namer;
9290   struct type *raw_real_type;
9291
9292   if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9293     return raw_type;
9294
9295   if (ada_is_aligner_type (raw_type))
9296     /* The encoding specifies that we should always use the aligner type.
9297        So, even if this aligner type has an associated XVS type, we should
9298        simply ignore it.
9299
9300        According to the compiler gurus, an XVS type parallel to an aligner
9301        type may exist because of a stabs limitation.  In stabs, aligner
9302        types are empty because the field has a variable-sized type, and
9303        thus cannot actually be used as an aligner type.  As a result,
9304        we need the associated parallel XVS type to decode the type.
9305        Since the policy in the compiler is to not change the internal
9306        representation based on the debugging info format, we sometimes
9307        end up having a redundant XVS type parallel to the aligner type.  */
9308     return raw_type;
9309
9310   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9311   if (real_type_namer == NULL
9312       || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9313       || TYPE_NFIELDS (real_type_namer) != 1)
9314     return raw_type;
9315
9316   if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9317     {
9318       /* This is an older encoding form where the base type needs to be
9319          looked up by name.  We prefer the newer encoding because it is
9320          more efficient.  */
9321       raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9322       if (raw_real_type == NULL)
9323         return raw_type;
9324       else
9325         return raw_real_type;
9326     }
9327
9328   /* The field in our XVS type is a reference to the base type.  */
9329   return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
9330 }
9331
9332 /* The type of value designated by TYPE, with all aligners removed.  */
9333
9334 struct type *
9335 ada_aligned_type (struct type *type)
9336 {
9337   if (ada_is_aligner_type (type))
9338     return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9339   else
9340     return ada_get_base_type (type);
9341 }
9342
9343
9344 /* The address of the aligned value in an object at address VALADDR
9345    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
9346
9347 const gdb_byte *
9348 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9349 {
9350   if (ada_is_aligner_type (type))
9351     return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
9352                                    valaddr +
9353                                    TYPE_FIELD_BITPOS (type,
9354                                                       0) / TARGET_CHAR_BIT);
9355   else
9356     return valaddr;
9357 }
9358
9359
9360
9361 /* The printed representation of an enumeration literal with encoded
9362    name NAME.  The value is good to the next call of ada_enum_name.  */
9363 const char *
9364 ada_enum_name (const char *name)
9365 {
9366   static char *result;
9367   static size_t result_len = 0;
9368   const char *tmp;
9369
9370   /* First, unqualify the enumeration name:
9371      1. Search for the last '.' character.  If we find one, then skip
9372      all the preceding characters, the unqualified name starts
9373      right after that dot.
9374      2. Otherwise, we may be debugging on a target where the compiler
9375      translates dots into "__".  Search forward for double underscores,
9376      but stop searching when we hit an overloading suffix, which is
9377      of the form "__" followed by digits.  */
9378
9379   tmp = strrchr (name, '.');
9380   if (tmp != NULL)
9381     name = tmp + 1;
9382   else
9383     {
9384       while ((tmp = strstr (name, "__")) != NULL)
9385         {
9386           if (isdigit (tmp[2]))
9387             break;
9388           else
9389             name = tmp + 2;
9390         }
9391     }
9392
9393   if (name[0] == 'Q')
9394     {
9395       int v;
9396
9397       if (name[1] == 'U' || name[1] == 'W')
9398         {
9399           if (sscanf (name + 2, "%x", &v) != 1)
9400             return name;
9401         }
9402       else if (((name[1] >= '0' && name[1] <= '9')
9403                 || (name[1] >= 'a' && name[1] <= 'z'))
9404                && name[2] == '\0')
9405         {
9406           GROW_VECT (result, result_len, 4);
9407           xsnprintf (result, result_len, "'%c'", name[1]);
9408           return result;
9409         }
9410       else
9411         return name;
9412
9413       GROW_VECT (result, result_len, 16);
9414       if (isascii (v) && isprint (v))
9415         xsnprintf (result, result_len, "'%c'", v);
9416       else if (name[1] == 'U')
9417         xsnprintf (result, result_len, "[\"%02x\"]", v);
9418       else
9419         xsnprintf (result, result_len, "[\"%04x\"]", v);
9420
9421       return result;
9422     }
9423   else
9424     {
9425       tmp = strstr (name, "__");
9426       if (tmp == NULL)
9427         tmp = strstr (name, "$");
9428       if (tmp != NULL)
9429         {
9430           GROW_VECT (result, result_len, tmp - name + 1);
9431           strncpy (result, name, tmp - name);
9432           result[tmp - name] = '\0';
9433           return result;
9434         }
9435
9436       return name;
9437     }
9438 }
9439
9440 /* Evaluate the subexpression of EXP starting at *POS as for
9441    evaluate_type, updating *POS to point just past the evaluated
9442    expression.  */
9443
9444 static struct value *
9445 evaluate_subexp_type (struct expression *exp, int *pos)
9446 {
9447   return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9448 }
9449
9450 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9451    value it wraps.  */
9452
9453 static struct value *
9454 unwrap_value (struct value *val)
9455 {
9456   struct type *type = ada_check_typedef (value_type (val));
9457
9458   if (ada_is_aligner_type (type))
9459     {
9460       struct value *v = ada_value_struct_elt (val, "F", 0);
9461       struct type *val_type = ada_check_typedef (value_type (v));
9462
9463       if (ada_type_name (val_type) == NULL)
9464         TYPE_NAME (val_type) = ada_type_name (type);
9465
9466       return unwrap_value (v);
9467     }
9468   else
9469     {
9470       struct type *raw_real_type =
9471         ada_check_typedef (ada_get_base_type (type));
9472
9473       /* If there is no parallel XVS or XVE type, then the value is
9474          already unwrapped.  Return it without further modification.  */
9475       if ((type == raw_real_type)
9476           && ada_find_parallel_type (type, "___XVE") == NULL)
9477         return val;
9478
9479       return
9480         coerce_unspec_val_to_type
9481         (val, ada_to_fixed_type (raw_real_type, 0,
9482                                  value_address (val),
9483                                  NULL, 1));
9484     }
9485 }
9486
9487 static struct value *
9488 cast_from_fixed (struct type *type, struct value *arg)
9489 {
9490   struct value *scale = ada_scaling_factor (value_type (arg));
9491   arg = value_cast (value_type (scale), arg);
9492
9493   arg = value_binop (arg, scale, BINOP_MUL);
9494   return value_cast (type, arg);
9495 }
9496
9497 static struct value *
9498 cast_to_fixed (struct type *type, struct value *arg)
9499 {
9500   if (type == value_type (arg))
9501     return arg;
9502
9503   struct value *scale = ada_scaling_factor (type);
9504   if (ada_is_fixed_point_type (value_type (arg)))
9505     arg = cast_from_fixed (value_type (scale), arg);
9506   else
9507     arg = value_cast (value_type (scale), arg);
9508
9509   arg = value_binop (arg, scale, BINOP_DIV);
9510   return value_cast (type, arg);
9511 }
9512
9513 /* Given two array types T1 and T2, return nonzero iff both arrays
9514    contain the same number of elements.  */
9515
9516 static int
9517 ada_same_array_size_p (struct type *t1, struct type *t2)
9518 {
9519   LONGEST lo1, hi1, lo2, hi2;
9520
9521   /* Get the array bounds in order to verify that the size of
9522      the two arrays match.  */
9523   if (!get_array_bounds (t1, &lo1, &hi1)
9524       || !get_array_bounds (t2, &lo2, &hi2))
9525     error (_("unable to determine array bounds"));
9526
9527   /* To make things easier for size comparison, normalize a bit
9528      the case of empty arrays by making sure that the difference
9529      between upper bound and lower bound is always -1.  */
9530   if (lo1 > hi1)
9531     hi1 = lo1 - 1;
9532   if (lo2 > hi2)
9533     hi2 = lo2 - 1;
9534
9535   return (hi1 - lo1 == hi2 - lo2);
9536 }
9537
9538 /* Assuming that VAL is an array of integrals, and TYPE represents
9539    an array with the same number of elements, but with wider integral
9540    elements, return an array "casted" to TYPE.  In practice, this
9541    means that the returned array is built by casting each element
9542    of the original array into TYPE's (wider) element type.  */
9543
9544 static struct value *
9545 ada_promote_array_of_integrals (struct type *type, struct value *val)
9546 {
9547   struct type *elt_type = TYPE_TARGET_TYPE (type);
9548   LONGEST lo, hi;
9549   struct value *res;
9550   LONGEST i;
9551
9552   /* Verify that both val and type are arrays of scalars, and
9553      that the size of val's elements is smaller than the size
9554      of type's element.  */
9555   gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9556   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9557   gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9558   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9559   gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9560               > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9561
9562   if (!get_array_bounds (type, &lo, &hi))
9563     error (_("unable to determine array bounds"));
9564
9565   res = allocate_value (type);
9566
9567   /* Promote each array element.  */
9568   for (i = 0; i < hi - lo + 1; i++)
9569     {
9570       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9571
9572       memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9573               value_contents_all (elt), TYPE_LENGTH (elt_type));
9574     }
9575
9576   return res;
9577 }
9578
9579 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9580    return the converted value.  */
9581
9582 static struct value *
9583 coerce_for_assign (struct type *type, struct value *val)
9584 {
9585   struct type *type2 = value_type (val);
9586
9587   if (type == type2)
9588     return val;
9589
9590   type2 = ada_check_typedef (type2);
9591   type = ada_check_typedef (type);
9592
9593   if (TYPE_CODE (type2) == TYPE_CODE_PTR
9594       && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9595     {
9596       val = ada_value_ind (val);
9597       type2 = value_type (val);
9598     }
9599
9600   if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
9601       && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9602     {
9603       if (!ada_same_array_size_p (type, type2))
9604         error (_("cannot assign arrays of different length"));
9605
9606       if (is_integral_type (TYPE_TARGET_TYPE (type))
9607           && is_integral_type (TYPE_TARGET_TYPE (type2))
9608           && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9609                < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9610         {
9611           /* Allow implicit promotion of the array elements to
9612              a wider type.  */
9613           return ada_promote_array_of_integrals (type, val);
9614         }
9615
9616       if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9617           != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9618         error (_("Incompatible types in assignment"));
9619       deprecated_set_value_type (val, type);
9620     }
9621   return val;
9622 }
9623
9624 static struct value *
9625 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9626 {
9627   struct value *val;
9628   struct type *type1, *type2;
9629   LONGEST v, v1, v2;
9630
9631   arg1 = coerce_ref (arg1);
9632   arg2 = coerce_ref (arg2);
9633   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9634   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9635
9636   if (TYPE_CODE (type1) != TYPE_CODE_INT
9637       || TYPE_CODE (type2) != TYPE_CODE_INT)
9638     return value_binop (arg1, arg2, op);
9639
9640   switch (op)
9641     {
9642     case BINOP_MOD:
9643     case BINOP_DIV:
9644     case BINOP_REM:
9645       break;
9646     default:
9647       return value_binop (arg1, arg2, op);
9648     }
9649
9650   v2 = value_as_long (arg2);
9651   if (v2 == 0)
9652     error (_("second operand of %s must not be zero."), op_string (op));
9653
9654   if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9655     return value_binop (arg1, arg2, op);
9656
9657   v1 = value_as_long (arg1);
9658   switch (op)
9659     {
9660     case BINOP_DIV:
9661       v = v1 / v2;
9662       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9663         v += v > 0 ? -1 : 1;
9664       break;
9665     case BINOP_REM:
9666       v = v1 % v2;
9667       if (v * v1 < 0)
9668         v -= v2;
9669       break;
9670     default:
9671       /* Should not reach this point.  */
9672       v = 0;
9673     }
9674
9675   val = allocate_value (type1);
9676   store_unsigned_integer (value_contents_raw (val),
9677                           TYPE_LENGTH (value_type (val)),
9678                           type_byte_order (type1), v);
9679   return val;
9680 }
9681
9682 static int
9683 ada_value_equal (struct value *arg1, struct value *arg2)
9684 {
9685   if (ada_is_direct_array_type (value_type (arg1))
9686       || ada_is_direct_array_type (value_type (arg2)))
9687     {
9688       struct type *arg1_type, *arg2_type;
9689
9690       /* Automatically dereference any array reference before
9691          we attempt to perform the comparison.  */
9692       arg1 = ada_coerce_ref (arg1);
9693       arg2 = ada_coerce_ref (arg2);
9694
9695       arg1 = ada_coerce_to_simple_array (arg1);
9696       arg2 = ada_coerce_to_simple_array (arg2);
9697
9698       arg1_type = ada_check_typedef (value_type (arg1));
9699       arg2_type = ada_check_typedef (value_type (arg2));
9700
9701       if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9702           || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
9703         error (_("Attempt to compare array with non-array"));
9704       /* FIXME: The following works only for types whose
9705          representations use all bits (no padding or undefined bits)
9706          and do not have user-defined equality.  */
9707       return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9708               && memcmp (value_contents (arg1), value_contents (arg2),
9709                          TYPE_LENGTH (arg1_type)) == 0);
9710     }
9711   return value_equal (arg1, arg2);
9712 }
9713
9714 /* Total number of component associations in the aggregate starting at
9715    index PC in EXP.  Assumes that index PC is the start of an
9716    OP_AGGREGATE.  */
9717
9718 static int
9719 num_component_specs (struct expression *exp, int pc)
9720 {
9721   int n, m, i;
9722
9723   m = exp->elts[pc + 1].longconst;
9724   pc += 3;
9725   n = 0;
9726   for (i = 0; i < m; i += 1)
9727     {
9728       switch (exp->elts[pc].opcode) 
9729         {
9730         default:
9731           n += 1;
9732           break;
9733         case OP_CHOICES:
9734           n += exp->elts[pc + 1].longconst;
9735           break;
9736         }
9737       ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9738     }
9739   return n;
9740 }
9741
9742 /* Assign the result of evaluating EXP starting at *POS to the INDEXth 
9743    component of LHS (a simple array or a record), updating *POS past
9744    the expression, assuming that LHS is contained in CONTAINER.  Does
9745    not modify the inferior's memory, nor does it modify LHS (unless
9746    LHS == CONTAINER).  */
9747
9748 static void
9749 assign_component (struct value *container, struct value *lhs, LONGEST index,
9750                   struct expression *exp, int *pos)
9751 {
9752   struct value *mark = value_mark ();
9753   struct value *elt;
9754   struct type *lhs_type = check_typedef (value_type (lhs));
9755
9756   if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
9757     {
9758       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9759       struct value *index_val = value_from_longest (index_type, index);
9760
9761       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9762     }
9763   else
9764     {
9765       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9766       elt = ada_to_fixed_value (elt);
9767     }
9768
9769   if (exp->elts[*pos].opcode == OP_AGGREGATE)
9770     assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9771   else
9772     value_assign_to_component (container, elt, 
9773                                ada_evaluate_subexp (NULL, exp, pos, 
9774                                                     EVAL_NORMAL));
9775
9776   value_free_to_mark (mark);
9777 }
9778
9779 /* Assuming that LHS represents an lvalue having a record or array
9780    type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9781    of that aggregate's value to LHS, advancing *POS past the
9782    aggregate.  NOSIDE is as for evaluate_subexp.  CONTAINER is an
9783    lvalue containing LHS (possibly LHS itself).  Does not modify
9784    the inferior's memory, nor does it modify the contents of 
9785    LHS (unless == CONTAINER).  Returns the modified CONTAINER.  */
9786
9787 static struct value *
9788 assign_aggregate (struct value *container, 
9789                   struct value *lhs, struct expression *exp, 
9790                   int *pos, enum noside noside)
9791 {
9792   struct type *lhs_type;
9793   int n = exp->elts[*pos+1].longconst;
9794   LONGEST low_index, high_index;
9795   int num_specs;
9796   LONGEST *indices;
9797   int max_indices, num_indices;
9798   int i;
9799
9800   *pos += 3;
9801   if (noside != EVAL_NORMAL)
9802     {
9803       for (i = 0; i < n; i += 1)
9804         ada_evaluate_subexp (NULL, exp, pos, noside);
9805       return container;
9806     }
9807
9808   container = ada_coerce_ref (container);
9809   if (ada_is_direct_array_type (value_type (container)))
9810     container = ada_coerce_to_simple_array (container);
9811   lhs = ada_coerce_ref (lhs);
9812   if (!deprecated_value_modifiable (lhs))
9813     error (_("Left operand of assignment is not a modifiable lvalue."));
9814
9815   lhs_type = check_typedef (value_type (lhs));
9816   if (ada_is_direct_array_type (lhs_type))
9817     {
9818       lhs = ada_coerce_to_simple_array (lhs);
9819       lhs_type = check_typedef (value_type (lhs));
9820       low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9821       high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
9822     }
9823   else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9824     {
9825       low_index = 0;
9826       high_index = num_visible_fields (lhs_type) - 1;
9827     }
9828   else
9829     error (_("Left-hand side must be array or record."));
9830
9831   num_specs = num_component_specs (exp, *pos - 3);
9832   max_indices = 4 * num_specs + 4;
9833   indices = XALLOCAVEC (LONGEST, max_indices);
9834   indices[0] = indices[1] = low_index - 1;
9835   indices[2] = indices[3] = high_index + 1;
9836   num_indices = 4;
9837
9838   for (i = 0; i < n; i += 1)
9839     {
9840       switch (exp->elts[*pos].opcode)
9841         {
9842           case OP_CHOICES:
9843             aggregate_assign_from_choices (container, lhs, exp, pos, indices, 
9844                                            &num_indices, max_indices,
9845                                            low_index, high_index);
9846             break;
9847           case OP_POSITIONAL:
9848             aggregate_assign_positional (container, lhs, exp, pos, indices,
9849                                          &num_indices, max_indices,
9850                                          low_index, high_index);
9851             break;
9852           case OP_OTHERS:
9853             if (i != n-1)
9854               error (_("Misplaced 'others' clause"));
9855             aggregate_assign_others (container, lhs, exp, pos, indices, 
9856                                      num_indices, low_index, high_index);
9857             break;
9858           default:
9859             error (_("Internal error: bad aggregate clause"));
9860         }
9861     }
9862
9863   return container;
9864 }
9865               
9866 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9867    construct at *POS, updating *POS past the construct, given that
9868    the positions are relative to lower bound LOW, where HIGH is the 
9869    upper bound.  Record the position in INDICES[0 .. MAX_INDICES-1]
9870    updating *NUM_INDICES as needed.  CONTAINER is as for
9871    assign_aggregate.  */
9872 static void
9873 aggregate_assign_positional (struct value *container,
9874                              struct value *lhs, struct expression *exp,
9875                              int *pos, LONGEST *indices, int *num_indices,
9876                              int max_indices, LONGEST low, LONGEST high) 
9877 {
9878   LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9879   
9880   if (ind - 1 == high)
9881     warning (_("Extra components in aggregate ignored."));
9882   if (ind <= high)
9883     {
9884       add_component_interval (ind, ind, indices, num_indices, max_indices);
9885       *pos += 3;
9886       assign_component (container, lhs, ind, exp, pos);
9887     }
9888   else
9889     ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9890 }
9891
9892 /* Assign into the components of LHS indexed by the OP_CHOICES
9893    construct at *POS, updating *POS past the construct, given that
9894    the allowable indices are LOW..HIGH.  Record the indices assigned
9895    to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9896    needed.  CONTAINER is as for assign_aggregate.  */
9897 static void
9898 aggregate_assign_from_choices (struct value *container,
9899                                struct value *lhs, struct expression *exp,
9900                                int *pos, LONGEST *indices, int *num_indices,
9901                                int max_indices, LONGEST low, LONGEST high) 
9902 {
9903   int j;
9904   int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9905   int choice_pos, expr_pc;
9906   int is_array = ada_is_direct_array_type (value_type (lhs));
9907
9908   choice_pos = *pos += 3;
9909
9910   for (j = 0; j < n_choices; j += 1)
9911     ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9912   expr_pc = *pos;
9913   ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9914   
9915   for (j = 0; j < n_choices; j += 1)
9916     {
9917       LONGEST lower, upper;
9918       enum exp_opcode op = exp->elts[choice_pos].opcode;
9919
9920       if (op == OP_DISCRETE_RANGE)
9921         {
9922           choice_pos += 1;
9923           lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9924                                                       EVAL_NORMAL));
9925           upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos, 
9926                                                       EVAL_NORMAL));
9927         }
9928       else if (is_array)
9929         {
9930           lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos, 
9931                                                       EVAL_NORMAL));
9932           upper = lower;
9933         }
9934       else
9935         {
9936           int ind;
9937           const char *name;
9938
9939           switch (op)
9940             {
9941             case OP_NAME:
9942               name = &exp->elts[choice_pos + 2].string;
9943               break;
9944             case OP_VAR_VALUE:
9945               name = exp->elts[choice_pos + 2].symbol->natural_name ();
9946               break;
9947             default:
9948               error (_("Invalid record component association."));
9949             }
9950           ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9951           ind = 0;
9952           if (! find_struct_field (name, value_type (lhs), 0, 
9953                                    NULL, NULL, NULL, NULL, &ind))
9954             error (_("Unknown component name: %s."), name);
9955           lower = upper = ind;
9956         }
9957
9958       if (lower <= upper && (lower < low || upper > high))
9959         error (_("Index in component association out of bounds."));
9960
9961       add_component_interval (lower, upper, indices, num_indices,
9962                               max_indices);
9963       while (lower <= upper)
9964         {
9965           int pos1;
9966
9967           pos1 = expr_pc;
9968           assign_component (container, lhs, lower, exp, &pos1);
9969           lower += 1;
9970         }
9971     }
9972 }
9973
9974 /* Assign the value of the expression in the OP_OTHERS construct in
9975    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9976    have not been previously assigned.  The index intervals already assigned
9977    are in INDICES[0 .. NUM_INDICES-1].  Updates *POS to after the 
9978    OP_OTHERS clause.  CONTAINER is as for assign_aggregate.  */
9979 static void
9980 aggregate_assign_others (struct value *container,
9981                          struct value *lhs, struct expression *exp,
9982                          int *pos, LONGEST *indices, int num_indices,
9983                          LONGEST low, LONGEST high) 
9984 {
9985   int i;
9986   int expr_pc = *pos + 1;
9987   
9988   for (i = 0; i < num_indices - 2; i += 2)
9989     {
9990       LONGEST ind;
9991
9992       for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9993         {
9994           int localpos;
9995
9996           localpos = expr_pc;
9997           assign_component (container, lhs, ind, exp, &localpos);
9998         }
9999     }
10000   ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10001 }
10002
10003 /* Add the interval [LOW .. HIGH] to the sorted set of intervals 
10004    [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10005    modifying *SIZE as needed.  It is an error if *SIZE exceeds
10006    MAX_SIZE.  The resulting intervals do not overlap.  */
10007 static void
10008 add_component_interval (LONGEST low, LONGEST high, 
10009                         LONGEST* indices, int *size, int max_size)
10010 {
10011   int i, j;
10012
10013   for (i = 0; i < *size; i += 2) {
10014     if (high >= indices[i] && low <= indices[i + 1])
10015       {
10016         int kh;
10017
10018         for (kh = i + 2; kh < *size; kh += 2)
10019           if (high < indices[kh])
10020             break;
10021         if (low < indices[i])
10022           indices[i] = low;
10023         indices[i + 1] = indices[kh - 1];
10024         if (high > indices[i + 1])
10025           indices[i + 1] = high;
10026         memcpy (indices + i + 2, indices + kh, *size - kh);
10027         *size -= kh - i - 2;
10028         return;
10029       }
10030     else if (high < indices[i])
10031       break;
10032   }
10033         
10034   if (*size == max_size)
10035     error (_("Internal error: miscounted aggregate components."));
10036   *size += 2;
10037   for (j = *size-1; j >= i+2; j -= 1)
10038     indices[j] = indices[j - 2];
10039   indices[i] = low;
10040   indices[i + 1] = high;
10041 }
10042
10043 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10044    is different.  */
10045
10046 static struct value *
10047 ada_value_cast (struct type *type, struct value *arg2)
10048 {
10049   if (type == ada_check_typedef (value_type (arg2)))
10050     return arg2;
10051
10052   if (ada_is_fixed_point_type (type))
10053     return cast_to_fixed (type, arg2);
10054
10055   if (ada_is_fixed_point_type (value_type (arg2)))
10056     return cast_from_fixed (type, arg2);
10057
10058   return value_cast (type, arg2);
10059 }
10060
10061 /*  Evaluating Ada expressions, and printing their result.
10062     ------------------------------------------------------
10063
10064     1. Introduction:
10065     ----------------
10066
10067     We usually evaluate an Ada expression in order to print its value.
10068     We also evaluate an expression in order to print its type, which
10069     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10070     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
10071     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10072     the evaluation compared to the EVAL_NORMAL, but is otherwise very
10073     similar.
10074
10075     Evaluating expressions is a little more complicated for Ada entities
10076     than it is for entities in languages such as C.  The main reason for
10077     this is that Ada provides types whose definition might be dynamic.
10078     One example of such types is variant records.  Or another example
10079     would be an array whose bounds can only be known at run time.
10080
10081     The following description is a general guide as to what should be
10082     done (and what should NOT be done) in order to evaluate an expression
10083     involving such types, and when.  This does not cover how the semantic
10084     information is encoded by GNAT as this is covered separatly.  For the
10085     document used as the reference for the GNAT encoding, see exp_dbug.ads
10086     in the GNAT sources.
10087
10088     Ideally, we should embed each part of this description next to its
10089     associated code.  Unfortunately, the amount of code is so vast right
10090     now that it's hard to see whether the code handling a particular
10091     situation might be duplicated or not.  One day, when the code is
10092     cleaned up, this guide might become redundant with the comments
10093     inserted in the code, and we might want to remove it.
10094
10095     2. ``Fixing'' an Entity, the Simple Case:
10096     -----------------------------------------
10097
10098     When evaluating Ada expressions, the tricky issue is that they may
10099     reference entities whose type contents and size are not statically
10100     known.  Consider for instance a variant record:
10101
10102        type Rec (Empty : Boolean := True) is record
10103           case Empty is
10104              when True => null;
10105              when False => Value : Integer;
10106           end case;
10107        end record;
10108        Yes : Rec := (Empty => False, Value => 1);
10109        No  : Rec := (empty => True);
10110
10111     The size and contents of that record depends on the value of the
10112     descriminant (Rec.Empty).  At this point, neither the debugging
10113     information nor the associated type structure in GDB are able to
10114     express such dynamic types.  So what the debugger does is to create
10115     "fixed" versions of the type that applies to the specific object.
10116     We also informally refer to this operation as "fixing" an object,
10117     which means creating its associated fixed type.
10118
10119     Example: when printing the value of variable "Yes" above, its fixed
10120     type would look like this:
10121
10122        type Rec is record
10123           Empty : Boolean;
10124           Value : Integer;
10125        end record;
10126
10127     On the other hand, if we printed the value of "No", its fixed type
10128     would become:
10129
10130        type Rec is record
10131           Empty : Boolean;
10132        end record;
10133
10134     Things become a little more complicated when trying to fix an entity
10135     with a dynamic type that directly contains another dynamic type,
10136     such as an array of variant records, for instance.  There are
10137     two possible cases: Arrays, and records.
10138
10139     3. ``Fixing'' Arrays:
10140     ---------------------
10141
10142     The type structure in GDB describes an array in terms of its bounds,
10143     and the type of its elements.  By design, all elements in the array
10144     have the same type and we cannot represent an array of variant elements
10145     using the current type structure in GDB.  When fixing an array,
10146     we cannot fix the array element, as we would potentially need one
10147     fixed type per element of the array.  As a result, the best we can do
10148     when fixing an array is to produce an array whose bounds and size
10149     are correct (allowing us to read it from memory), but without having
10150     touched its element type.  Fixing each element will be done later,
10151     when (if) necessary.
10152
10153     Arrays are a little simpler to handle than records, because the same
10154     amount of memory is allocated for each element of the array, even if
10155     the amount of space actually used by each element differs from element
10156     to element.  Consider for instance the following array of type Rec:
10157
10158        type Rec_Array is array (1 .. 2) of Rec;
10159
10160     The actual amount of memory occupied by each element might be different
10161     from element to element, depending on the value of their discriminant.
10162     But the amount of space reserved for each element in the array remains
10163     fixed regardless.  So we simply need to compute that size using
10164     the debugging information available, from which we can then determine
10165     the array size (we multiply the number of elements of the array by
10166     the size of each element).
10167
10168     The simplest case is when we have an array of a constrained element
10169     type. For instance, consider the following type declarations:
10170
10171         type Bounded_String (Max_Size : Integer) is
10172            Length : Integer;
10173            Buffer : String (1 .. Max_Size);
10174         end record;
10175         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10176
10177     In this case, the compiler describes the array as an array of
10178     variable-size elements (identified by its XVS suffix) for which
10179     the size can be read in the parallel XVZ variable.
10180
10181     In the case of an array of an unconstrained element type, the compiler
10182     wraps the array element inside a private PAD type.  This type should not
10183     be shown to the user, and must be "unwrap"'ed before printing.  Note
10184     that we also use the adjective "aligner" in our code to designate
10185     these wrapper types.
10186
10187     In some cases, the size allocated for each element is statically
10188     known.  In that case, the PAD type already has the correct size,
10189     and the array element should remain unfixed.
10190
10191     But there are cases when this size is not statically known.
10192     For instance, assuming that "Five" is an integer variable:
10193
10194         type Dynamic is array (1 .. Five) of Integer;
10195         type Wrapper (Has_Length : Boolean := False) is record
10196            Data : Dynamic;
10197            case Has_Length is
10198               when True => Length : Integer;
10199               when False => null;
10200            end case;
10201         end record;
10202         type Wrapper_Array is array (1 .. 2) of Wrapper;
10203
10204         Hello : Wrapper_Array := (others => (Has_Length => True,
10205                                              Data => (others => 17),
10206                                              Length => 1));
10207
10208
10209     The debugging info would describe variable Hello as being an
10210     array of a PAD type.  The size of that PAD type is not statically
10211     known, but can be determined using a parallel XVZ variable.
10212     In that case, a copy of the PAD type with the correct size should
10213     be used for the fixed array.
10214
10215     3. ``Fixing'' record type objects:
10216     ----------------------------------
10217
10218     Things are slightly different from arrays in the case of dynamic
10219     record types.  In this case, in order to compute the associated
10220     fixed type, we need to determine the size and offset of each of
10221     its components.  This, in turn, requires us to compute the fixed
10222     type of each of these components.
10223
10224     Consider for instance the example:
10225
10226         type Bounded_String (Max_Size : Natural) is record
10227            Str : String (1 .. Max_Size);
10228            Length : Natural;
10229         end record;
10230         My_String : Bounded_String (Max_Size => 10);
10231
10232     In that case, the position of field "Length" depends on the size
10233     of field Str, which itself depends on the value of the Max_Size
10234     discriminant.  In order to fix the type of variable My_String,
10235     we need to fix the type of field Str.  Therefore, fixing a variant
10236     record requires us to fix each of its components.
10237
10238     However, if a component does not have a dynamic size, the component
10239     should not be fixed.  In particular, fields that use a PAD type
10240     should not fixed.  Here is an example where this might happen
10241     (assuming type Rec above):
10242
10243        type Container (Big : Boolean) is record
10244           First : Rec;
10245           After : Integer;
10246           case Big is
10247              when True => Another : Integer;
10248              when False => null;
10249           end case;
10250        end record;
10251        My_Container : Container := (Big => False,
10252                                     First => (Empty => True),
10253                                     After => 42);
10254
10255     In that example, the compiler creates a PAD type for component First,
10256     whose size is constant, and then positions the component After just
10257     right after it.  The offset of component After is therefore constant
10258     in this case.
10259
10260     The debugger computes the position of each field based on an algorithm
10261     that uses, among other things, the actual position and size of the field
10262     preceding it.  Let's now imagine that the user is trying to print
10263     the value of My_Container.  If the type fixing was recursive, we would
10264     end up computing the offset of field After based on the size of the
10265     fixed version of field First.  And since in our example First has
10266     only one actual field, the size of the fixed type is actually smaller
10267     than the amount of space allocated to that field, and thus we would
10268     compute the wrong offset of field After.
10269
10270     To make things more complicated, we need to watch out for dynamic
10271     components of variant records (identified by the ___XVL suffix in
10272     the component name).  Even if the target type is a PAD type, the size
10273     of that type might not be statically known.  So the PAD type needs
10274     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
10275     we might end up with the wrong size for our component.  This can be
10276     observed with the following type declarations:
10277
10278         type Octal is new Integer range 0 .. 7;
10279         type Octal_Array is array (Positive range <>) of Octal;
10280         pragma Pack (Octal_Array);
10281
10282         type Octal_Buffer (Size : Positive) is record
10283            Buffer : Octal_Array (1 .. Size);
10284            Length : Integer;
10285         end record;
10286
10287     In that case, Buffer is a PAD type whose size is unset and needs
10288     to be computed by fixing the unwrapped type.
10289
10290     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10291     ----------------------------------------------------------
10292
10293     Lastly, when should the sub-elements of an entity that remained unfixed
10294     thus far, be actually fixed?
10295
10296     The answer is: Only when referencing that element.  For instance
10297     when selecting one component of a record, this specific component
10298     should be fixed at that point in time.  Or when printing the value
10299     of a record, each component should be fixed before its value gets
10300     printed.  Similarly for arrays, the element of the array should be
10301     fixed when printing each element of the array, or when extracting
10302     one element out of that array.  On the other hand, fixing should
10303     not be performed on the elements when taking a slice of an array!
10304
10305     Note that one of the side effects of miscomputing the offset and
10306     size of each field is that we end up also miscomputing the size
10307     of the containing type.  This can have adverse results when computing
10308     the value of an entity.  GDB fetches the value of an entity based
10309     on the size of its type, and thus a wrong size causes GDB to fetch
10310     the wrong amount of memory.  In the case where the computed size is
10311     too small, GDB fetches too little data to print the value of our
10312     entity.  Results in this case are unpredictable, as we usually read
10313     past the buffer containing the data =:-o.  */
10314
10315 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10316    for that subexpression cast to TO_TYPE.  Advance *POS over the
10317    subexpression.  */
10318
10319 static value *
10320 ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10321                               enum noside noside, struct type *to_type)
10322 {
10323   int pc = *pos;
10324
10325   if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10326       || exp->elts[pc].opcode == OP_VAR_VALUE)
10327     {
10328       (*pos) += 4;
10329
10330       value *val;
10331       if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10332         {
10333           if (noside == EVAL_AVOID_SIDE_EFFECTS)
10334             return value_zero (to_type, not_lval);
10335
10336           val = evaluate_var_msym_value (noside,
10337                                          exp->elts[pc + 1].objfile,
10338                                          exp->elts[pc + 2].msymbol);
10339         }
10340       else
10341         val = evaluate_var_value (noside,
10342                                   exp->elts[pc + 1].block,
10343                                   exp->elts[pc + 2].symbol);
10344
10345       if (noside == EVAL_SKIP)
10346         return eval_skip_value (exp);
10347
10348       val = ada_value_cast (to_type, val);
10349
10350       /* Follow the Ada language semantics that do not allow taking
10351          an address of the result of a cast (view conversion in Ada).  */
10352       if (VALUE_LVAL (val) == lval_memory)
10353         {
10354           if (value_lazy (val))
10355             value_fetch_lazy (val);
10356           VALUE_LVAL (val) = not_lval;
10357         }
10358       return val;
10359     }
10360
10361   value *val = evaluate_subexp (to_type, exp, pos, noside);
10362   if (noside == EVAL_SKIP)
10363     return eval_skip_value (exp);
10364   return ada_value_cast (to_type, val);
10365 }
10366
10367 /* Implement the evaluate_exp routine in the exp_descriptor structure
10368    for the Ada language.  */
10369
10370 static struct value *
10371 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
10372                      int *pos, enum noside noside)
10373 {
10374   enum exp_opcode op;
10375   int tem;
10376   int pc;
10377   int preeval_pos;
10378   struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10379   struct type *type;
10380   int nargs, oplen;
10381   struct value **argvec;
10382
10383   pc = *pos;
10384   *pos += 1;
10385   op = exp->elts[pc].opcode;
10386
10387   switch (op)
10388     {
10389     default:
10390       *pos -= 1;
10391       arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10392
10393       if (noside == EVAL_NORMAL)
10394         arg1 = unwrap_value (arg1);
10395
10396       /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10397          then we need to perform the conversion manually, because
10398          evaluate_subexp_standard doesn't do it.  This conversion is
10399          necessary in Ada because the different kinds of float/fixed
10400          types in Ada have different representations.
10401
10402          Similarly, we need to perform the conversion from OP_LONG
10403          ourselves.  */
10404       if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
10405         arg1 = ada_value_cast (expect_type, arg1);
10406
10407       return arg1;
10408
10409     case OP_STRING:
10410       {
10411         struct value *result;
10412
10413         *pos -= 1;
10414         result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10415         /* The result type will have code OP_STRING, bashed there from 
10416            OP_ARRAY.  Bash it back.  */
10417         if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10418           TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
10419         return result;
10420       }
10421
10422     case UNOP_CAST:
10423       (*pos) += 2;
10424       type = exp->elts[pc + 1].type;
10425       return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
10426
10427     case UNOP_QUAL:
10428       (*pos) += 2;
10429       type = exp->elts[pc + 1].type;
10430       return ada_evaluate_subexp (type, exp, pos, noside);
10431
10432     case BINOP_ASSIGN:
10433       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10434       if (exp->elts[*pos].opcode == OP_AGGREGATE)
10435         {
10436           arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10437           if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10438             return arg1;
10439           return ada_value_assign (arg1, arg1);
10440         }
10441       /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10442          except if the lhs of our assignment is a convenience variable.
10443          In the case of assigning to a convenience variable, the lhs
10444          should be exactly the result of the evaluation of the rhs.  */
10445       type = value_type (arg1);
10446       if (VALUE_LVAL (arg1) == lval_internalvar)
10447          type = NULL;
10448       arg2 = evaluate_subexp (type, exp, pos, noside);
10449       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10450         return arg1;
10451       if (VALUE_LVAL (arg1) == lval_internalvar)
10452         {
10453           /* Nothing.  */
10454         }
10455       else if (ada_is_fixed_point_type (value_type (arg1)))
10456         arg2 = cast_to_fixed (value_type (arg1), arg2);
10457       else if (ada_is_fixed_point_type (value_type (arg2)))
10458         error
10459           (_("Fixed-point values must be assigned to fixed-point variables"));
10460       else
10461         arg2 = coerce_for_assign (value_type (arg1), arg2);
10462       return ada_value_assign (arg1, arg2);
10463
10464     case BINOP_ADD:
10465       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10466       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10467       if (noside == EVAL_SKIP)
10468         goto nosideret;
10469       if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10470         return (value_from_longest
10471                  (value_type (arg1),
10472                   value_as_long (arg1) + value_as_long (arg2)));
10473       if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10474         return (value_from_longest
10475                  (value_type (arg2),
10476                   value_as_long (arg1) + value_as_long (arg2)));
10477       if ((ada_is_fixed_point_type (value_type (arg1))
10478            || ada_is_fixed_point_type (value_type (arg2)))
10479           && value_type (arg1) != value_type (arg2))
10480         error (_("Operands of fixed-point addition must have the same type"));
10481       /* Do the addition, and cast the result to the type of the first
10482          argument.  We cannot cast the result to a reference type, so if
10483          ARG1 is a reference type, find its underlying type.  */
10484       type = value_type (arg1);
10485       while (TYPE_CODE (type) == TYPE_CODE_REF)
10486         type = TYPE_TARGET_TYPE (type);
10487       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10488       return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
10489
10490     case BINOP_SUB:
10491       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10492       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10493       if (noside == EVAL_SKIP)
10494         goto nosideret;
10495       if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10496         return (value_from_longest
10497                  (value_type (arg1),
10498                   value_as_long (arg1) - value_as_long (arg2)));
10499       if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10500         return (value_from_longest
10501                  (value_type (arg2),
10502                   value_as_long (arg1) - value_as_long (arg2)));
10503       if ((ada_is_fixed_point_type (value_type (arg1))
10504            || ada_is_fixed_point_type (value_type (arg2)))
10505           && value_type (arg1) != value_type (arg2))
10506         error (_("Operands of fixed-point subtraction "
10507                  "must have the same type"));
10508       /* Do the substraction, and cast the result to the type of the first
10509          argument.  We cannot cast the result to a reference type, so if
10510          ARG1 is a reference type, find its underlying type.  */
10511       type = value_type (arg1);
10512       while (TYPE_CODE (type) == TYPE_CODE_REF)
10513         type = TYPE_TARGET_TYPE (type);
10514       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10515       return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
10516
10517     case BINOP_MUL:
10518     case BINOP_DIV:
10519     case BINOP_REM:
10520     case BINOP_MOD:
10521       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10522       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10523       if (noside == EVAL_SKIP)
10524         goto nosideret;
10525       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10526         {
10527           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10528           return value_zero (value_type (arg1), not_lval);
10529         }
10530       else
10531         {
10532           type = builtin_type (exp->gdbarch)->builtin_double;
10533           if (ada_is_fixed_point_type (value_type (arg1)))
10534             arg1 = cast_from_fixed (type, arg1);
10535           if (ada_is_fixed_point_type (value_type (arg2)))
10536             arg2 = cast_from_fixed (type, arg2);
10537           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10538           return ada_value_binop (arg1, arg2, op);
10539         }
10540
10541     case BINOP_EQUAL:
10542     case BINOP_NOTEQUAL:
10543       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10544       arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
10545       if (noside == EVAL_SKIP)
10546         goto nosideret;
10547       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10548         tem = 0;
10549       else
10550         {
10551           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10552           tem = ada_value_equal (arg1, arg2);
10553         }
10554       if (op == BINOP_NOTEQUAL)
10555         tem = !tem;
10556       type = language_bool_type (exp->language_defn, exp->gdbarch);
10557       return value_from_longest (type, (LONGEST) tem);
10558
10559     case UNOP_NEG:
10560       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10561       if (noside == EVAL_SKIP)
10562         goto nosideret;
10563       else if (ada_is_fixed_point_type (value_type (arg1)))
10564         return value_cast (value_type (arg1), value_neg (arg1));
10565       else
10566         {
10567           unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10568           return value_neg (arg1);
10569         }
10570
10571     case BINOP_LOGICAL_AND:
10572     case BINOP_LOGICAL_OR:
10573     case UNOP_LOGICAL_NOT:
10574       {
10575         struct value *val;
10576
10577         *pos -= 1;
10578         val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10579         type = language_bool_type (exp->language_defn, exp->gdbarch);
10580         return value_cast (type, val);
10581       }
10582
10583     case BINOP_BITWISE_AND:
10584     case BINOP_BITWISE_IOR:
10585     case BINOP_BITWISE_XOR:
10586       {
10587         struct value *val;
10588
10589         arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10590         *pos = pc;
10591         val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10592
10593         return value_cast (value_type (arg1), val);
10594       }
10595
10596     case OP_VAR_VALUE:
10597       *pos -= 1;
10598
10599       if (noside == EVAL_SKIP)
10600         {
10601           *pos += 4;
10602           goto nosideret;
10603         }
10604
10605       if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
10606         /* Only encountered when an unresolved symbol occurs in a
10607            context other than a function call, in which case, it is
10608            invalid.  */
10609         error (_("Unexpected unresolved symbol, %s, during evaluation"),
10610                exp->elts[pc + 2].symbol->print_name ());
10611
10612       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10613         {
10614           type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
10615           /* Check to see if this is a tagged type.  We also need to handle
10616              the case where the type is a reference to a tagged type, but
10617              we have to be careful to exclude pointers to tagged types.
10618              The latter should be shown as usual (as a pointer), whereas
10619              a reference should mostly be transparent to the user.  */
10620           if (ada_is_tagged_type (type, 0)
10621               || (TYPE_CODE (type) == TYPE_CODE_REF
10622                   && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10623             {
10624               /* Tagged types are a little special in the fact that the real
10625                  type is dynamic and can only be determined by inspecting the
10626                  object's tag.  This means that we need to get the object's
10627                  value first (EVAL_NORMAL) and then extract the actual object
10628                  type from its tag.
10629
10630                  Note that we cannot skip the final step where we extract
10631                  the object type from its tag, because the EVAL_NORMAL phase
10632                  results in dynamic components being resolved into fixed ones.
10633                  This can cause problems when trying to print the type
10634                  description of tagged types whose parent has a dynamic size:
10635                  We use the type name of the "_parent" component in order
10636                  to print the name of the ancestor type in the type description.
10637                  If that component had a dynamic size, the resolution into
10638                  a fixed type would result in the loss of that type name,
10639                  thus preventing us from printing the name of the ancestor
10640                  type in the type description.  */
10641               arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10642
10643               if (TYPE_CODE (type) != TYPE_CODE_REF)
10644                 {
10645                   struct type *actual_type;
10646
10647                   actual_type = type_from_tag (ada_value_tag (arg1));
10648                   if (actual_type == NULL)
10649                     /* If, for some reason, we were unable to determine
10650                        the actual type from the tag, then use the static
10651                        approximation that we just computed as a fallback.
10652                        This can happen if the debugging information is
10653                        incomplete, for instance.  */
10654                     actual_type = type;
10655                   return value_zero (actual_type, not_lval);
10656                 }
10657               else
10658                 {
10659                   /* In the case of a ref, ada_coerce_ref takes care
10660                      of determining the actual type.  But the evaluation
10661                      should return a ref as it should be valid to ask
10662                      for its address; so rebuild a ref after coerce.  */
10663                   arg1 = ada_coerce_ref (arg1);
10664                   return value_ref (arg1, TYPE_CODE_REF);
10665                 }
10666             }
10667
10668           /* Records and unions for which GNAT encodings have been
10669              generated need to be statically fixed as well.
10670              Otherwise, non-static fixing produces a type where
10671              all dynamic properties are removed, which prevents "ptype"
10672              from being able to completely describe the type.
10673              For instance, a case statement in a variant record would be
10674              replaced by the relevant components based on the actual
10675              value of the discriminants.  */
10676           if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10677                && dynamic_template_type (type) != NULL)
10678               || (TYPE_CODE (type) == TYPE_CODE_UNION
10679                   && ada_find_parallel_type (type, "___XVU") != NULL))
10680             {
10681               *pos += 4;
10682               return value_zero (to_static_fixed_type (type), not_lval);
10683             }
10684         }
10685
10686       arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10687       return ada_to_fixed_value (arg1);
10688
10689     case OP_FUNCALL:
10690       (*pos) += 2;
10691
10692       /* Allocate arg vector, including space for the function to be
10693          called in argvec[0] and a terminating NULL.  */
10694       nargs = longest_to_int (exp->elts[pc + 1].longconst);
10695       argvec = XALLOCAVEC (struct value *, nargs + 2);
10696
10697       if (exp->elts[*pos].opcode == OP_VAR_VALUE
10698           && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
10699         error (_("Unexpected unresolved symbol, %s, during evaluation"),
10700                exp->elts[pc + 5].symbol->print_name ());
10701       else
10702         {
10703           for (tem = 0; tem <= nargs; tem += 1)
10704             argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10705           argvec[tem] = 0;
10706
10707           if (noside == EVAL_SKIP)
10708             goto nosideret;
10709         }
10710
10711       if (ada_is_constrained_packed_array_type
10712           (desc_base_type (value_type (argvec[0]))))
10713         argvec[0] = ada_coerce_to_simple_array (argvec[0]);
10714       else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10715                && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10716         /* This is a packed array that has already been fixed, and
10717            therefore already coerced to a simple array.  Nothing further
10718            to do.  */
10719         ;
10720       else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10721         {
10722           /* Make sure we dereference references so that all the code below
10723              feels like it's really handling the referenced value.  Wrapping
10724              types (for alignment) may be there, so make sure we strip them as
10725              well.  */
10726           argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10727         }
10728       else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10729                && VALUE_LVAL (argvec[0]) == lval_memory)
10730         argvec[0] = value_addr (argvec[0]);
10731
10732       type = ada_check_typedef (value_type (argvec[0]));
10733
10734       /* Ada allows us to implicitly dereference arrays when subscripting
10735          them.  So, if this is an array typedef (encoding use for array
10736          access types encoded as fat pointers), strip it now.  */
10737       if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10738         type = ada_typedef_target_type (type);
10739
10740       if (TYPE_CODE (type) == TYPE_CODE_PTR)
10741         {
10742           switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
10743             {
10744             case TYPE_CODE_FUNC:
10745               type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10746               break;
10747             case TYPE_CODE_ARRAY:
10748               break;
10749             case TYPE_CODE_STRUCT:
10750               if (noside != EVAL_AVOID_SIDE_EFFECTS)
10751                 argvec[0] = ada_value_ind (argvec[0]);
10752               type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10753               break;
10754             default:
10755               error (_("cannot subscript or call something of type `%s'"),
10756                      ada_type_name (value_type (argvec[0])));
10757               break;
10758             }
10759         }
10760
10761       switch (TYPE_CODE (type))
10762         {
10763         case TYPE_CODE_FUNC:
10764           if (noside == EVAL_AVOID_SIDE_EFFECTS)
10765             {
10766               if (TYPE_TARGET_TYPE (type) == NULL)
10767                 error_call_unknown_return_type (NULL);
10768               return allocate_value (TYPE_TARGET_TYPE (type));
10769             }
10770           return call_function_by_hand (argvec[0], NULL,
10771                                         gdb::make_array_view (argvec + 1,
10772                                                               nargs));
10773         case TYPE_CODE_INTERNAL_FUNCTION:
10774           if (noside == EVAL_AVOID_SIDE_EFFECTS)
10775             /* We don't know anything about what the internal
10776                function might return, but we have to return
10777                something.  */
10778             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10779                                not_lval);
10780           else
10781             return call_internal_function (exp->gdbarch, exp->language_defn,
10782                                            argvec[0], nargs, argvec + 1);
10783
10784         case TYPE_CODE_STRUCT:
10785           {
10786             int arity;
10787
10788             arity = ada_array_arity (type);
10789             type = ada_array_element_type (type, nargs);
10790             if (type == NULL)
10791               error (_("cannot subscript or call a record"));
10792             if (arity != nargs)
10793               error (_("wrong number of subscripts; expecting %d"), arity);
10794             if (noside == EVAL_AVOID_SIDE_EFFECTS)
10795               return value_zero (ada_aligned_type (type), lval_memory);
10796             return
10797               unwrap_value (ada_value_subscript
10798                             (argvec[0], nargs, argvec + 1));
10799           }
10800         case TYPE_CODE_ARRAY:
10801           if (noside == EVAL_AVOID_SIDE_EFFECTS)
10802             {
10803               type = ada_array_element_type (type, nargs);
10804               if (type == NULL)
10805                 error (_("element type of array unknown"));
10806               else
10807                 return value_zero (ada_aligned_type (type), lval_memory);
10808             }
10809           return
10810             unwrap_value (ada_value_subscript
10811                           (ada_coerce_to_simple_array (argvec[0]),
10812                            nargs, argvec + 1));
10813         case TYPE_CODE_PTR:     /* Pointer to array */
10814           if (noside == EVAL_AVOID_SIDE_EFFECTS)
10815             {
10816               type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10817               type = ada_array_element_type (type, nargs);
10818               if (type == NULL)
10819                 error (_("element type of array unknown"));
10820               else
10821                 return value_zero (ada_aligned_type (type), lval_memory);
10822             }
10823           return
10824             unwrap_value (ada_value_ptr_subscript (argvec[0],
10825                                                    nargs, argvec + 1));
10826
10827         default:
10828           error (_("Attempt to index or call something other than an "
10829                    "array or function"));
10830         }
10831
10832     case TERNOP_SLICE:
10833       {
10834         struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10835         struct value *low_bound_val =
10836           evaluate_subexp (NULL_TYPE, exp, pos, noside);
10837         struct value *high_bound_val =
10838           evaluate_subexp (NULL_TYPE, exp, pos, noside);
10839         LONGEST low_bound;
10840         LONGEST high_bound;
10841
10842         low_bound_val = coerce_ref (low_bound_val);
10843         high_bound_val = coerce_ref (high_bound_val);
10844         low_bound = value_as_long (low_bound_val);
10845         high_bound = value_as_long (high_bound_val);
10846
10847         if (noside == EVAL_SKIP)
10848           goto nosideret;
10849
10850         /* If this is a reference to an aligner type, then remove all
10851            the aligners.  */
10852         if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10853             && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10854           TYPE_TARGET_TYPE (value_type (array)) =
10855             ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
10856
10857         if (ada_is_constrained_packed_array_type (value_type (array)))
10858           error (_("cannot slice a packed array"));
10859
10860         /* If this is a reference to an array or an array lvalue,
10861            convert to a pointer.  */
10862         if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10863             || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
10864                 && VALUE_LVAL (array) == lval_memory))
10865           array = value_addr (array);
10866
10867         if (noside == EVAL_AVOID_SIDE_EFFECTS
10868             && ada_is_array_descriptor_type (ada_check_typedef
10869                                              (value_type (array))))
10870           return empty_array (ada_type_of_array (array, 0), low_bound,
10871                               high_bound);
10872
10873         array = ada_coerce_to_simple_array_ptr (array);
10874
10875         /* If we have more than one level of pointer indirection,
10876            dereference the value until we get only one level.  */
10877         while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10878                && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
10879                      == TYPE_CODE_PTR))
10880           array = value_ind (array);
10881
10882         /* Make sure we really do have an array type before going further,
10883            to avoid a SEGV when trying to get the index type or the target
10884            type later down the road if the debug info generated by
10885            the compiler is incorrect or incomplete.  */
10886         if (!ada_is_simple_array_type (value_type (array)))
10887           error (_("cannot take slice of non-array"));
10888
10889         if (TYPE_CODE (ada_check_typedef (value_type (array)))
10890             == TYPE_CODE_PTR)
10891           {
10892             struct type *type0 = ada_check_typedef (value_type (array));
10893
10894             if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10895               return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
10896             else
10897               {
10898                 struct type *arr_type0 =
10899                   to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
10900
10901                 return ada_value_slice_from_ptr (array, arr_type0,
10902                                                  longest_to_int (low_bound),
10903                                                  longest_to_int (high_bound));
10904               }
10905           }
10906         else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10907           return array;
10908         else if (high_bound < low_bound)
10909           return empty_array (value_type (array), low_bound, high_bound);
10910         else
10911           return ada_value_slice (array, longest_to_int (low_bound),
10912                                   longest_to_int (high_bound));
10913       }
10914
10915     case UNOP_IN_RANGE:
10916       (*pos) += 2;
10917       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10918       type = check_typedef (exp->elts[pc + 1].type);
10919
10920       if (noside == EVAL_SKIP)
10921         goto nosideret;
10922
10923       switch (TYPE_CODE (type))
10924         {
10925         default:
10926           lim_warning (_("Membership test incompletely implemented; "
10927                          "always returns true"));
10928           type = language_bool_type (exp->language_defn, exp->gdbarch);
10929           return value_from_longest (type, (LONGEST) 1);
10930
10931         case TYPE_CODE_RANGE:
10932           arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10933           arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
10934           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10935           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10936           type = language_bool_type (exp->language_defn, exp->gdbarch);
10937           return
10938             value_from_longest (type,
10939                                 (value_less (arg1, arg3)
10940                                  || value_equal (arg1, arg3))
10941                                 && (value_less (arg2, arg1)
10942                                     || value_equal (arg2, arg1)));
10943         }
10944
10945     case BINOP_IN_BOUNDS:
10946       (*pos) += 2;
10947       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10948       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10949
10950       if (noside == EVAL_SKIP)
10951         goto nosideret;
10952
10953       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10954         {
10955           type = language_bool_type (exp->language_defn, exp->gdbarch);
10956           return value_zero (type, not_lval);
10957         }
10958
10959       tem = longest_to_int (exp->elts[pc + 1].longconst);
10960
10961       type = ada_index_type (value_type (arg2), tem, "range");
10962       if (!type)
10963         type = value_type (arg1);
10964
10965       arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10966       arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
10967
10968       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10969       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10970       type = language_bool_type (exp->language_defn, exp->gdbarch);
10971       return
10972         value_from_longest (type,
10973                             (value_less (arg1, arg3)
10974                              || value_equal (arg1, arg3))
10975                             && (value_less (arg2, arg1)
10976                                 || value_equal (arg2, arg1)));
10977
10978     case TERNOP_IN_RANGE:
10979       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10980       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10981       arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10982
10983       if (noside == EVAL_SKIP)
10984         goto nosideret;
10985
10986       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10987       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10988       type = language_bool_type (exp->language_defn, exp->gdbarch);
10989       return
10990         value_from_longest (type,
10991                             (value_less (arg1, arg3)
10992                              || value_equal (arg1, arg3))
10993                             && (value_less (arg2, arg1)
10994                                 || value_equal (arg2, arg1)));
10995
10996     case OP_ATR_FIRST:
10997     case OP_ATR_LAST:
10998     case OP_ATR_LENGTH:
10999       {
11000         struct type *type_arg;
11001
11002         if (exp->elts[*pos].opcode == OP_TYPE)
11003           {
11004             evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11005             arg1 = NULL;
11006             type_arg = check_typedef (exp->elts[pc + 2].type);
11007           }
11008         else
11009           {
11010             arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11011             type_arg = NULL;
11012           }
11013
11014         if (exp->elts[*pos].opcode != OP_LONG)
11015           error (_("Invalid operand to '%s"), ada_attribute_name (op));
11016         tem = longest_to_int (exp->elts[*pos + 2].longconst);
11017         *pos += 4;
11018
11019         if (noside == EVAL_SKIP)
11020           goto nosideret;
11021         else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11022           {
11023             if (type_arg == NULL)
11024               type_arg = value_type (arg1);
11025
11026             if (ada_is_constrained_packed_array_type (type_arg))
11027               type_arg = decode_constrained_packed_array_type (type_arg);
11028
11029             if (!discrete_type_p (type_arg))
11030               {
11031                 switch (op)
11032                   {
11033                   default:          /* Should never happen.  */
11034                     error (_("unexpected attribute encountered"));
11035                   case OP_ATR_FIRST:
11036                   case OP_ATR_LAST:
11037                     type_arg = ada_index_type (type_arg, tem,
11038                                                ada_attribute_name (op));
11039                     break;
11040                   case OP_ATR_LENGTH:
11041                     type_arg = builtin_type (exp->gdbarch)->builtin_int;
11042                     break;
11043                   }
11044               }
11045
11046             return value_zero (type_arg, not_lval);
11047           }
11048         else if (type_arg == NULL)
11049           {
11050             arg1 = ada_coerce_ref (arg1);
11051
11052             if (ada_is_constrained_packed_array_type (value_type (arg1)))
11053               arg1 = ada_coerce_to_simple_array (arg1);
11054
11055             if (op == OP_ATR_LENGTH)
11056               type = builtin_type (exp->gdbarch)->builtin_int;
11057             else
11058               {
11059                 type = ada_index_type (value_type (arg1), tem,
11060                                        ada_attribute_name (op));
11061                 if (type == NULL)
11062                   type = builtin_type (exp->gdbarch)->builtin_int;
11063               }
11064
11065             switch (op)
11066               {
11067               default:          /* Should never happen.  */
11068                 error (_("unexpected attribute encountered"));
11069               case OP_ATR_FIRST:
11070                 return value_from_longest
11071                         (type, ada_array_bound (arg1, tem, 0));
11072               case OP_ATR_LAST:
11073                 return value_from_longest
11074                         (type, ada_array_bound (arg1, tem, 1));
11075               case OP_ATR_LENGTH:
11076                 return value_from_longest
11077                         (type, ada_array_length (arg1, tem));
11078               }
11079           }
11080         else if (discrete_type_p (type_arg))
11081           {
11082             struct type *range_type;
11083             const char *name = ada_type_name (type_arg);
11084
11085             range_type = NULL;
11086             if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
11087               range_type = to_fixed_range_type (type_arg, NULL);
11088             if (range_type == NULL)
11089               range_type = type_arg;
11090             switch (op)
11091               {
11092               default:
11093                 error (_("unexpected attribute encountered"));
11094               case OP_ATR_FIRST:
11095                 return value_from_longest 
11096                   (range_type, ada_discrete_type_low_bound (range_type));
11097               case OP_ATR_LAST:
11098                 return value_from_longest
11099                   (range_type, ada_discrete_type_high_bound (range_type));
11100               case OP_ATR_LENGTH:
11101                 error (_("the 'length attribute applies only to array types"));
11102               }
11103           }
11104         else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
11105           error (_("unimplemented type attribute"));
11106         else
11107           {
11108             LONGEST low, high;
11109
11110             if (ada_is_constrained_packed_array_type (type_arg))
11111               type_arg = decode_constrained_packed_array_type (type_arg);
11112
11113             if (op == OP_ATR_LENGTH)
11114               type = builtin_type (exp->gdbarch)->builtin_int;
11115             else
11116               {
11117                 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11118                 if (type == NULL)
11119                   type = builtin_type (exp->gdbarch)->builtin_int;
11120               }
11121
11122             switch (op)
11123               {
11124               default:
11125                 error (_("unexpected attribute encountered"));
11126               case OP_ATR_FIRST:
11127                 low = ada_array_bound_from_type (type_arg, tem, 0);
11128                 return value_from_longest (type, low);
11129               case OP_ATR_LAST:
11130                 high = ada_array_bound_from_type (type_arg, tem, 1);
11131                 return value_from_longest (type, high);
11132               case OP_ATR_LENGTH:
11133                 low = ada_array_bound_from_type (type_arg, tem, 0);
11134                 high = ada_array_bound_from_type (type_arg, tem, 1);
11135                 return value_from_longest (type, high - low + 1);
11136               }
11137           }
11138       }
11139
11140     case OP_ATR_TAG:
11141       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11142       if (noside == EVAL_SKIP)
11143         goto nosideret;
11144
11145       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11146         return value_zero (ada_tag_type (arg1), not_lval);
11147
11148       return ada_value_tag (arg1);
11149
11150     case OP_ATR_MIN:
11151     case OP_ATR_MAX:
11152       evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11153       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11154       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11155       if (noside == EVAL_SKIP)
11156         goto nosideret;
11157       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11158         return value_zero (value_type (arg1), not_lval);
11159       else
11160         {
11161           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11162           return value_binop (arg1, arg2,
11163                               op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11164         }
11165
11166     case OP_ATR_MODULUS:
11167       {
11168         struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
11169
11170         evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11171         if (noside == EVAL_SKIP)
11172           goto nosideret;
11173
11174         if (!ada_is_modular_type (type_arg))
11175           error (_("'modulus must be applied to modular type"));
11176
11177         return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11178                                    ada_modulus (type_arg));
11179       }
11180
11181
11182     case OP_ATR_POS:
11183       evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11184       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11185       if (noside == EVAL_SKIP)
11186         goto nosideret;
11187       type = builtin_type (exp->gdbarch)->builtin_int;
11188       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11189         return value_zero (type, not_lval);
11190       else
11191         return value_pos_atr (type, arg1);
11192
11193     case OP_ATR_SIZE:
11194       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11195       type = value_type (arg1);
11196
11197       /* If the argument is a reference, then dereference its type, since
11198          the user is really asking for the size of the actual object,
11199          not the size of the pointer.  */
11200       if (TYPE_CODE (type) == TYPE_CODE_REF)
11201         type = TYPE_TARGET_TYPE (type);
11202
11203       if (noside == EVAL_SKIP)
11204         goto nosideret;
11205       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11206         return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
11207       else
11208         return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
11209                                    TARGET_CHAR_BIT * TYPE_LENGTH (type));
11210
11211     case OP_ATR_VAL:
11212       evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11213       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11214       type = exp->elts[pc + 2].type;
11215       if (noside == EVAL_SKIP)
11216         goto nosideret;
11217       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11218         return value_zero (type, not_lval);
11219       else
11220         return value_val_atr (type, arg1);
11221
11222     case BINOP_EXP:
11223       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11224       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11225       if (noside == EVAL_SKIP)
11226         goto nosideret;
11227       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11228         return value_zero (value_type (arg1), not_lval);
11229       else
11230         {
11231           /* For integer exponentiation operations,
11232              only promote the first argument.  */
11233           if (is_integral_type (value_type (arg2)))
11234             unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11235           else
11236             binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11237
11238           return value_binop (arg1, arg2, op);
11239         }
11240
11241     case UNOP_PLUS:
11242       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11243       if (noside == EVAL_SKIP)
11244         goto nosideret;
11245       else
11246         return arg1;
11247
11248     case UNOP_ABS:
11249       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11250       if (noside == EVAL_SKIP)
11251         goto nosideret;
11252       unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11253       if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
11254         return value_neg (arg1);
11255       else
11256         return arg1;
11257
11258     case UNOP_IND:
11259       preeval_pos = *pos;
11260       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11261       if (noside == EVAL_SKIP)
11262         goto nosideret;
11263       type = ada_check_typedef (value_type (arg1));
11264       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11265         {
11266           if (ada_is_array_descriptor_type (type))
11267             /* GDB allows dereferencing GNAT array descriptors.  */
11268             {
11269               struct type *arrType = ada_type_of_array (arg1, 0);
11270
11271               if (arrType == NULL)
11272                 error (_("Attempt to dereference null array pointer."));
11273               return value_at_lazy (arrType, 0);
11274             }
11275           else if (TYPE_CODE (type) == TYPE_CODE_PTR
11276                    || TYPE_CODE (type) == TYPE_CODE_REF
11277                    /* In C you can dereference an array to get the 1st elt.  */
11278                    || TYPE_CODE (type) == TYPE_CODE_ARRAY)
11279             {
11280             /* As mentioned in the OP_VAR_VALUE case, tagged types can
11281                only be determined by inspecting the object's tag.
11282                This means that we need to evaluate completely the
11283                expression in order to get its type.  */
11284
11285               if ((TYPE_CODE (type) == TYPE_CODE_REF
11286                    || TYPE_CODE (type) == TYPE_CODE_PTR)
11287                   && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11288                 {
11289                   arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11290                                           EVAL_NORMAL);
11291                   type = value_type (ada_value_ind (arg1));
11292                 }
11293               else
11294                 {
11295                   type = to_static_fixed_type
11296                     (ada_aligned_type
11297                      (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11298                 }
11299               ada_ensure_varsize_limit (type);
11300               return value_zero (type, lval_memory);
11301             }
11302           else if (TYPE_CODE (type) == TYPE_CODE_INT)
11303             {
11304               /* GDB allows dereferencing an int.  */
11305               if (expect_type == NULL)
11306                 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11307                                    lval_memory);
11308               else
11309                 {
11310                   expect_type = 
11311                     to_static_fixed_type (ada_aligned_type (expect_type));
11312                   return value_zero (expect_type, lval_memory);
11313                 }
11314             }
11315           else
11316             error (_("Attempt to take contents of a non-pointer value."));
11317         }
11318       arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
11319       type = ada_check_typedef (value_type (arg1));
11320
11321       if (TYPE_CODE (type) == TYPE_CODE_INT)
11322           /* GDB allows dereferencing an int.  If we were given
11323              the expect_type, then use that as the target type.
11324              Otherwise, assume that the target type is an int.  */
11325         {
11326           if (expect_type != NULL)
11327             return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11328                                               arg1));
11329           else
11330             return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11331                                   (CORE_ADDR) value_as_address (arg1));
11332         }
11333
11334       if (ada_is_array_descriptor_type (type))
11335         /* GDB allows dereferencing GNAT array descriptors.  */
11336         return ada_coerce_to_simple_array (arg1);
11337       else
11338         return ada_value_ind (arg1);
11339
11340     case STRUCTOP_STRUCT:
11341       tem = longest_to_int (exp->elts[pc + 1].longconst);
11342       (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
11343       preeval_pos = *pos;
11344       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11345       if (noside == EVAL_SKIP)
11346         goto nosideret;
11347       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11348         {
11349           struct type *type1 = value_type (arg1);
11350
11351           if (ada_is_tagged_type (type1, 1))
11352             {
11353               type = ada_lookup_struct_elt_type (type1,
11354                                                  &exp->elts[pc + 2].string,
11355                                                  1, 1);
11356
11357               /* If the field is not found, check if it exists in the
11358                  extension of this object's type. This means that we
11359                  need to evaluate completely the expression.  */
11360
11361               if (type == NULL)
11362                 {
11363                   arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11364                                           EVAL_NORMAL);
11365                   arg1 = ada_value_struct_elt (arg1,
11366                                                &exp->elts[pc + 2].string,
11367                                                0);
11368                   arg1 = unwrap_value (arg1);
11369                   type = value_type (ada_to_fixed_value (arg1));
11370                 }
11371             }
11372           else
11373             type =
11374               ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
11375                                           0);
11376
11377           return value_zero (ada_aligned_type (type), lval_memory);
11378         }
11379       else
11380         {
11381           arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11382           arg1 = unwrap_value (arg1);
11383           return ada_to_fixed_value (arg1);
11384         }
11385
11386     case OP_TYPE:
11387       /* The value is not supposed to be used.  This is here to make it
11388          easier to accommodate expressions that contain types.  */
11389       (*pos) += 2;
11390       if (noside == EVAL_SKIP)
11391         goto nosideret;
11392       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11393         return allocate_value (exp->elts[pc + 1].type);
11394       else
11395         error (_("Attempt to use a type name as an expression"));
11396
11397     case OP_AGGREGATE:
11398     case OP_CHOICES:
11399     case OP_OTHERS:
11400     case OP_DISCRETE_RANGE:
11401     case OP_POSITIONAL:
11402     case OP_NAME:
11403       if (noside == EVAL_NORMAL)
11404         switch (op) 
11405           {
11406           case OP_NAME:
11407             error (_("Undefined name, ambiguous name, or renaming used in "
11408                      "component association: %s."), &exp->elts[pc+2].string);
11409           case OP_AGGREGATE:
11410             error (_("Aggregates only allowed on the right of an assignment"));
11411           default:
11412             internal_error (__FILE__, __LINE__,
11413                             _("aggregate apparently mangled"));
11414           }
11415
11416       ada_forward_operator_length (exp, pc, &oplen, &nargs);
11417       *pos += oplen - 1;
11418       for (tem = 0; tem < nargs; tem += 1) 
11419         ada_evaluate_subexp (NULL, exp, pos, noside);
11420       goto nosideret;
11421     }
11422
11423 nosideret:
11424   return eval_skip_value (exp);
11425 }
11426 \f
11427
11428                                 /* Fixed point */
11429
11430 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11431    type name that encodes the 'small and 'delta information.
11432    Otherwise, return NULL.  */
11433
11434 static const char *
11435 fixed_type_info (struct type *type)
11436 {
11437   const char *name = ada_type_name (type);
11438   enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11439
11440   if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11441     {
11442       const char *tail = strstr (name, "___XF_");
11443
11444       if (tail == NULL)
11445         return NULL;
11446       else
11447         return tail + 5;
11448     }
11449   else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11450     return fixed_type_info (TYPE_TARGET_TYPE (type));
11451   else
11452     return NULL;
11453 }
11454
11455 /* Returns non-zero iff TYPE represents an Ada fixed-point type.  */
11456
11457 int
11458 ada_is_fixed_point_type (struct type *type)
11459 {
11460   return fixed_type_info (type) != NULL;
11461 }
11462
11463 /* Return non-zero iff TYPE represents a System.Address type.  */
11464
11465 int
11466 ada_is_system_address_type (struct type *type)
11467 {
11468   return (TYPE_NAME (type)
11469           && strcmp (TYPE_NAME (type), "system__address") == 0);
11470 }
11471
11472 /* Assuming that TYPE is the representation of an Ada fixed-point
11473    type, return the target floating-point type to be used to represent
11474    of this type during internal computation.  */
11475
11476 static struct type *
11477 ada_scaling_type (struct type *type)
11478 {
11479   return builtin_type (get_type_arch (type))->builtin_long_double;
11480 }
11481
11482 /* Assuming that TYPE is the representation of an Ada fixed-point
11483    type, return its delta, or NULL if the type is malformed and the
11484    delta cannot be determined.  */
11485
11486 struct value *
11487 ada_delta (struct type *type)
11488 {
11489   const char *encoding = fixed_type_info (type);
11490   struct type *scale_type = ada_scaling_type (type);
11491
11492   long long num, den;
11493
11494   if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11495     return nullptr;
11496   else
11497     return value_binop (value_from_longest (scale_type, num),
11498                         value_from_longest (scale_type, den), BINOP_DIV);
11499 }
11500
11501 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11502    factor ('SMALL value) associated with the type.  */
11503
11504 struct value *
11505 ada_scaling_factor (struct type *type)
11506 {
11507   const char *encoding = fixed_type_info (type);
11508   struct type *scale_type = ada_scaling_type (type);
11509
11510   long long num0, den0, num1, den1;
11511   int n;
11512
11513   n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
11514               &num0, &den0, &num1, &den1);
11515
11516   if (n < 2)
11517     return value_from_longest (scale_type, 1);
11518   else if (n == 4)
11519     return value_binop (value_from_longest (scale_type, num1),
11520                         value_from_longest (scale_type, den1), BINOP_DIV);
11521   else
11522     return value_binop (value_from_longest (scale_type, num0),
11523                         value_from_longest (scale_type, den0), BINOP_DIV);
11524 }
11525
11526 \f
11527
11528                                 /* Range types */
11529
11530 /* Scan STR beginning at position K for a discriminant name, and
11531    return the value of that discriminant field of DVAL in *PX.  If
11532    PNEW_K is not null, put the position of the character beyond the
11533    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
11534    not alter *PX and *PNEW_K if unsuccessful.  */
11535
11536 static int
11537 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11538                     int *pnew_k)
11539 {
11540   static char *bound_buffer = NULL;
11541   static size_t bound_buffer_len = 0;
11542   const char *pstart, *pend, *bound;
11543   struct value *bound_val;
11544
11545   if (dval == NULL || str == NULL || str[k] == '\0')
11546     return 0;
11547
11548   pstart = str + k;
11549   pend = strstr (pstart, "__");
11550   if (pend == NULL)
11551     {
11552       bound = pstart;
11553       k += strlen (bound);
11554     }
11555   else
11556     {
11557       int len = pend - pstart;
11558
11559       /* Strip __ and beyond.  */
11560       GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11561       strncpy (bound_buffer, pstart, len);
11562       bound_buffer[len] = '\0';
11563
11564       bound = bound_buffer;
11565       k = pend - str;
11566     }
11567
11568   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11569   if (bound_val == NULL)
11570     return 0;
11571
11572   *px = value_as_long (bound_val);
11573   if (pnew_k != NULL)
11574     *pnew_k = k;
11575   return 1;
11576 }
11577
11578 /* Value of variable named NAME in the current environment.  If
11579    no such variable found, then if ERR_MSG is null, returns 0, and
11580    otherwise causes an error with message ERR_MSG.  */
11581
11582 static struct value *
11583 get_var_value (const char *name, const char *err_msg)
11584 {
11585   lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
11586
11587   std::vector<struct block_symbol> syms;
11588   int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11589                                              get_selected_block (0),
11590                                              VAR_DOMAIN, &syms, 1);
11591
11592   if (nsyms != 1)
11593     {
11594       if (err_msg == NULL)
11595         return 0;
11596       else
11597         error (("%s"), err_msg);
11598     }
11599
11600   return value_of_variable (syms[0].symbol, syms[0].block);
11601 }
11602
11603 /* Value of integer variable named NAME in the current environment.
11604    If no such variable is found, returns false.  Otherwise, sets VALUE
11605    to the variable's value and returns true.  */
11606
11607 bool
11608 get_int_var_value (const char *name, LONGEST &value)
11609 {
11610   struct value *var_val = get_var_value (name, 0);
11611
11612   if (var_val == 0)
11613     return false;
11614
11615   value = value_as_long (var_val);
11616   return true;
11617 }
11618
11619
11620 /* Return a range type whose base type is that of the range type named
11621    NAME in the current environment, and whose bounds are calculated
11622    from NAME according to the GNAT range encoding conventions.
11623    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
11624    corresponding range type from debug information; fall back to using it
11625    if symbol lookup fails.  If a new type must be created, allocate it
11626    like ORIG_TYPE was.  The bounds information, in general, is encoded
11627    in NAME, the base type given in the named range type.  */
11628
11629 static struct type *
11630 to_fixed_range_type (struct type *raw_type, struct value *dval)
11631 {
11632   const char *name;
11633   struct type *base_type;
11634   const char *subtype_info;
11635
11636   gdb_assert (raw_type != NULL);
11637   gdb_assert (TYPE_NAME (raw_type) != NULL);
11638
11639   if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
11640     base_type = TYPE_TARGET_TYPE (raw_type);
11641   else
11642     base_type = raw_type;
11643
11644   name = TYPE_NAME (raw_type);
11645   subtype_info = strstr (name, "___XD");
11646   if (subtype_info == NULL)
11647     {
11648       LONGEST L = ada_discrete_type_low_bound (raw_type);
11649       LONGEST U = ada_discrete_type_high_bound (raw_type);
11650
11651       if (L < INT_MIN || U > INT_MAX)
11652         return raw_type;
11653       else
11654         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11655                                          L, U);
11656     }
11657   else
11658     {
11659       static char *name_buf = NULL;
11660       static size_t name_len = 0;
11661       int prefix_len = subtype_info - name;
11662       LONGEST L, U;
11663       struct type *type;
11664       const char *bounds_str;
11665       int n;
11666
11667       GROW_VECT (name_buf, name_len, prefix_len + 5);
11668       strncpy (name_buf, name, prefix_len);
11669       name_buf[prefix_len] = '\0';
11670
11671       subtype_info += 5;
11672       bounds_str = strchr (subtype_info, '_');
11673       n = 1;
11674
11675       if (*subtype_info == 'L')
11676         {
11677           if (!ada_scan_number (bounds_str, n, &L, &n)
11678               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11679             return raw_type;
11680           if (bounds_str[n] == '_')
11681             n += 2;
11682           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
11683             n += 1;
11684           subtype_info += 1;
11685         }
11686       else
11687         {
11688           strcpy (name_buf + prefix_len, "___L");
11689           if (!get_int_var_value (name_buf, L))
11690             {
11691               lim_warning (_("Unknown lower bound, using 1."));
11692               L = 1;
11693             }
11694         }
11695
11696       if (*subtype_info == 'U')
11697         {
11698           if (!ada_scan_number (bounds_str, n, &U, &n)
11699               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11700             return raw_type;
11701         }
11702       else
11703         {
11704           strcpy (name_buf + prefix_len, "___U");
11705           if (!get_int_var_value (name_buf, U))
11706             {
11707               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11708               U = L;
11709             }
11710         }
11711
11712       type = create_static_range_type (alloc_type_copy (raw_type),
11713                                        base_type, L, U);
11714       /* create_static_range_type alters the resulting type's length
11715          to match the size of the base_type, which is not what we want.
11716          Set it back to the original range type's length.  */
11717       TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11718       TYPE_NAME (type) = name;
11719       return type;
11720     }
11721 }
11722
11723 /* True iff NAME is the name of a range type.  */
11724
11725 int
11726 ada_is_range_type_name (const char *name)
11727 {
11728   return (name != NULL && strstr (name, "___XD"));
11729 }
11730 \f
11731
11732                                 /* Modular types */
11733
11734 /* True iff TYPE is an Ada modular type.  */
11735
11736 int
11737 ada_is_modular_type (struct type *type)
11738 {
11739   struct type *subranged_type = get_base_type (type);
11740
11741   return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
11742           && TYPE_CODE (subranged_type) == TYPE_CODE_INT
11743           && TYPE_UNSIGNED (subranged_type));
11744 }
11745
11746 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
11747
11748 ULONGEST
11749 ada_modulus (struct type *type)
11750 {
11751   return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
11752 }
11753 \f
11754
11755 /* Ada exception catchpoint support:
11756    ---------------------------------
11757
11758    We support 3 kinds of exception catchpoints:
11759      . catchpoints on Ada exceptions
11760      . catchpoints on unhandled Ada exceptions
11761      . catchpoints on failed assertions
11762
11763    Exceptions raised during failed assertions, or unhandled exceptions
11764    could perfectly be caught with the general catchpoint on Ada exceptions.
11765    However, we can easily differentiate these two special cases, and having
11766    the option to distinguish these two cases from the rest can be useful
11767    to zero-in on certain situations.
11768
11769    Exception catchpoints are a specialized form of breakpoint,
11770    since they rely on inserting breakpoints inside known routines
11771    of the GNAT runtime.  The implementation therefore uses a standard
11772    breakpoint structure of the BP_BREAKPOINT type, but with its own set
11773    of breakpoint_ops.
11774
11775    Support in the runtime for exception catchpoints have been changed
11776    a few times already, and these changes affect the implementation
11777    of these catchpoints.  In order to be able to support several
11778    variants of the runtime, we use a sniffer that will determine
11779    the runtime variant used by the program being debugged.  */
11780
11781 /* Ada's standard exceptions.
11782
11783    The Ada 83 standard also defined Numeric_Error.  But there so many
11784    situations where it was unclear from the Ada 83 Reference Manual
11785    (RM) whether Constraint_Error or Numeric_Error should be raised,
11786    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11787    Interpretation saying that anytime the RM says that Numeric_Error
11788    should be raised, the implementation may raise Constraint_Error.
11789    Ada 95 went one step further and pretty much removed Numeric_Error
11790    from the list of standard exceptions (it made it a renaming of
11791    Constraint_Error, to help preserve compatibility when compiling
11792    an Ada83 compiler). As such, we do not include Numeric_Error from
11793    this list of standard exceptions.  */
11794
11795 static const char *standard_exc[] = {
11796   "constraint_error",
11797   "program_error",
11798   "storage_error",
11799   "tasking_error"
11800 };
11801
11802 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11803
11804 /* A structure that describes how to support exception catchpoints
11805    for a given executable.  */
11806
11807 struct exception_support_info
11808 {
11809    /* The name of the symbol to break on in order to insert
11810       a catchpoint on exceptions.  */
11811    const char *catch_exception_sym;
11812
11813    /* The name of the symbol to break on in order to insert
11814       a catchpoint on unhandled exceptions.  */
11815    const char *catch_exception_unhandled_sym;
11816
11817    /* The name of the symbol to break on in order to insert
11818       a catchpoint on failed assertions.  */
11819    const char *catch_assert_sym;
11820
11821    /* The name of the symbol to break on in order to insert
11822       a catchpoint on exception handling.  */
11823    const char *catch_handlers_sym;
11824
11825    /* Assuming that the inferior just triggered an unhandled exception
11826       catchpoint, this function is responsible for returning the address
11827       in inferior memory where the name of that exception is stored.
11828       Return zero if the address could not be computed.  */
11829    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11830 };
11831
11832 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11833 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11834
11835 /* The following exception support info structure describes how to
11836    implement exception catchpoints with the latest version of the
11837    Ada runtime (as of 2019-08-??).  */
11838
11839 static const struct exception_support_info default_exception_support_info =
11840 {
11841   "__gnat_debug_raise_exception", /* catch_exception_sym */
11842   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11843   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11844   "__gnat_begin_handler_v1", /* catch_handlers_sym */
11845   ada_unhandled_exception_name_addr
11846 };
11847
11848 /* The following exception support info structure describes how to
11849    implement exception catchpoints with an earlier version of the
11850    Ada runtime (as of 2007-03-06) using v0 of the EH ABI.  */
11851
11852 static const struct exception_support_info exception_support_info_v0 =
11853 {
11854   "__gnat_debug_raise_exception", /* catch_exception_sym */
11855   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11856   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11857   "__gnat_begin_handler", /* catch_handlers_sym */
11858   ada_unhandled_exception_name_addr
11859 };
11860
11861 /* The following exception support info structure describes how to
11862    implement exception catchpoints with a slightly older version
11863    of the Ada runtime.  */
11864
11865 static const struct exception_support_info exception_support_info_fallback =
11866 {
11867   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11868   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11869   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
11870   "__gnat_begin_handler", /* catch_handlers_sym */
11871   ada_unhandled_exception_name_addr_from_raise
11872 };
11873
11874 /* Return nonzero if we can detect the exception support routines
11875    described in EINFO.
11876
11877    This function errors out if an abnormal situation is detected
11878    (for instance, if we find the exception support routines, but
11879    that support is found to be incomplete).  */
11880
11881 static int
11882 ada_has_this_exception_support (const struct exception_support_info *einfo)
11883 {
11884   struct symbol *sym;
11885
11886   /* The symbol we're looking up is provided by a unit in the GNAT runtime
11887      that should be compiled with debugging information.  As a result, we
11888      expect to find that symbol in the symtabs.  */
11889
11890   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11891   if (sym == NULL)
11892     {
11893       /* Perhaps we did not find our symbol because the Ada runtime was
11894          compiled without debugging info, or simply stripped of it.
11895          It happens on some GNU/Linux distributions for instance, where
11896          users have to install a separate debug package in order to get
11897          the runtime's debugging info.  In that situation, let the user
11898          know why we cannot insert an Ada exception catchpoint.
11899
11900          Note: Just for the purpose of inserting our Ada exception
11901          catchpoint, we could rely purely on the associated minimal symbol.
11902          But we would be operating in degraded mode anyway, since we are
11903          still lacking the debugging info needed later on to extract
11904          the name of the exception being raised (this name is printed in
11905          the catchpoint message, and is also used when trying to catch
11906          a specific exception).  We do not handle this case for now.  */
11907       struct bound_minimal_symbol msym
11908         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11909
11910       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11911         error (_("Your Ada runtime appears to be missing some debugging "
11912                  "information.\nCannot insert Ada exception catchpoint "
11913                  "in this configuration."));
11914
11915       return 0;
11916     }
11917
11918   /* Make sure that the symbol we found corresponds to a function.  */
11919
11920   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11921     {
11922       error (_("Symbol \"%s\" is not a function (class = %d)"),
11923              sym->linkage_name (), SYMBOL_CLASS (sym));
11924       return 0;
11925     }
11926
11927   sym = standard_lookup (einfo->catch_handlers_sym, NULL, VAR_DOMAIN);
11928   if (sym == NULL)
11929     {
11930       struct bound_minimal_symbol msym
11931         = lookup_minimal_symbol (einfo->catch_handlers_sym, NULL, NULL);
11932
11933       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11934         error (_("Your Ada runtime appears to be missing some debugging "
11935                  "information.\nCannot insert Ada exception catchpoint "
11936                  "in this configuration."));
11937
11938       return 0;
11939     }
11940
11941   /* Make sure that the symbol we found corresponds to a function.  */
11942
11943   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11944     {
11945       error (_("Symbol \"%s\" is not a function (class = %d)"),
11946              sym->linkage_name (), SYMBOL_CLASS (sym));
11947       return 0;
11948     }
11949
11950   return 1;
11951 }
11952
11953 /* Inspect the Ada runtime and determine which exception info structure
11954    should be used to provide support for exception catchpoints.
11955
11956    This function will always set the per-inferior exception_info,
11957    or raise an error.  */
11958
11959 static void
11960 ada_exception_support_info_sniffer (void)
11961 {
11962   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11963
11964   /* If the exception info is already known, then no need to recompute it.  */
11965   if (data->exception_info != NULL)
11966     return;
11967
11968   /* Check the latest (default) exception support info.  */
11969   if (ada_has_this_exception_support (&default_exception_support_info))
11970     {
11971       data->exception_info = &default_exception_support_info;
11972       return;
11973     }
11974
11975   /* Try the v0 exception suport info.  */
11976   if (ada_has_this_exception_support (&exception_support_info_v0))
11977     {
11978       data->exception_info = &exception_support_info_v0;
11979       return;
11980     }
11981
11982   /* Try our fallback exception suport info.  */
11983   if (ada_has_this_exception_support (&exception_support_info_fallback))
11984     {
11985       data->exception_info = &exception_support_info_fallback;
11986       return;
11987     }
11988
11989   /* Sometimes, it is normal for us to not be able to find the routine
11990      we are looking for.  This happens when the program is linked with
11991      the shared version of the GNAT runtime, and the program has not been
11992      started yet.  Inform the user of these two possible causes if
11993      applicable.  */
11994
11995   if (ada_update_initial_language (language_unknown) != language_ada)
11996     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
11997
11998   /* If the symbol does not exist, then check that the program is
11999      already started, to make sure that shared libraries have been
12000      loaded.  If it is not started, this may mean that the symbol is
12001      in a shared library.  */
12002
12003   if (inferior_ptid.pid () == 0)
12004     error (_("Unable to insert catchpoint. Try to start the program first."));
12005
12006   /* At this point, we know that we are debugging an Ada program and
12007      that the inferior has been started, but we still are not able to
12008      find the run-time symbols.  That can mean that we are in
12009      configurable run time mode, or that a-except as been optimized
12010      out by the linker...  In any case, at this point it is not worth
12011      supporting this feature.  */
12012
12013   error (_("Cannot insert Ada exception catchpoints in this configuration."));
12014 }
12015
12016 /* True iff FRAME is very likely to be that of a function that is
12017    part of the runtime system.  This is all very heuristic, but is
12018    intended to be used as advice as to what frames are uninteresting
12019    to most users.  */
12020
12021 static int
12022 is_known_support_routine (struct frame_info *frame)
12023 {
12024   enum language func_lang;
12025   int i;
12026   const char *fullname;
12027
12028   /* If this code does not have any debugging information (no symtab),
12029      This cannot be any user code.  */
12030
12031   symtab_and_line sal = find_frame_sal (frame);
12032   if (sal.symtab == NULL)
12033     return 1;
12034
12035   /* If there is a symtab, but the associated source file cannot be
12036      located, then assume this is not user code:  Selecting a frame
12037      for which we cannot display the code would not be very helpful
12038      for the user.  This should also take care of case such as VxWorks
12039      where the kernel has some debugging info provided for a few units.  */
12040
12041   fullname = symtab_to_fullname (sal.symtab);
12042   if (access (fullname, R_OK) != 0)
12043     return 1;
12044
12045   /* Check the unit filename against the Ada runtime file naming.
12046      We also check the name of the objfile against the name of some
12047      known system libraries that sometimes come with debugging info
12048      too.  */
12049
12050   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12051     {
12052       re_comp (known_runtime_file_name_patterns[i]);
12053       if (re_exec (lbasename (sal.symtab->filename)))
12054         return 1;
12055       if (SYMTAB_OBJFILE (sal.symtab) != NULL
12056           && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
12057         return 1;
12058     }
12059
12060   /* Check whether the function is a GNAT-generated entity.  */
12061
12062   gdb::unique_xmalloc_ptr<char> func_name
12063     = find_frame_funname (frame, &func_lang, NULL);
12064   if (func_name == NULL)
12065     return 1;
12066
12067   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12068     {
12069       re_comp (known_auxiliary_function_name_patterns[i]);
12070       if (re_exec (func_name.get ()))
12071         return 1;
12072     }
12073
12074   return 0;
12075 }
12076
12077 /* Find the first frame that contains debugging information and that is not
12078    part of the Ada run-time, starting from FI and moving upward.  */
12079
12080 void
12081 ada_find_printable_frame (struct frame_info *fi)
12082 {
12083   for (; fi != NULL; fi = get_prev_frame (fi))
12084     {
12085       if (!is_known_support_routine (fi))
12086         {
12087           select_frame (fi);
12088           break;
12089         }
12090     }
12091
12092 }
12093
12094 /* Assuming that the inferior just triggered an unhandled exception
12095    catchpoint, return the address in inferior memory where the name
12096    of the exception is stored.
12097    
12098    Return zero if the address could not be computed.  */
12099
12100 static CORE_ADDR
12101 ada_unhandled_exception_name_addr (void)
12102 {
12103   return parse_and_eval_address ("e.full_name");
12104 }
12105
12106 /* Same as ada_unhandled_exception_name_addr, except that this function
12107    should be used when the inferior uses an older version of the runtime,
12108    where the exception name needs to be extracted from a specific frame
12109    several frames up in the callstack.  */
12110
12111 static CORE_ADDR
12112 ada_unhandled_exception_name_addr_from_raise (void)
12113 {
12114   int frame_level;
12115   struct frame_info *fi;
12116   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12117
12118   /* To determine the name of this exception, we need to select
12119      the frame corresponding to RAISE_SYM_NAME.  This frame is
12120      at least 3 levels up, so we simply skip the first 3 frames
12121      without checking the name of their associated function.  */
12122   fi = get_current_frame ();
12123   for (frame_level = 0; frame_level < 3; frame_level += 1)
12124     if (fi != NULL)
12125       fi = get_prev_frame (fi); 
12126
12127   while (fi != NULL)
12128     {
12129       enum language func_lang;
12130
12131       gdb::unique_xmalloc_ptr<char> func_name
12132         = find_frame_funname (fi, &func_lang, NULL);
12133       if (func_name != NULL)
12134         {
12135           if (strcmp (func_name.get (),
12136                       data->exception_info->catch_exception_sym) == 0)
12137             break; /* We found the frame we were looking for...  */
12138         }
12139       fi = get_prev_frame (fi);
12140     }
12141
12142   if (fi == NULL)
12143     return 0;
12144
12145   select_frame (fi);
12146   return parse_and_eval_address ("id.full_name");
12147 }
12148
12149 /* Assuming the inferior just triggered an Ada exception catchpoint
12150    (of any type), return the address in inferior memory where the name
12151    of the exception is stored, if applicable.
12152
12153    Assumes the selected frame is the current frame.
12154
12155    Return zero if the address could not be computed, or if not relevant.  */
12156
12157 static CORE_ADDR
12158 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
12159                            struct breakpoint *b)
12160 {
12161   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12162
12163   switch (ex)
12164     {
12165       case ada_catch_exception:
12166         return (parse_and_eval_address ("e.full_name"));
12167         break;
12168
12169       case ada_catch_exception_unhandled:
12170         return data->exception_info->unhandled_exception_name_addr ();
12171         break;
12172
12173       case ada_catch_handlers:
12174         return 0;  /* The runtimes does not provide access to the exception
12175                       name.  */
12176         break;
12177
12178       case ada_catch_assert:
12179         return 0;  /* Exception name is not relevant in this case.  */
12180         break;
12181
12182       default:
12183         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12184         break;
12185     }
12186
12187   return 0; /* Should never be reached.  */
12188 }
12189
12190 /* Assuming the inferior is stopped at an exception catchpoint,
12191    return the message which was associated to the exception, if
12192    available.  Return NULL if the message could not be retrieved.
12193
12194    Note: The exception message can be associated to an exception
12195    either through the use of the Raise_Exception function, or
12196    more simply (Ada 2005 and later), via:
12197
12198        raise Exception_Name with "exception message";
12199
12200    */
12201
12202 static gdb::unique_xmalloc_ptr<char>
12203 ada_exception_message_1 (void)
12204 {
12205   struct value *e_msg_val;
12206   int e_msg_len;
12207
12208   /* For runtimes that support this feature, the exception message
12209      is passed as an unbounded string argument called "message".  */
12210   e_msg_val = parse_and_eval ("message");
12211   if (e_msg_val == NULL)
12212     return NULL; /* Exception message not supported.  */
12213
12214   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12215   gdb_assert (e_msg_val != NULL);
12216   e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12217
12218   /* If the message string is empty, then treat it as if there was
12219      no exception message.  */
12220   if (e_msg_len <= 0)
12221     return NULL;
12222
12223   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12224   read_memory_string (value_address (e_msg_val), e_msg.get (), e_msg_len + 1);
12225   e_msg.get ()[e_msg_len] = '\0';
12226
12227   return e_msg;
12228 }
12229
12230 /* Same as ada_exception_message_1, except that all exceptions are
12231    contained here (returning NULL instead).  */
12232
12233 static gdb::unique_xmalloc_ptr<char>
12234 ada_exception_message (void)
12235 {
12236   gdb::unique_xmalloc_ptr<char> e_msg;
12237
12238   try
12239     {
12240       e_msg = ada_exception_message_1 ();
12241     }
12242   catch (const gdb_exception_error &e)
12243     {
12244       e_msg.reset (nullptr);
12245     }
12246
12247   return e_msg;
12248 }
12249
12250 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12251    any error that ada_exception_name_addr_1 might cause to be thrown.
12252    When an error is intercepted, a warning with the error message is printed,
12253    and zero is returned.  */
12254
12255 static CORE_ADDR
12256 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
12257                          struct breakpoint *b)
12258 {
12259   CORE_ADDR result = 0;
12260
12261   try
12262     {
12263       result = ada_exception_name_addr_1 (ex, b);
12264     }
12265
12266   catch (const gdb_exception_error &e)
12267     {
12268       warning (_("failed to get exception name: %s"), e.what ());
12269       return 0;
12270     }
12271
12272   return result;
12273 }
12274
12275 static std::string ada_exception_catchpoint_cond_string
12276   (const char *excep_string,
12277    enum ada_exception_catchpoint_kind ex);
12278
12279 /* Ada catchpoints.
12280
12281    In the case of catchpoints on Ada exceptions, the catchpoint will
12282    stop the target on every exception the program throws.  When a user
12283    specifies the name of a specific exception, we translate this
12284    request into a condition expression (in text form), and then parse
12285    it into an expression stored in each of the catchpoint's locations.
12286    We then use this condition to check whether the exception that was
12287    raised is the one the user is interested in.  If not, then the
12288    target is resumed again.  We store the name of the requested
12289    exception, in order to be able to re-set the condition expression
12290    when symbols change.  */
12291
12292 /* An instance of this type is used to represent an Ada catchpoint
12293    breakpoint location.  */
12294
12295 class ada_catchpoint_location : public bp_location
12296 {
12297 public:
12298   ada_catchpoint_location (breakpoint *owner)
12299     : bp_location (owner, bp_loc_software_breakpoint)
12300   {}
12301
12302   /* The condition that checks whether the exception that was raised
12303      is the specific exception the user specified on catchpoint
12304      creation.  */
12305   expression_up excep_cond_expr;
12306 };
12307
12308 /* An instance of this type is used to represent an Ada catchpoint.  */
12309
12310 struct ada_catchpoint : public breakpoint
12311 {
12312   explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind)
12313     : m_kind (kind)
12314   {
12315   }
12316
12317   /* The name of the specific exception the user specified.  */
12318   std::string excep_string;
12319
12320   /* What kind of catchpoint this is.  */
12321   enum ada_exception_catchpoint_kind m_kind;
12322 };
12323
12324 /* Parse the exception condition string in the context of each of the
12325    catchpoint's locations, and store them for later evaluation.  */
12326
12327 static void
12328 create_excep_cond_exprs (struct ada_catchpoint *c,
12329                          enum ada_exception_catchpoint_kind ex)
12330 {
12331   struct bp_location *bl;
12332
12333   /* Nothing to do if there's no specific exception to catch.  */
12334   if (c->excep_string.empty ())
12335     return;
12336
12337   /* Same if there are no locations... */
12338   if (c->loc == NULL)
12339     return;
12340
12341   /* Compute the condition expression in text form, from the specific
12342      expection we want to catch.  */
12343   std::string cond_string
12344     = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
12345
12346   /* Iterate over all the catchpoint's locations, and parse an
12347      expression for each.  */
12348   for (bl = c->loc; bl != NULL; bl = bl->next)
12349     {
12350       struct ada_catchpoint_location *ada_loc
12351         = (struct ada_catchpoint_location *) bl;
12352       expression_up exp;
12353
12354       if (!bl->shlib_disabled)
12355         {
12356           const char *s;
12357
12358           s = cond_string.c_str ();
12359           try
12360             {
12361               exp = parse_exp_1 (&s, bl->address,
12362                                  block_for_pc (bl->address),
12363                                  0);
12364             }
12365           catch (const gdb_exception_error &e)
12366             {
12367               warning (_("failed to reevaluate internal exception condition "
12368                          "for catchpoint %d: %s"),
12369                        c->number, e.what ());
12370             }
12371         }
12372
12373       ada_loc->excep_cond_expr = std::move (exp);
12374     }
12375 }
12376
12377 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12378    structure for all exception catchpoint kinds.  */
12379
12380 static struct bp_location *
12381 allocate_location_exception (struct breakpoint *self)
12382 {
12383   return new ada_catchpoint_location (self);
12384 }
12385
12386 /* Implement the RE_SET method in the breakpoint_ops structure for all
12387    exception catchpoint kinds.  */
12388
12389 static void
12390 re_set_exception (struct breakpoint *b)
12391 {
12392   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12393
12394   /* Call the base class's method.  This updates the catchpoint's
12395      locations.  */
12396   bkpt_breakpoint_ops.re_set (b);
12397
12398   /* Reparse the exception conditional expressions.  One for each
12399      location.  */
12400   create_excep_cond_exprs (c, c->m_kind);
12401 }
12402
12403 /* Returns true if we should stop for this breakpoint hit.  If the
12404    user specified a specific exception, we only want to cause a stop
12405    if the program thrown that exception.  */
12406
12407 static int
12408 should_stop_exception (const struct bp_location *bl)
12409 {
12410   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12411   const struct ada_catchpoint_location *ada_loc
12412     = (const struct ada_catchpoint_location *) bl;
12413   int stop;
12414
12415   struct internalvar *var = lookup_internalvar ("_ada_exception");
12416   if (c->m_kind == ada_catch_assert)
12417     clear_internalvar (var);
12418   else
12419     {
12420       try
12421         {
12422           const char *expr;
12423
12424           if (c->m_kind == ada_catch_handlers)
12425             expr = ("GNAT_GCC_exception_Access(gcc_exception)"
12426                     ".all.occurrence.id");
12427           else
12428             expr = "e";
12429
12430           struct value *exc = parse_and_eval (expr);
12431           set_internalvar (var, exc);
12432         }
12433       catch (const gdb_exception_error &ex)
12434         {
12435           clear_internalvar (var);
12436         }
12437     }
12438
12439   /* With no specific exception, should always stop.  */
12440   if (c->excep_string.empty ())
12441     return 1;
12442
12443   if (ada_loc->excep_cond_expr == NULL)
12444     {
12445       /* We will have a NULL expression if back when we were creating
12446          the expressions, this location's had failed to parse.  */
12447       return 1;
12448     }
12449
12450   stop = 1;
12451   try
12452     {
12453       struct value *mark;
12454
12455       mark = value_mark ();
12456       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12457       value_free_to_mark (mark);
12458     }
12459   catch (const gdb_exception &ex)
12460     {
12461       exception_fprintf (gdb_stderr, ex,
12462                          _("Error in testing exception condition:\n"));
12463     }
12464
12465   return stop;
12466 }
12467
12468 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12469    for all exception catchpoint kinds.  */
12470
12471 static void
12472 check_status_exception (bpstat bs)
12473 {
12474   bs->stop = should_stop_exception (bs->bp_location_at);
12475 }
12476
12477 /* Implement the PRINT_IT method in the breakpoint_ops structure
12478    for all exception catchpoint kinds.  */
12479
12480 static enum print_stop_action
12481 print_it_exception (bpstat bs)
12482 {
12483   struct ui_out *uiout = current_uiout;
12484   struct breakpoint *b = bs->breakpoint_at;
12485
12486   annotate_catchpoint (b->number);
12487
12488   if (uiout->is_mi_like_p ())
12489     {
12490       uiout->field_string ("reason",
12491                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12492       uiout->field_string ("disp", bpdisp_text (b->disposition));
12493     }
12494
12495   uiout->text (b->disposition == disp_del
12496                ? "\nTemporary catchpoint " : "\nCatchpoint ");
12497   uiout->field_signed ("bkptno", b->number);
12498   uiout->text (", ");
12499
12500   /* ada_exception_name_addr relies on the selected frame being the
12501      current frame.  Need to do this here because this function may be
12502      called more than once when printing a stop, and below, we'll
12503      select the first frame past the Ada run-time (see
12504      ada_find_printable_frame).  */
12505   select_frame (get_current_frame ());
12506
12507   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12508   switch (c->m_kind)
12509     {
12510       case ada_catch_exception:
12511       case ada_catch_exception_unhandled:
12512       case ada_catch_handlers:
12513         {
12514           const CORE_ADDR addr = ada_exception_name_addr (c->m_kind, b);
12515           char exception_name[256];
12516
12517           if (addr != 0)
12518             {
12519               read_memory (addr, (gdb_byte *) exception_name,
12520                            sizeof (exception_name) - 1);
12521               exception_name [sizeof (exception_name) - 1] = '\0';
12522             }
12523           else
12524             {
12525               /* For some reason, we were unable to read the exception
12526                  name.  This could happen if the Runtime was compiled
12527                  without debugging info, for instance.  In that case,
12528                  just replace the exception name by the generic string
12529                  "exception" - it will read as "an exception" in the
12530                  notification we are about to print.  */
12531               memcpy (exception_name, "exception", sizeof ("exception"));
12532             }
12533           /* In the case of unhandled exception breakpoints, we print
12534              the exception name as "unhandled EXCEPTION_NAME", to make
12535              it clearer to the user which kind of catchpoint just got
12536              hit.  We used ui_out_text to make sure that this extra
12537              info does not pollute the exception name in the MI case.  */
12538           if (c->m_kind == ada_catch_exception_unhandled)
12539             uiout->text ("unhandled ");
12540           uiout->field_string ("exception-name", exception_name);
12541         }
12542         break;
12543       case ada_catch_assert:
12544         /* In this case, the name of the exception is not really
12545            important.  Just print "failed assertion" to make it clearer
12546            that his program just hit an assertion-failure catchpoint.
12547            We used ui_out_text because this info does not belong in
12548            the MI output.  */
12549         uiout->text ("failed assertion");
12550         break;
12551     }
12552
12553   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12554   if (exception_message != NULL)
12555     {
12556       uiout->text (" (");
12557       uiout->field_string ("exception-message", exception_message.get ());
12558       uiout->text (")");
12559     }
12560
12561   uiout->text (" at ");
12562   ada_find_printable_frame (get_current_frame ());
12563
12564   return PRINT_SRC_AND_LOC;
12565 }
12566
12567 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12568    for all exception catchpoint kinds.  */
12569
12570 static void
12571 print_one_exception (struct breakpoint *b, struct bp_location **last_loc)
12572
12573   struct ui_out *uiout = current_uiout;
12574   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12575   struct value_print_options opts;
12576
12577   get_user_print_options (&opts);
12578
12579   if (opts.addressprint)
12580     uiout->field_skip ("addr");
12581
12582   annotate_field (5);
12583   switch (c->m_kind)
12584     {
12585       case ada_catch_exception:
12586         if (!c->excep_string.empty ())
12587           {
12588             std::string msg = string_printf (_("`%s' Ada exception"),
12589                                              c->excep_string.c_str ());
12590
12591             uiout->field_string ("what", msg);
12592           }
12593         else
12594           uiout->field_string ("what", "all Ada exceptions");
12595         
12596         break;
12597
12598       case ada_catch_exception_unhandled:
12599         uiout->field_string ("what", "unhandled Ada exceptions");
12600         break;
12601       
12602       case ada_catch_handlers:
12603         if (!c->excep_string.empty ())
12604           {
12605             uiout->field_fmt ("what",
12606                               _("`%s' Ada exception handlers"),
12607                               c->excep_string.c_str ());
12608           }
12609         else
12610           uiout->field_string ("what", "all Ada exceptions handlers");
12611         break;
12612
12613       case ada_catch_assert:
12614         uiout->field_string ("what", "failed Ada assertions");
12615         break;
12616
12617       default:
12618         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12619         break;
12620     }
12621 }
12622
12623 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12624    for all exception catchpoint kinds.  */
12625
12626 static void
12627 print_mention_exception (struct breakpoint *b)
12628 {
12629   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12630   struct ui_out *uiout = current_uiout;
12631
12632   uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
12633                                                  : _("Catchpoint "));
12634   uiout->field_signed ("bkptno", b->number);
12635   uiout->text (": ");
12636
12637   switch (c->m_kind)
12638     {
12639       case ada_catch_exception:
12640         if (!c->excep_string.empty ())
12641           {
12642             std::string info = string_printf (_("`%s' Ada exception"),
12643                                               c->excep_string.c_str ());
12644             uiout->text (info.c_str ());
12645           }
12646         else
12647           uiout->text (_("all Ada exceptions"));
12648         break;
12649
12650       case ada_catch_exception_unhandled:
12651         uiout->text (_("unhandled Ada exceptions"));
12652         break;
12653
12654       case ada_catch_handlers:
12655         if (!c->excep_string.empty ())
12656           {
12657             std::string info
12658               = string_printf (_("`%s' Ada exception handlers"),
12659                                c->excep_string.c_str ());
12660             uiout->text (info.c_str ());
12661           }
12662         else
12663           uiout->text (_("all Ada exceptions handlers"));
12664         break;
12665
12666       case ada_catch_assert:
12667         uiout->text (_("failed Ada assertions"));
12668         break;
12669
12670       default:
12671         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12672         break;
12673     }
12674 }
12675
12676 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12677    for all exception catchpoint kinds.  */
12678
12679 static void
12680 print_recreate_exception (struct breakpoint *b, struct ui_file *fp)
12681 {
12682   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12683
12684   switch (c->m_kind)
12685     {
12686       case ada_catch_exception:
12687         fprintf_filtered (fp, "catch exception");
12688         if (!c->excep_string.empty ())
12689           fprintf_filtered (fp, " %s", c->excep_string.c_str ());
12690         break;
12691
12692       case ada_catch_exception_unhandled:
12693         fprintf_filtered (fp, "catch exception unhandled");
12694         break;
12695
12696       case ada_catch_handlers:
12697         fprintf_filtered (fp, "catch handlers");
12698         break;
12699
12700       case ada_catch_assert:
12701         fprintf_filtered (fp, "catch assert");
12702         break;
12703
12704       default:
12705         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12706     }
12707   print_recreate_thread (b, fp);
12708 }
12709
12710 /* Virtual tables for various breakpoint types.  */
12711 static struct breakpoint_ops catch_exception_breakpoint_ops;
12712 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
12713 static struct breakpoint_ops catch_assert_breakpoint_ops;
12714 static struct breakpoint_ops catch_handlers_breakpoint_ops;
12715
12716 /* See ada-lang.h.  */
12717
12718 bool
12719 is_ada_exception_catchpoint (breakpoint *bp)
12720 {
12721   return (bp->ops == &catch_exception_breakpoint_ops
12722           || bp->ops == &catch_exception_unhandled_breakpoint_ops
12723           || bp->ops == &catch_assert_breakpoint_ops
12724           || bp->ops == &catch_handlers_breakpoint_ops);
12725 }
12726
12727 /* Split the arguments specified in a "catch exception" command.  
12728    Set EX to the appropriate catchpoint type.
12729    Set EXCEP_STRING to the name of the specific exception if
12730    specified by the user.
12731    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12732    "catch handlers" command.  False otherwise.
12733    If a condition is found at the end of the arguments, the condition
12734    expression is stored in COND_STRING (memory must be deallocated
12735    after use).  Otherwise COND_STRING is set to NULL.  */
12736
12737 static void
12738 catch_ada_exception_command_split (const char *args,
12739                                    bool is_catch_handlers_cmd,
12740                                    enum ada_exception_catchpoint_kind *ex,
12741                                    std::string *excep_string,
12742                                    std::string *cond_string)
12743 {
12744   std::string exception_name;
12745
12746   exception_name = extract_arg (&args);
12747   if (exception_name == "if")
12748     {
12749       /* This is not an exception name; this is the start of a condition
12750          expression for a catchpoint on all exceptions.  So, "un-get"
12751          this token, and set exception_name to NULL.  */
12752       exception_name.clear ();
12753       args -= 2;
12754     }
12755
12756   /* Check to see if we have a condition.  */
12757
12758   args = skip_spaces (args);
12759   if (startswith (args, "if")
12760       && (isspace (args[2]) || args[2] == '\0'))
12761     {
12762       args += 2;
12763       args = skip_spaces (args);
12764
12765       if (args[0] == '\0')
12766         error (_("Condition missing after `if' keyword"));
12767       *cond_string = args;
12768
12769       args += strlen (args);
12770     }
12771
12772   /* Check that we do not have any more arguments.  Anything else
12773      is unexpected.  */
12774
12775   if (args[0] != '\0')
12776     error (_("Junk at end of expression"));
12777
12778   if (is_catch_handlers_cmd)
12779     {
12780       /* Catch handling of exceptions.  */
12781       *ex = ada_catch_handlers;
12782       *excep_string = exception_name;
12783     }
12784   else if (exception_name.empty ())
12785     {
12786       /* Catch all exceptions.  */
12787       *ex = ada_catch_exception;
12788       excep_string->clear ();
12789     }
12790   else if (exception_name == "unhandled")
12791     {
12792       /* Catch unhandled exceptions.  */
12793       *ex = ada_catch_exception_unhandled;
12794       excep_string->clear ();
12795     }
12796   else
12797     {
12798       /* Catch a specific exception.  */
12799       *ex = ada_catch_exception;
12800       *excep_string = exception_name;
12801     }
12802 }
12803
12804 /* Return the name of the symbol on which we should break in order to
12805    implement a catchpoint of the EX kind.  */
12806
12807 static const char *
12808 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12809 {
12810   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12811
12812   gdb_assert (data->exception_info != NULL);
12813
12814   switch (ex)
12815     {
12816       case ada_catch_exception:
12817         return (data->exception_info->catch_exception_sym);
12818         break;
12819       case ada_catch_exception_unhandled:
12820         return (data->exception_info->catch_exception_unhandled_sym);
12821         break;
12822       case ada_catch_assert:
12823         return (data->exception_info->catch_assert_sym);
12824         break;
12825       case ada_catch_handlers:
12826         return (data->exception_info->catch_handlers_sym);
12827         break;
12828       default:
12829         internal_error (__FILE__, __LINE__,
12830                         _("unexpected catchpoint kind (%d)"), ex);
12831     }
12832 }
12833
12834 /* Return the breakpoint ops "virtual table" used for catchpoints
12835    of the EX kind.  */
12836
12837 static const struct breakpoint_ops *
12838 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
12839 {
12840   switch (ex)
12841     {
12842       case ada_catch_exception:
12843         return (&catch_exception_breakpoint_ops);
12844         break;
12845       case ada_catch_exception_unhandled:
12846         return (&catch_exception_unhandled_breakpoint_ops);
12847         break;
12848       case ada_catch_assert:
12849         return (&catch_assert_breakpoint_ops);
12850         break;
12851       case ada_catch_handlers:
12852         return (&catch_handlers_breakpoint_ops);
12853         break;
12854       default:
12855         internal_error (__FILE__, __LINE__,
12856                         _("unexpected catchpoint kind (%d)"), ex);
12857     }
12858 }
12859
12860 /* Return the condition that will be used to match the current exception
12861    being raised with the exception that the user wants to catch.  This
12862    assumes that this condition is used when the inferior just triggered
12863    an exception catchpoint.
12864    EX: the type of catchpoints used for catching Ada exceptions.  */
12865
12866 static std::string
12867 ada_exception_catchpoint_cond_string (const char *excep_string,
12868                                       enum ada_exception_catchpoint_kind ex)
12869 {
12870   int i;
12871   bool is_standard_exc = false;
12872   std::string result;
12873
12874   if (ex == ada_catch_handlers)
12875     {
12876       /* For exception handlers catchpoints, the condition string does
12877          not use the same parameter as for the other exceptions.  */
12878       result = ("long_integer (GNAT_GCC_exception_Access"
12879                 "(gcc_exception).all.occurrence.id)");
12880     }
12881   else
12882     result = "long_integer (e)";
12883
12884   /* The standard exceptions are a special case.  They are defined in
12885      runtime units that have been compiled without debugging info; if
12886      EXCEP_STRING is the not-fully-qualified name of a standard
12887      exception (e.g. "constraint_error") then, during the evaluation
12888      of the condition expression, the symbol lookup on this name would
12889      *not* return this standard exception.  The catchpoint condition
12890      may then be set only on user-defined exceptions which have the
12891      same not-fully-qualified name (e.g. my_package.constraint_error).
12892
12893      To avoid this unexcepted behavior, these standard exceptions are
12894      systematically prefixed by "standard".  This means that "catch
12895      exception constraint_error" is rewritten into "catch exception
12896      standard.constraint_error".
12897
12898      If an exception named constraint_error is defined in another package of
12899      the inferior program, then the only way to specify this exception as a
12900      breakpoint condition is to use its fully-qualified named:
12901      e.g. my_package.constraint_error.  */
12902
12903   for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12904     {
12905       if (strcmp (standard_exc [i], excep_string) == 0)
12906         {
12907           is_standard_exc = true;
12908           break;
12909         }
12910     }
12911
12912   result += " = ";
12913
12914   if (is_standard_exc)
12915     string_appendf (result, "long_integer (&standard.%s)", excep_string);
12916   else
12917     string_appendf (result, "long_integer (&%s)", excep_string);
12918
12919   return result;
12920 }
12921
12922 /* Return the symtab_and_line that should be used to insert an exception
12923    catchpoint of the TYPE kind.
12924
12925    ADDR_STRING returns the name of the function where the real
12926    breakpoint that implements the catchpoints is set, depending on the
12927    type of catchpoint we need to create.  */
12928
12929 static struct symtab_and_line
12930 ada_exception_sal (enum ada_exception_catchpoint_kind ex,
12931                    std::string *addr_string, const struct breakpoint_ops **ops)
12932 {
12933   const char *sym_name;
12934   struct symbol *sym;
12935
12936   /* First, find out which exception support info to use.  */
12937   ada_exception_support_info_sniffer ();
12938
12939   /* Then lookup the function on which we will break in order to catch
12940      the Ada exceptions requested by the user.  */
12941   sym_name = ada_exception_sym_name (ex);
12942   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12943
12944   if (sym == NULL)
12945     error (_("Catchpoint symbol not found: %s"), sym_name);
12946
12947   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12948     error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
12949
12950   /* Set ADDR_STRING.  */
12951   *addr_string = sym_name;
12952
12953   /* Set OPS.  */
12954   *ops = ada_exception_breakpoint_ops (ex);
12955
12956   return find_function_start_sal (sym, 1);
12957 }
12958
12959 /* Create an Ada exception catchpoint.
12960
12961    EX_KIND is the kind of exception catchpoint to be created.
12962
12963    If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12964    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
12965    of the exception to which this catchpoint applies.
12966
12967    COND_STRING, if not empty, is the catchpoint condition.
12968
12969    TEMPFLAG, if nonzero, means that the underlying breakpoint
12970    should be temporary.
12971
12972    FROM_TTY is the usual argument passed to all commands implementations.  */
12973
12974 void
12975 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12976                                  enum ada_exception_catchpoint_kind ex_kind,
12977                                  const std::string &excep_string,
12978                                  const std::string &cond_string,
12979                                  int tempflag,
12980                                  int disabled,
12981                                  int from_tty)
12982 {
12983   std::string addr_string;
12984   const struct breakpoint_ops *ops = NULL;
12985   struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
12986
12987   std::unique_ptr<ada_catchpoint> c (new ada_catchpoint (ex_kind));
12988   init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
12989                                  ops, tempflag, disabled, from_tty);
12990   c->excep_string = excep_string;
12991   create_excep_cond_exprs (c.get (), ex_kind);
12992   if (!cond_string.empty ())
12993     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty);
12994   install_breakpoint (0, std::move (c), 1);
12995 }
12996
12997 /* Implement the "catch exception" command.  */
12998
12999 static void
13000 catch_ada_exception_command (const char *arg_entry, int from_tty,
13001                              struct cmd_list_element *command)
13002 {
13003   const char *arg = arg_entry;
13004   struct gdbarch *gdbarch = get_current_arch ();
13005   int tempflag;
13006   enum ada_exception_catchpoint_kind ex_kind;
13007   std::string excep_string;
13008   std::string cond_string;
13009
13010   tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13011
13012   if (!arg)
13013     arg = "";
13014   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
13015                                      &cond_string);
13016   create_ada_exception_catchpoint (gdbarch, ex_kind,
13017                                    excep_string, cond_string,
13018                                    tempflag, 1 /* enabled */,
13019                                    from_tty);
13020 }
13021
13022 /* Implement the "catch handlers" command.  */
13023
13024 static void
13025 catch_ada_handlers_command (const char *arg_entry, int from_tty,
13026                             struct cmd_list_element *command)
13027 {
13028   const char *arg = arg_entry;
13029   struct gdbarch *gdbarch = get_current_arch ();
13030   int tempflag;
13031   enum ada_exception_catchpoint_kind ex_kind;
13032   std::string excep_string;
13033   std::string cond_string;
13034
13035   tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13036
13037   if (!arg)
13038     arg = "";
13039   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
13040                                      &cond_string);
13041   create_ada_exception_catchpoint (gdbarch, ex_kind,
13042                                    excep_string, cond_string,
13043                                    tempflag, 1 /* enabled */,
13044                                    from_tty);
13045 }
13046
13047 /* Completion function for the Ada "catch" commands.  */
13048
13049 static void
13050 catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
13051                      const char *text, const char *word)
13052 {
13053   std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
13054
13055   for (const ada_exc_info &info : exceptions)
13056     {
13057       if (startswith (info.name, word))
13058         tracker.add_completion (make_unique_xstrdup (info.name));
13059     }
13060 }
13061
13062 /* Split the arguments specified in a "catch assert" command.
13063
13064    ARGS contains the command's arguments (or the empty string if
13065    no arguments were passed).
13066
13067    If ARGS contains a condition, set COND_STRING to that condition
13068    (the memory needs to be deallocated after use).  */
13069
13070 static void
13071 catch_ada_assert_command_split (const char *args, std::string &cond_string)
13072 {
13073   args = skip_spaces (args);
13074
13075   /* Check whether a condition was provided.  */
13076   if (startswith (args, "if")
13077       && (isspace (args[2]) || args[2] == '\0'))
13078     {
13079       args += 2;
13080       args = skip_spaces (args);
13081       if (args[0] == '\0')
13082         error (_("condition missing after `if' keyword"));
13083       cond_string.assign (args);
13084     }
13085
13086   /* Otherwise, there should be no other argument at the end of
13087      the command.  */
13088   else if (args[0] != '\0')
13089     error (_("Junk at end of arguments."));
13090 }
13091
13092 /* Implement the "catch assert" command.  */
13093
13094 static void
13095 catch_assert_command (const char *arg_entry, int from_tty,
13096                       struct cmd_list_element *command)
13097 {
13098   const char *arg = arg_entry;
13099   struct gdbarch *gdbarch = get_current_arch ();
13100   int tempflag;
13101   std::string cond_string;
13102
13103   tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13104
13105   if (!arg)
13106     arg = "";
13107   catch_ada_assert_command_split (arg, cond_string);
13108   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
13109                                    "", cond_string,
13110                                    tempflag, 1 /* enabled */,
13111                                    from_tty);
13112 }
13113
13114 /* Return non-zero if the symbol SYM is an Ada exception object.  */
13115
13116 static int
13117 ada_is_exception_sym (struct symbol *sym)
13118 {
13119   const char *type_name = TYPE_NAME (SYMBOL_TYPE (sym));
13120
13121   return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13122           && SYMBOL_CLASS (sym) != LOC_BLOCK
13123           && SYMBOL_CLASS (sym) != LOC_CONST
13124           && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13125           && type_name != NULL && strcmp (type_name, "exception") == 0);
13126 }
13127
13128 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13129    Ada exception object.  This matches all exceptions except the ones
13130    defined by the Ada language.  */
13131
13132 static int
13133 ada_is_non_standard_exception_sym (struct symbol *sym)
13134 {
13135   int i;
13136
13137   if (!ada_is_exception_sym (sym))
13138     return 0;
13139
13140   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13141     if (strcmp (sym->linkage_name (), standard_exc[i]) == 0)
13142       return 0;  /* A standard exception.  */
13143
13144   /* Numeric_Error is also a standard exception, so exclude it.
13145      See the STANDARD_EXC description for more details as to why
13146      this exception is not listed in that array.  */
13147   if (strcmp (sym->linkage_name (), "numeric_error") == 0)
13148     return 0;
13149
13150   return 1;
13151 }
13152
13153 /* A helper function for std::sort, comparing two struct ada_exc_info
13154    objects.
13155
13156    The comparison is determined first by exception name, and then
13157    by exception address.  */
13158
13159 bool
13160 ada_exc_info::operator< (const ada_exc_info &other) const
13161 {
13162   int result;
13163
13164   result = strcmp (name, other.name);
13165   if (result < 0)
13166     return true;
13167   if (result == 0 && addr < other.addr)
13168     return true;
13169   return false;
13170 }
13171
13172 bool
13173 ada_exc_info::operator== (const ada_exc_info &other) const
13174 {
13175   return addr == other.addr && strcmp (name, other.name) == 0;
13176 }
13177
13178 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13179    routine, but keeping the first SKIP elements untouched.
13180
13181    All duplicates are also removed.  */
13182
13183 static void
13184 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
13185                                       int skip)
13186 {
13187   std::sort (exceptions->begin () + skip, exceptions->end ());
13188   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13189                      exceptions->end ());
13190 }
13191
13192 /* Add all exceptions defined by the Ada standard whose name match
13193    a regular expression.
13194
13195    If PREG is not NULL, then this regexp_t object is used to
13196    perform the symbol name matching.  Otherwise, no name-based
13197    filtering is performed.
13198
13199    EXCEPTIONS is a vector of exceptions to which matching exceptions
13200    gets pushed.  */
13201
13202 static void
13203 ada_add_standard_exceptions (compiled_regex *preg,
13204                              std::vector<ada_exc_info> *exceptions)
13205 {
13206   int i;
13207
13208   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13209     {
13210       if (preg == NULL
13211           || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
13212         {
13213           struct bound_minimal_symbol msymbol
13214             = ada_lookup_simple_minsym (standard_exc[i]);
13215
13216           if (msymbol.minsym != NULL)
13217             {
13218               struct ada_exc_info info
13219                 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
13220
13221               exceptions->push_back (info);
13222             }
13223         }
13224     }
13225 }
13226
13227 /* Add all Ada exceptions defined locally and accessible from the given
13228    FRAME.
13229
13230    If PREG is not NULL, then this regexp_t object is used to
13231    perform the symbol name matching.  Otherwise, no name-based
13232    filtering is performed.
13233
13234    EXCEPTIONS is a vector of exceptions to which matching exceptions
13235    gets pushed.  */
13236
13237 static void
13238 ada_add_exceptions_from_frame (compiled_regex *preg,
13239                                struct frame_info *frame,
13240                                std::vector<ada_exc_info> *exceptions)
13241 {
13242   const struct block *block = get_frame_block (frame, 0);
13243
13244   while (block != 0)
13245     {
13246       struct block_iterator iter;
13247       struct symbol *sym;
13248
13249       ALL_BLOCK_SYMBOLS (block, iter, sym)
13250         {
13251           switch (SYMBOL_CLASS (sym))
13252             {
13253             case LOC_TYPEDEF:
13254             case LOC_BLOCK:
13255             case LOC_CONST:
13256               break;
13257             default:
13258               if (ada_is_exception_sym (sym))
13259                 {
13260                   struct ada_exc_info info = {sym->print_name (),
13261                                               SYMBOL_VALUE_ADDRESS (sym)};
13262
13263                   exceptions->push_back (info);
13264                 }
13265             }
13266         }
13267       if (BLOCK_FUNCTION (block) != NULL)
13268         break;
13269       block = BLOCK_SUPERBLOCK (block);
13270     }
13271 }
13272
13273 /* Return true if NAME matches PREG or if PREG is NULL.  */
13274
13275 static bool
13276 name_matches_regex (const char *name, compiled_regex *preg)
13277 {
13278   return (preg == NULL
13279           || preg->exec (ada_decode (name).c_str (), 0, NULL, 0) == 0);
13280 }
13281
13282 /* Add all exceptions defined globally whose name name match
13283    a regular expression, excluding standard exceptions.
13284
13285    The reason we exclude standard exceptions is that they need
13286    to be handled separately: Standard exceptions are defined inside
13287    a runtime unit which is normally not compiled with debugging info,
13288    and thus usually do not show up in our symbol search.  However,
13289    if the unit was in fact built with debugging info, we need to
13290    exclude them because they would duplicate the entry we found
13291    during the special loop that specifically searches for those
13292    standard exceptions.
13293
13294    If PREG is not NULL, then this regexp_t object is used to
13295    perform the symbol name matching.  Otherwise, no name-based
13296    filtering is performed.
13297
13298    EXCEPTIONS is a vector of exceptions to which matching exceptions
13299    gets pushed.  */
13300
13301 static void
13302 ada_add_global_exceptions (compiled_regex *preg,
13303                            std::vector<ada_exc_info> *exceptions)
13304 {
13305   /* In Ada, the symbol "search name" is a linkage name, whereas the
13306      regular expression used to do the matching refers to the natural
13307      name.  So match against the decoded name.  */
13308   expand_symtabs_matching (NULL,
13309                            lookup_name_info::match_any (),
13310                            [&] (const char *search_name)
13311                            {
13312                              std::string decoded = ada_decode (search_name);
13313                              return name_matches_regex (decoded.c_str (), preg);
13314                            },
13315                            NULL,
13316                            VARIABLES_DOMAIN);
13317
13318   for (objfile *objfile : current_program_space->objfiles ())
13319     {
13320       for (compunit_symtab *s : objfile->compunits ())
13321         {
13322           const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
13323           int i;
13324
13325           for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13326             {
13327               const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13328               struct block_iterator iter;
13329               struct symbol *sym;
13330
13331               ALL_BLOCK_SYMBOLS (b, iter, sym)
13332                 if (ada_is_non_standard_exception_sym (sym)
13333                     && name_matches_regex (sym->natural_name (), preg))
13334                   {
13335                     struct ada_exc_info info
13336                       = {sym->print_name (), SYMBOL_VALUE_ADDRESS (sym)};
13337
13338                     exceptions->push_back (info);
13339                   }
13340             }
13341         }
13342     }
13343 }
13344
13345 /* Implements ada_exceptions_list with the regular expression passed
13346    as a regex_t, rather than a string.
13347
13348    If not NULL, PREG is used to filter out exceptions whose names
13349    do not match.  Otherwise, all exceptions are listed.  */
13350
13351 static std::vector<ada_exc_info>
13352 ada_exceptions_list_1 (compiled_regex *preg)
13353 {
13354   std::vector<ada_exc_info> result;
13355   int prev_len;
13356
13357   /* First, list the known standard exceptions.  These exceptions
13358      need to be handled separately, as they are usually defined in
13359      runtime units that have been compiled without debugging info.  */
13360
13361   ada_add_standard_exceptions (preg, &result);
13362
13363   /* Next, find all exceptions whose scope is local and accessible
13364      from the currently selected frame.  */
13365
13366   if (has_stack_frames ())
13367     {
13368       prev_len = result.size ();
13369       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13370                                      &result);
13371       if (result.size () > prev_len)
13372         sort_remove_dups_ada_exceptions_list (&result, prev_len);
13373     }
13374
13375   /* Add all exceptions whose scope is global.  */
13376
13377   prev_len = result.size ();
13378   ada_add_global_exceptions (preg, &result);
13379   if (result.size () > prev_len)
13380     sort_remove_dups_ada_exceptions_list (&result, prev_len);
13381
13382   return result;
13383 }
13384
13385 /* Return a vector of ada_exc_info.
13386
13387    If REGEXP is NULL, all exceptions are included in the result.
13388    Otherwise, it should contain a valid regular expression,
13389    and only the exceptions whose names match that regular expression
13390    are included in the result.
13391
13392    The exceptions are sorted in the following order:
13393      - Standard exceptions (defined by the Ada language), in
13394        alphabetical order;
13395      - Exceptions only visible from the current frame, in
13396        alphabetical order;
13397      - Exceptions whose scope is global, in alphabetical order.  */
13398
13399 std::vector<ada_exc_info>
13400 ada_exceptions_list (const char *regexp)
13401 {
13402   if (regexp == NULL)
13403     return ada_exceptions_list_1 (NULL);
13404
13405   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13406   return ada_exceptions_list_1 (&reg);
13407 }
13408
13409 /* Implement the "info exceptions" command.  */
13410
13411 static void
13412 info_exceptions_command (const char *regexp, int from_tty)
13413 {
13414   struct gdbarch *gdbarch = get_current_arch ();
13415
13416   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13417
13418   if (regexp != NULL)
13419     printf_filtered
13420       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13421   else
13422     printf_filtered (_("All defined Ada exceptions:\n"));
13423
13424   for (const ada_exc_info &info : exceptions)
13425     printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13426 }
13427
13428                                 /* Operators */
13429 /* Information about operators given special treatment in functions
13430    below.  */
13431 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>).  */
13432
13433 #define ADA_OPERATORS \
13434     OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13435     OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13436     OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13437     OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13438     OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13439     OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13440     OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13441     OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13442     OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13443     OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13444     OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13445     OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13446     OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13447     OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13448     OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13449     OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13450     OP_DEFN (OP_OTHERS, 1, 1, 0) \
13451     OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13452     OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13453
13454 static void
13455 ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13456                      int *argsp)
13457 {
13458   switch (exp->elts[pc - 1].opcode)
13459     {
13460     default:
13461       operator_length_standard (exp, pc, oplenp, argsp);
13462       break;
13463
13464 #define OP_DEFN(op, len, args, binop) \
13465     case op: *oplenp = len; *argsp = args; break;
13466       ADA_OPERATORS;
13467 #undef OP_DEFN
13468
13469     case OP_AGGREGATE:
13470       *oplenp = 3;
13471       *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13472       break;
13473
13474     case OP_CHOICES:
13475       *oplenp = 3;
13476       *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13477       break;
13478     }
13479 }
13480
13481 /* Implementation of the exp_descriptor method operator_check.  */
13482
13483 static int
13484 ada_operator_check (struct expression *exp, int pos,
13485                     int (*objfile_func) (struct objfile *objfile, void *data),
13486                     void *data)
13487 {
13488   const union exp_element *const elts = exp->elts;
13489   struct type *type = NULL;
13490
13491   switch (elts[pos].opcode)
13492     {
13493       case UNOP_IN_RANGE:
13494       case UNOP_QUAL:
13495         type = elts[pos + 1].type;
13496         break;
13497
13498       default:
13499         return operator_check_standard (exp, pos, objfile_func, data);
13500     }
13501
13502   /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL.  */
13503
13504   if (type && TYPE_OBJFILE (type)
13505       && (*objfile_func) (TYPE_OBJFILE (type), data))
13506     return 1;
13507
13508   return 0;
13509 }
13510
13511 static const char *
13512 ada_op_name (enum exp_opcode opcode)
13513 {
13514   switch (opcode)
13515     {
13516     default:
13517       return op_name_standard (opcode);
13518
13519 #define OP_DEFN(op, len, args, binop) case op: return #op;
13520       ADA_OPERATORS;
13521 #undef OP_DEFN
13522
13523     case OP_AGGREGATE:
13524       return "OP_AGGREGATE";
13525     case OP_CHOICES:
13526       return "OP_CHOICES";
13527     case OP_NAME:
13528       return "OP_NAME";
13529     }
13530 }
13531
13532 /* As for operator_length, but assumes PC is pointing at the first
13533    element of the operator, and gives meaningful results only for the 
13534    Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise.  */
13535
13536 static void
13537 ada_forward_operator_length (struct expression *exp, int pc,
13538                              int *oplenp, int *argsp)
13539 {
13540   switch (exp->elts[pc].opcode)
13541     {
13542     default:
13543       *oplenp = *argsp = 0;
13544       break;
13545
13546 #define OP_DEFN(op, len, args, binop) \
13547     case op: *oplenp = len; *argsp = args; break;
13548       ADA_OPERATORS;
13549 #undef OP_DEFN
13550
13551     case OP_AGGREGATE:
13552       *oplenp = 3;
13553       *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13554       break;
13555
13556     case OP_CHOICES:
13557       *oplenp = 3;
13558       *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13559       break;
13560
13561     case OP_STRING:
13562     case OP_NAME:
13563       {
13564         int len = longest_to_int (exp->elts[pc + 1].longconst);
13565
13566         *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13567         *argsp = 0;
13568         break;
13569       }
13570     }
13571 }
13572
13573 static int
13574 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13575 {
13576   enum exp_opcode op = exp->elts[elt].opcode;
13577   int oplen, nargs;
13578   int pc = elt;
13579   int i;
13580
13581   ada_forward_operator_length (exp, elt, &oplen, &nargs);
13582
13583   switch (op)
13584     {
13585       /* Ada attributes ('Foo).  */
13586     case OP_ATR_FIRST:
13587     case OP_ATR_LAST:
13588     case OP_ATR_LENGTH:
13589     case OP_ATR_IMAGE:
13590     case OP_ATR_MAX:
13591     case OP_ATR_MIN:
13592     case OP_ATR_MODULUS:
13593     case OP_ATR_POS:
13594     case OP_ATR_SIZE:
13595     case OP_ATR_TAG:
13596     case OP_ATR_VAL:
13597       break;
13598
13599     case UNOP_IN_RANGE:
13600     case UNOP_QUAL:
13601       /* XXX: gdb_sprint_host_address, type_sprint */
13602       fprintf_filtered (stream, _("Type @"));
13603       gdb_print_host_address (exp->elts[pc + 1].type, stream);
13604       fprintf_filtered (stream, " (");
13605       type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13606       fprintf_filtered (stream, ")");
13607       break;
13608     case BINOP_IN_BOUNDS:
13609       fprintf_filtered (stream, " (%d)",
13610                         longest_to_int (exp->elts[pc + 2].longconst));
13611       break;
13612     case TERNOP_IN_RANGE:
13613       break;
13614
13615     case OP_AGGREGATE:
13616     case OP_OTHERS:
13617     case OP_DISCRETE_RANGE:
13618     case OP_POSITIONAL:
13619     case OP_CHOICES:
13620       break;
13621
13622     case OP_NAME:
13623     case OP_STRING:
13624       {
13625         char *name = &exp->elts[elt + 2].string;
13626         int len = longest_to_int (exp->elts[elt + 1].longconst);
13627
13628         fprintf_filtered (stream, "Text: `%.*s'", len, name);
13629         break;
13630       }
13631
13632     default:
13633       return dump_subexp_body_standard (exp, stream, elt);
13634     }
13635
13636   elt += oplen;
13637   for (i = 0; i < nargs; i += 1)
13638     elt = dump_subexp (exp, stream, elt);
13639
13640   return elt;
13641 }
13642
13643 /* The Ada extension of print_subexp (q.v.).  */
13644
13645 static void
13646 ada_print_subexp (struct expression *exp, int *pos,
13647                   struct ui_file *stream, enum precedence prec)
13648 {
13649   int oplen, nargs, i;
13650   int pc = *pos;
13651   enum exp_opcode op = exp->elts[pc].opcode;
13652
13653   ada_forward_operator_length (exp, pc, &oplen, &nargs);
13654
13655   *pos += oplen;
13656   switch (op)
13657     {
13658     default:
13659       *pos -= oplen;
13660       print_subexp_standard (exp, pos, stream, prec);
13661       return;
13662
13663     case OP_VAR_VALUE:
13664       fputs_filtered (exp->elts[pc + 2].symbol->natural_name (), stream);
13665       return;
13666
13667     case BINOP_IN_BOUNDS:
13668       /* XXX: sprint_subexp */
13669       print_subexp (exp, pos, stream, PREC_SUFFIX);
13670       fputs_filtered (" in ", stream);
13671       print_subexp (exp, pos, stream, PREC_SUFFIX);
13672       fputs_filtered ("'range", stream);
13673       if (exp->elts[pc + 1].longconst > 1)
13674         fprintf_filtered (stream, "(%ld)",
13675                           (long) exp->elts[pc + 1].longconst);
13676       return;
13677
13678     case TERNOP_IN_RANGE:
13679       if (prec >= PREC_EQUAL)
13680         fputs_filtered ("(", stream);
13681       /* XXX: sprint_subexp */
13682       print_subexp (exp, pos, stream, PREC_SUFFIX);
13683       fputs_filtered (" in ", stream);
13684       print_subexp (exp, pos, stream, PREC_EQUAL);
13685       fputs_filtered (" .. ", stream);
13686       print_subexp (exp, pos, stream, PREC_EQUAL);
13687       if (prec >= PREC_EQUAL)
13688         fputs_filtered (")", stream);
13689       return;
13690
13691     case OP_ATR_FIRST:
13692     case OP_ATR_LAST:
13693     case OP_ATR_LENGTH:
13694     case OP_ATR_IMAGE:
13695     case OP_ATR_MAX:
13696     case OP_ATR_MIN:
13697     case OP_ATR_MODULUS:
13698     case OP_ATR_POS:
13699     case OP_ATR_SIZE:
13700     case OP_ATR_TAG:
13701     case OP_ATR_VAL:
13702       if (exp->elts[*pos].opcode == OP_TYPE)
13703         {
13704           if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
13705             LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13706                            &type_print_raw_options);
13707           *pos += 3;
13708         }
13709       else
13710         print_subexp (exp, pos, stream, PREC_SUFFIX);
13711       fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13712       if (nargs > 1)
13713         {
13714           int tem;
13715
13716           for (tem = 1; tem < nargs; tem += 1)
13717             {
13718               fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13719               print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13720             }
13721           fputs_filtered (")", stream);
13722         }
13723       return;
13724
13725     case UNOP_QUAL:
13726       type_print (exp->elts[pc + 1].type, "", stream, 0);
13727       fputs_filtered ("'(", stream);
13728       print_subexp (exp, pos, stream, PREC_PREFIX);
13729       fputs_filtered (")", stream);
13730       return;
13731
13732     case UNOP_IN_RANGE:
13733       /* XXX: sprint_subexp */
13734       print_subexp (exp, pos, stream, PREC_SUFFIX);
13735       fputs_filtered (" in ", stream);
13736       LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13737                      &type_print_raw_options);
13738       return;
13739
13740     case OP_DISCRETE_RANGE:
13741       print_subexp (exp, pos, stream, PREC_SUFFIX);
13742       fputs_filtered ("..", stream);
13743       print_subexp (exp, pos, stream, PREC_SUFFIX);
13744       return;
13745
13746     case OP_OTHERS:
13747       fputs_filtered ("others => ", stream);
13748       print_subexp (exp, pos, stream, PREC_SUFFIX);
13749       return;
13750
13751     case OP_CHOICES:
13752       for (i = 0; i < nargs-1; i += 1)
13753         {
13754           if (i > 0)
13755             fputs_filtered ("|", stream);
13756           print_subexp (exp, pos, stream, PREC_SUFFIX);
13757         }
13758       fputs_filtered (" => ", stream);
13759       print_subexp (exp, pos, stream, PREC_SUFFIX);
13760       return;
13761       
13762     case OP_POSITIONAL:
13763       print_subexp (exp, pos, stream, PREC_SUFFIX);
13764       return;
13765
13766     case OP_AGGREGATE:
13767       fputs_filtered ("(", stream);
13768       for (i = 0; i < nargs; i += 1)
13769         {
13770           if (i > 0)
13771             fputs_filtered (", ", stream);
13772           print_subexp (exp, pos, stream, PREC_SUFFIX);
13773         }
13774       fputs_filtered (")", stream);
13775       return;
13776     }
13777 }
13778
13779 /* Table mapping opcodes into strings for printing operators
13780    and precedences of the operators.  */
13781
13782 static const struct op_print ada_op_print_tab[] = {
13783   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13784   {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13785   {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13786   {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13787   {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13788   {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13789   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13790   {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13791   {"<=", BINOP_LEQ, PREC_ORDER, 0},
13792   {">=", BINOP_GEQ, PREC_ORDER, 0},
13793   {">", BINOP_GTR, PREC_ORDER, 0},
13794   {"<", BINOP_LESS, PREC_ORDER, 0},
13795   {">>", BINOP_RSH, PREC_SHIFT, 0},
13796   {"<<", BINOP_LSH, PREC_SHIFT, 0},
13797   {"+", BINOP_ADD, PREC_ADD, 0},
13798   {"-", BINOP_SUB, PREC_ADD, 0},
13799   {"&", BINOP_CONCAT, PREC_ADD, 0},
13800   {"*", BINOP_MUL, PREC_MUL, 0},
13801   {"/", BINOP_DIV, PREC_MUL, 0},
13802   {"rem", BINOP_REM, PREC_MUL, 0},
13803   {"mod", BINOP_MOD, PREC_MUL, 0},
13804   {"**", BINOP_EXP, PREC_REPEAT, 0},
13805   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13806   {"-", UNOP_NEG, PREC_PREFIX, 0},
13807   {"+", UNOP_PLUS, PREC_PREFIX, 0},
13808   {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13809   {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13810   {"abs ", UNOP_ABS, PREC_PREFIX, 0},
13811   {".all", UNOP_IND, PREC_SUFFIX, 1},
13812   {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13813   {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
13814   {NULL, OP_NULL, PREC_SUFFIX, 0}
13815 };
13816 \f
13817 enum ada_primitive_types {
13818   ada_primitive_type_int,
13819   ada_primitive_type_long,
13820   ada_primitive_type_short,
13821   ada_primitive_type_char,
13822   ada_primitive_type_float,
13823   ada_primitive_type_double,
13824   ada_primitive_type_void,
13825   ada_primitive_type_long_long,
13826   ada_primitive_type_long_double,
13827   ada_primitive_type_natural,
13828   ada_primitive_type_positive,
13829   ada_primitive_type_system_address,
13830   ada_primitive_type_storage_offset,
13831   nr_ada_primitive_types
13832 };
13833
13834 static void
13835 ada_language_arch_info (struct gdbarch *gdbarch,
13836                         struct language_arch_info *lai)
13837 {
13838   const struct builtin_type *builtin = builtin_type (gdbarch);
13839
13840   lai->primitive_type_vector
13841     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
13842                               struct type *);
13843
13844   lai->primitive_type_vector [ada_primitive_type_int]
13845     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13846                          0, "integer");
13847   lai->primitive_type_vector [ada_primitive_type_long]
13848     = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13849                          0, "long_integer");
13850   lai->primitive_type_vector [ada_primitive_type_short]
13851     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13852                          0, "short_integer");
13853   lai->string_char_type
13854     = lai->primitive_type_vector [ada_primitive_type_char]
13855     = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
13856   lai->primitive_type_vector [ada_primitive_type_float]
13857     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13858                        "float", gdbarch_float_format (gdbarch));
13859   lai->primitive_type_vector [ada_primitive_type_double]
13860     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13861                        "long_float", gdbarch_double_format (gdbarch));
13862   lai->primitive_type_vector [ada_primitive_type_long_long]
13863     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13864                          0, "long_long_integer");
13865   lai->primitive_type_vector [ada_primitive_type_long_double]
13866     = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13867                        "long_long_float", gdbarch_long_double_format (gdbarch));
13868   lai->primitive_type_vector [ada_primitive_type_natural]
13869     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13870                          0, "natural");
13871   lai->primitive_type_vector [ada_primitive_type_positive]
13872     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13873                          0, "positive");
13874   lai->primitive_type_vector [ada_primitive_type_void]
13875     = builtin->builtin_void;
13876
13877   lai->primitive_type_vector [ada_primitive_type_system_address]
13878     = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13879                                       "void"));
13880   TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
13881     = "system__address";
13882
13883   /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13884      type.  This is a signed integral type whose size is the same as
13885      the size of addresses.  */
13886   {
13887     unsigned int addr_length = TYPE_LENGTH
13888       (lai->primitive_type_vector [ada_primitive_type_system_address]);
13889
13890     lai->primitive_type_vector [ada_primitive_type_storage_offset]
13891       = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
13892                            "storage_offset");
13893   }
13894
13895   lai->bool_type_symbol = NULL;
13896   lai->bool_type_default = builtin->builtin_bool;
13897 }
13898 \f
13899                                 /* Language vector */
13900
13901 /* Not really used, but needed in the ada_language_defn.  */
13902
13903 static void
13904 emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
13905 {
13906   ada_emit_char (c, type, stream, quoter, 1);
13907 }
13908
13909 static int
13910 parse (struct parser_state *ps)
13911 {
13912   warnings_issued = 0;
13913   return ada_parse (ps);
13914 }
13915
13916 static const struct exp_descriptor ada_exp_descriptor = {
13917   ada_print_subexp,
13918   ada_operator_length,
13919   ada_operator_check,
13920   ada_op_name,
13921   ada_dump_subexp_body,
13922   ada_evaluate_subexp
13923 };
13924
13925 /* symbol_name_matcher_ftype adapter for wild_match.  */
13926
13927 static bool
13928 do_wild_match (const char *symbol_search_name,
13929                const lookup_name_info &lookup_name,
13930                completion_match_result *comp_match_res)
13931 {
13932   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
13933 }
13934
13935 /* symbol_name_matcher_ftype adapter for full_match.  */
13936
13937 static bool
13938 do_full_match (const char *symbol_search_name,
13939                const lookup_name_info &lookup_name,
13940                completion_match_result *comp_match_res)
13941 {
13942   return full_match (symbol_search_name, ada_lookup_name (lookup_name));
13943 }
13944
13945 /* symbol_name_matcher_ftype for exact (verbatim) matches.  */
13946
13947 static bool
13948 do_exact_match (const char *symbol_search_name,
13949                 const lookup_name_info &lookup_name,
13950                 completion_match_result *comp_match_res)
13951 {
13952   return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
13953 }
13954
13955 /* Build the Ada lookup name for LOOKUP_NAME.  */
13956
13957 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
13958 {
13959   const std::string &user_name = lookup_name.name ();
13960
13961   if (user_name[0] == '<')
13962     {
13963       if (user_name.back () == '>')
13964         m_encoded_name = user_name.substr (1, user_name.size () - 2);
13965       else
13966         m_encoded_name = user_name.substr (1, user_name.size () - 1);
13967       m_encoded_p = true;
13968       m_verbatim_p = true;
13969       m_wild_match_p = false;
13970       m_standard_p = false;
13971     }
13972   else
13973     {
13974       m_verbatim_p = false;
13975
13976       m_encoded_p = user_name.find ("__") != std::string::npos;
13977
13978       if (!m_encoded_p)
13979         {
13980           const char *folded = ada_fold_name (user_name.c_str ());
13981           const char *encoded = ada_encode_1 (folded, false);
13982           if (encoded != NULL)
13983             m_encoded_name = encoded;
13984           else
13985             m_encoded_name = user_name;
13986         }
13987       else
13988         m_encoded_name = user_name;
13989
13990       /* Handle the 'package Standard' special case.  See description
13991          of m_standard_p.  */
13992       if (startswith (m_encoded_name.c_str (), "standard__"))
13993         {
13994           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
13995           m_standard_p = true;
13996         }
13997       else
13998         m_standard_p = false;
13999
14000       /* If the name contains a ".", then the user is entering a fully
14001          qualified entity name, and the match must not be done in wild
14002          mode.  Similarly, if the user wants to complete what looks
14003          like an encoded name, the match must not be done in wild
14004          mode.  Also, in the standard__ special case always do
14005          non-wild matching.  */
14006       m_wild_match_p
14007         = (lookup_name.match_type () != symbol_name_match_type::FULL
14008            && !m_encoded_p
14009            && !m_standard_p
14010            && user_name.find ('.') == std::string::npos);
14011     }
14012 }
14013
14014 /* symbol_name_matcher_ftype method for Ada.  This only handles
14015    completion mode.  */
14016
14017 static bool
14018 ada_symbol_name_matches (const char *symbol_search_name,
14019                          const lookup_name_info &lookup_name,
14020                          completion_match_result *comp_match_res)
14021 {
14022   return lookup_name.ada ().matches (symbol_search_name,
14023                                      lookup_name.match_type (),
14024                                      comp_match_res);
14025 }
14026
14027 /* A name matcher that matches the symbol name exactly, with
14028    strcmp.  */
14029
14030 static bool
14031 literal_symbol_name_matcher (const char *symbol_search_name,
14032                              const lookup_name_info &lookup_name,
14033                              completion_match_result *comp_match_res)
14034 {
14035   const std::string &name = lookup_name.name ();
14036
14037   int cmp = (lookup_name.completion_mode ()
14038              ? strncmp (symbol_search_name, name.c_str (), name.size ())
14039              : strcmp (symbol_search_name, name.c_str ()));
14040   if (cmp == 0)
14041     {
14042       if (comp_match_res != NULL)
14043         comp_match_res->set_match (symbol_search_name);
14044       return true;
14045     }
14046   else
14047     return false;
14048 }
14049
14050 /* Implement the "la_get_symbol_name_matcher" language_defn method for
14051    Ada.  */
14052
14053 static symbol_name_matcher_ftype *
14054 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14055 {
14056   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14057     return literal_symbol_name_matcher;
14058
14059   if (lookup_name.completion_mode ())
14060     return ada_symbol_name_matches;
14061   else
14062     {
14063       if (lookup_name.ada ().wild_match_p ())
14064         return do_wild_match;
14065       else if (lookup_name.ada ().verbatim_p ())
14066         return do_exact_match;
14067       else
14068         return do_full_match;
14069     }
14070 }
14071
14072 /* Implement the "la_read_var_value" language_defn method for Ada.  */
14073
14074 static struct value *
14075 ada_read_var_value (struct symbol *var, const struct block *var_block,
14076                     struct frame_info *frame)
14077 {
14078   /* The only case where default_read_var_value is not sufficient
14079      is when VAR is a renaming...  */
14080   if (frame != nullptr)
14081     {
14082       const struct block *frame_block = get_frame_block (frame, NULL);
14083       if (frame_block != nullptr && ada_is_renaming_symbol (var))
14084         return ada_read_renaming_var_value (var, frame_block);
14085     }
14086
14087   /* This is a typical case where we expect the default_read_var_value
14088      function to work.  */
14089   return default_read_var_value (var, var_block, frame);
14090 }
14091
14092 static const char *ada_extensions[] =
14093 {
14094   ".adb", ".ads", ".a", ".ada", ".dg", NULL
14095 };
14096
14097 extern const struct language_defn ada_language_defn = {
14098   "ada",                        /* Language name */
14099   "Ada",
14100   language_ada,
14101   range_check_off,
14102   case_sensitive_on,            /* Yes, Ada is case-insensitive, but
14103                                    that's not quite what this means.  */
14104   array_row_major,
14105   macro_expansion_no,
14106   ada_extensions,
14107   &ada_exp_descriptor,
14108   parse,
14109   resolve,
14110   ada_printchar,                /* Print a character constant */
14111   ada_printstr,                 /* Function to print string constant */
14112   emit_char,                    /* Function to print single char (not used) */
14113   ada_print_type,               /* Print a type using appropriate syntax */
14114   ada_print_typedef,            /* Print a typedef using appropriate syntax */
14115   ada_val_print,                /* Print a value using appropriate syntax */
14116   ada_value_print,              /* Print a top-level value */
14117   ada_read_var_value,           /* la_read_var_value */
14118   NULL,                         /* Language specific skip_trampoline */
14119   NULL,                         /* name_of_this */
14120   true,                         /* la_store_sym_names_in_linkage_form_p */
14121   ada_lookup_symbol_nonlocal,   /* Looking up non-local symbols.  */
14122   basic_lookup_transparent_type,        /* lookup_transparent_type */
14123   ada_la_decode,                /* Language specific symbol demangler */
14124   ada_sniff_from_mangled_name,
14125   NULL,                         /* Language specific
14126                                    class_name_from_physname */
14127   ada_op_print_tab,             /* expression operators for printing */
14128   0,                            /* c-style arrays */
14129   1,                            /* String lower bound */
14130   ada_get_gdb_completer_word_break_characters,
14131   ada_collect_symbol_completion_matches,
14132   ada_language_arch_info,
14133   ada_print_array_index,
14134   default_pass_by_reference,
14135   ada_watch_location_expression,
14136   ada_get_symbol_name_matcher,  /* la_get_symbol_name_matcher */
14137   ada_iterate_over_symbols,
14138   default_search_name_hash,
14139   &ada_varobj_ops,
14140   NULL,
14141   NULL,
14142   ada_is_string_type,
14143   "(...)"                       /* la_struct_too_deep_ellipsis */
14144 };
14145
14146 /* Command-list for the "set/show ada" prefix command.  */
14147 static struct cmd_list_element *set_ada_list;
14148 static struct cmd_list_element *show_ada_list;
14149
14150 /* Implement the "set ada" prefix command.  */
14151
14152 static void
14153 set_ada_command (const char *arg, int from_tty)
14154 {
14155   printf_unfiltered (_(\
14156 "\"set ada\" must be followed by the name of a setting.\n"));
14157   help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
14158 }
14159
14160 /* Implement the "show ada" prefix command.  */
14161
14162 static void
14163 show_ada_command (const char *args, int from_tty)
14164 {
14165   cmd_show_list (show_ada_list, from_tty, "");
14166 }
14167
14168 static void
14169 initialize_ada_catchpoint_ops (void)
14170 {
14171   struct breakpoint_ops *ops;
14172
14173   initialize_breakpoint_ops ();
14174
14175   ops = &catch_exception_breakpoint_ops;
14176   *ops = bkpt_breakpoint_ops;
14177   ops->allocate_location = allocate_location_exception;
14178   ops->re_set = re_set_exception;
14179   ops->check_status = check_status_exception;
14180   ops->print_it = print_it_exception;
14181   ops->print_one = print_one_exception;
14182   ops->print_mention = print_mention_exception;
14183   ops->print_recreate = print_recreate_exception;
14184
14185   ops = &catch_exception_unhandled_breakpoint_ops;
14186   *ops = bkpt_breakpoint_ops;
14187   ops->allocate_location = allocate_location_exception;
14188   ops->re_set = re_set_exception;
14189   ops->check_status = check_status_exception;
14190   ops->print_it = print_it_exception;
14191   ops->print_one = print_one_exception;
14192   ops->print_mention = print_mention_exception;
14193   ops->print_recreate = print_recreate_exception;
14194
14195   ops = &catch_assert_breakpoint_ops;
14196   *ops = bkpt_breakpoint_ops;
14197   ops->allocate_location = allocate_location_exception;
14198   ops->re_set = re_set_exception;
14199   ops->check_status = check_status_exception;
14200   ops->print_it = print_it_exception;
14201   ops->print_one = print_one_exception;
14202   ops->print_mention = print_mention_exception;
14203   ops->print_recreate = print_recreate_exception;
14204
14205   ops = &catch_handlers_breakpoint_ops;
14206   *ops = bkpt_breakpoint_ops;
14207   ops->allocate_location = allocate_location_exception;
14208   ops->re_set = re_set_exception;
14209   ops->check_status = check_status_exception;
14210   ops->print_it = print_it_exception;
14211   ops->print_one = print_one_exception;
14212   ops->print_mention = print_mention_exception;
14213   ops->print_recreate = print_recreate_exception;
14214 }
14215
14216 /* This module's 'new_objfile' observer.  */
14217
14218 static void
14219 ada_new_objfile_observer (struct objfile *objfile)
14220 {
14221   ada_clear_symbol_cache ();
14222 }
14223
14224 /* This module's 'free_objfile' observer.  */
14225
14226 static void
14227 ada_free_objfile_observer (struct objfile *objfile)
14228 {
14229   ada_clear_symbol_cache ();
14230 }
14231
14232 void
14233 _initialize_ada_language (void)
14234 {
14235   initialize_ada_catchpoint_ops ();
14236
14237   add_prefix_cmd ("ada", no_class, set_ada_command,
14238                   _("Prefix command for changing Ada-specific settings."),
14239                   &set_ada_list, "set ada ", 0, &setlist);
14240
14241   add_prefix_cmd ("ada", no_class, show_ada_command,
14242                   _("Generic command for showing Ada-specific settings."),
14243                   &show_ada_list, "show ada ", 0, &showlist);
14244
14245   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14246                            &trust_pad_over_xvs, _("\
14247 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14248 Show whether an optimization trusting PAD types over XVS types is activated."),
14249                            _("\
14250 This is related to the encoding used by the GNAT compiler.  The debugger\n\
14251 should normally trust the contents of PAD types, but certain older versions\n\
14252 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14253 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
14254 work around this bug.  It is always safe to turn this option \"off\", but\n\
14255 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14256 this option to \"off\" unless necessary."),
14257                             NULL, NULL, &set_ada_list, &show_ada_list);
14258
14259   add_setshow_boolean_cmd ("print-signatures", class_vars,
14260                            &print_signatures, _("\
14261 Enable or disable the output of formal and return types for functions in the \
14262 overloads selection menu."), _("\
14263 Show whether the output of formal and return types for functions in the \
14264 overloads selection menu is activated."),
14265                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14266
14267   add_catch_command ("exception", _("\
14268 Catch Ada exceptions, when raised.\n\
14269 Usage: catch exception [ARG] [if CONDITION]\n\
14270 Without any argument, stop when any Ada exception is raised.\n\
14271 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14272 being raised does not have a handler (and will therefore lead to the task's\n\
14273 termination).\n\
14274 Otherwise, the catchpoint only stops when the name of the exception being\n\
14275 raised is the same as ARG.\n\
14276 CONDITION is a boolean expression that is evaluated to see whether the\n\
14277 exception should cause a stop."),
14278                      catch_ada_exception_command,
14279                      catch_ada_completer,
14280                      CATCH_PERMANENT,
14281                      CATCH_TEMPORARY);
14282
14283   add_catch_command ("handlers", _("\
14284 Catch Ada exceptions, when handled.\n\
14285 Usage: catch handlers [ARG] [if CONDITION]\n\
14286 Without any argument, stop when any Ada exception is handled.\n\
14287 With an argument, catch only exceptions with the given name.\n\
14288 CONDITION is a boolean expression that is evaluated to see whether the\n\
14289 exception should cause a stop."),
14290                      catch_ada_handlers_command,
14291                      catch_ada_completer,
14292                      CATCH_PERMANENT,
14293                      CATCH_TEMPORARY);
14294   add_catch_command ("assert", _("\
14295 Catch failed Ada assertions, when raised.\n\
14296 Usage: catch assert [if CONDITION]\n\
14297 CONDITION is a boolean expression that is evaluated to see whether the\n\
14298 exception should cause a stop."),
14299                      catch_assert_command,
14300                      NULL,
14301                      CATCH_PERMANENT,
14302                      CATCH_TEMPORARY);
14303
14304   varsize_limit = 65536;
14305   add_setshow_uinteger_cmd ("varsize-limit", class_support,
14306                             &varsize_limit, _("\
14307 Set the maximum number of bytes allowed in a variable-size object."), _("\
14308 Show the maximum number of bytes allowed in a variable-size object."), _("\
14309 Attempts to access an object whose size is not a compile-time constant\n\
14310 and exceeds this limit will cause an error."),
14311                             NULL, NULL, &setlist, &showlist);
14312
14313   add_info ("exceptions", info_exceptions_command,
14314             _("\
14315 List all Ada exception names.\n\
14316 Usage: info exceptions [REGEXP]\n\
14317 If a regular expression is passed as an argument, only those matching\n\
14318 the regular expression are listed."));
14319
14320   add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14321                   _("Set Ada maintenance-related variables."),
14322                   &maint_set_ada_cmdlist, "maintenance set ada ",
14323                   0/*allow-unknown*/, &maintenance_set_cmdlist);
14324
14325   add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14326                   _("Show Ada maintenance-related variables."),
14327                   &maint_show_ada_cmdlist, "maintenance show ada ",
14328                   0/*allow-unknown*/, &maintenance_show_cmdlist);
14329
14330   add_setshow_boolean_cmd
14331     ("ignore-descriptive-types", class_maintenance,
14332      &ada_ignore_descriptive_types_p,
14333      _("Set whether descriptive types generated by GNAT should be ignored."),
14334      _("Show whether descriptive types generated by GNAT should be ignored."),
14335      _("\
14336 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14337 DWARF attribute."),
14338      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14339
14340   decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
14341                                            NULL, xcalloc, xfree);
14342
14343   /* The ada-lang observers.  */
14344   gdb::observers::new_objfile.attach (ada_new_objfile_observer);
14345   gdb::observers::free_objfile.attach (ada_free_objfile_observer);
14346   gdb::observers::inferior_exit.attach (ada_inferior_exit);
14347 }
This page took 0.818559 seconds and 4 git commands to generate.