Remove cleanup from ada-lang.c
[external/binutils.git] / gdb / ada-lang.c
1 /* Ada language support routines for GDB, the GNU debugger.
2
3    Copyright (C) 1992-2018 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 "demangle.h"
24 #include "gdb_regex.h"
25 #include "frame.h"
26 #include "symtab.h"
27 #include "gdbtypes.h"
28 #include "gdbcmd.h"
29 #include "expression.h"
30 #include "parser-defs.h"
31 #include "language.h"
32 #include "varobj.h"
33 #include "c-lang.h"
34 #include "inferior.h"
35 #include "symfile.h"
36 #include "objfiles.h"
37 #include "breakpoint.h"
38 #include "gdbcore.h"
39 #include "hashtab.h"
40 #include "gdb_obstack.h"
41 #include "ada-lang.h"
42 #include "completer.h"
43 #include <sys/stat.h>
44 #include "ui-out.h"
45 #include "block.h"
46 #include "infcall.h"
47 #include "dictionary.h"
48 #include "annotate.h"
49 #include "valprint.h"
50 #include "source.h"
51 #include "observable.h"
52 #include "vec.h"
53 #include "stack.h"
54 #include "gdb_vecs.h"
55 #include "typeprint.h"
56 #include "namespace.h"
57
58 #include "psymtab.h"
59 #include "value.h"
60 #include "mi/mi-common.h"
61 #include "arch-utils.h"
62 #include "cli/cli-utils.h"
63 #include "common/function-view.h"
64 #include "common/byte-vector.h"
65 #include <algorithm>
66
67 /* Define whether or not the C operator '/' truncates towards zero for
68    differently signed operands (truncation direction is undefined in C).
69    Copied from valarith.c.  */
70
71 #ifndef TRUNCATION_TOWARDS_ZERO
72 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
73 #endif
74
75 static struct type *desc_base_type (struct type *);
76
77 static struct type *desc_bounds_type (struct type *);
78
79 static struct value *desc_bounds (struct value *);
80
81 static int fat_pntr_bounds_bitpos (struct type *);
82
83 static int fat_pntr_bounds_bitsize (struct type *);
84
85 static struct type *desc_data_target_type (struct type *);
86
87 static struct value *desc_data (struct value *);
88
89 static int fat_pntr_data_bitpos (struct type *);
90
91 static int fat_pntr_data_bitsize (struct type *);
92
93 static struct value *desc_one_bound (struct value *, int, int);
94
95 static int desc_bound_bitpos (struct type *, int, int);
96
97 static int desc_bound_bitsize (struct type *, int, int);
98
99 static struct type *desc_index_type (struct type *, int);
100
101 static int desc_arity (struct type *);
102
103 static int ada_type_match (struct type *, struct type *, int);
104
105 static int ada_args_match (struct symbol *, struct value **, int);
106
107 static struct value *make_array_descriptor (struct type *, struct value *);
108
109 static void ada_add_block_symbols (struct obstack *,
110                                    const struct block *,
111                                    const lookup_name_info &lookup_name,
112                                    domain_enum, struct objfile *);
113
114 static void ada_add_all_symbols (struct obstack *, const struct block *,
115                                  const lookup_name_info &lookup_name,
116                                  domain_enum, int, int *);
117
118 static int is_nonfunction (struct block_symbol *, int);
119
120 static void add_defn_to_vec (struct obstack *, struct symbol *,
121                              const struct block *);
122
123 static int num_defns_collected (struct obstack *);
124
125 static struct block_symbol *defns_collected (struct obstack *, int);
126
127 static struct value *resolve_subexp (expression_up *, int *, int,
128                                      struct type *);
129
130 static void replace_operator_with_call (expression_up *, int, int, int,
131                                         struct symbol *, const struct block *);
132
133 static int possible_user_operator_p (enum exp_opcode, struct value **);
134
135 static const char *ada_op_name (enum exp_opcode);
136
137 static const char *ada_decoded_op_name (enum exp_opcode);
138
139 static int numeric_type_p (struct type *);
140
141 static int integer_type_p (struct type *);
142
143 static int scalar_type_p (struct type *);
144
145 static int discrete_type_p (struct type *);
146
147 static enum ada_renaming_category parse_old_style_renaming (struct type *,
148                                                             const char **,
149                                                             int *,
150                                                             const char **);
151
152 static struct symbol *find_old_style_renaming_symbol (const char *,
153                                                       const struct block *);
154
155 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
156                                                 int, int);
157
158 static struct value *evaluate_subexp_type (struct expression *, int *);
159
160 static struct type *ada_find_parallel_type_with_name (struct type *,
161                                                       const char *);
162
163 static int is_dynamic_field (struct type *, int);
164
165 static struct type *to_fixed_variant_branch_type (struct type *,
166                                                   const gdb_byte *,
167                                                   CORE_ADDR, struct value *);
168
169 static struct type *to_fixed_array_type (struct type *, struct value *, int);
170
171 static struct type *to_fixed_range_type (struct type *, struct value *);
172
173 static struct type *to_static_fixed_type (struct type *);
174 static struct type *static_unwrap_type (struct type *type);
175
176 static struct value *unwrap_value (struct value *);
177
178 static struct type *constrained_packed_array_type (struct type *, long *);
179
180 static struct type *decode_constrained_packed_array_type (struct type *);
181
182 static long decode_packed_array_bitsize (struct type *);
183
184 static struct value *decode_constrained_packed_array (struct value *);
185
186 static int ada_is_packed_array_type  (struct type *);
187
188 static int ada_is_unconstrained_packed_array_type (struct type *);
189
190 static struct value *value_subscript_packed (struct value *, int,
191                                              struct value **);
192
193 static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
194
195 static struct value *coerce_unspec_val_to_type (struct value *,
196                                                 struct type *);
197
198 static int lesseq_defined_than (struct symbol *, struct symbol *);
199
200 static int equiv_types (struct type *, struct type *);
201
202 static int is_name_suffix (const char *);
203
204 static int advance_wild_match (const char **, const char *, int);
205
206 static bool wild_match (const char *name, const char *patn);
207
208 static struct value *ada_coerce_ref (struct value *);
209
210 static LONGEST pos_atr (struct value *);
211
212 static struct value *value_pos_atr (struct type *, struct value *);
213
214 static struct value *value_val_atr (struct type *, struct value *);
215
216 static struct symbol *standard_lookup (const char *, const struct block *,
217                                        domain_enum);
218
219 static struct value *ada_search_struct_field (const char *, struct value *, int,
220                                               struct type *);
221
222 static struct value *ada_value_primitive_field (struct value *, int, int,
223                                                 struct type *);
224
225 static int find_struct_field (const char *, struct type *, int,
226                               struct type **, int *, int *, int *, int *);
227
228 static int ada_resolve_function (struct block_symbol *, int,
229                                  struct value **, int, const char *,
230                                  struct type *);
231
232 static int ada_is_direct_array_type (struct type *);
233
234 static void ada_language_arch_info (struct gdbarch *,
235                                     struct language_arch_info *);
236
237 static struct value *ada_index_struct_field (int, struct value *, int,
238                                              struct type *);
239
240 static struct value *assign_aggregate (struct value *, struct value *, 
241                                        struct expression *,
242                                        int *, enum noside);
243
244 static void aggregate_assign_from_choices (struct value *, struct value *, 
245                                            struct expression *,
246                                            int *, LONGEST *, int *,
247                                            int, LONGEST, LONGEST);
248
249 static void aggregate_assign_positional (struct value *, struct value *,
250                                          struct expression *,
251                                          int *, LONGEST *, int *, int,
252                                          LONGEST, LONGEST);
253
254
255 static void aggregate_assign_others (struct value *, struct value *,
256                                      struct expression *,
257                                      int *, LONGEST *, int, LONGEST, LONGEST);
258
259
260 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
261
262
263 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
264                                           int *, enum noside);
265
266 static void ada_forward_operator_length (struct expression *, int, int *,
267                                          int *);
268
269 static struct type *ada_find_any_type (const char *name);
270
271 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
272   (const lookup_name_info &lookup_name);
273
274 \f
275
276 /* The result of a symbol lookup to be stored in our symbol cache.  */
277
278 struct cache_entry
279 {
280   /* The name used to perform the lookup.  */
281   const char *name;
282   /* The namespace used during the lookup.  */
283   domain_enum domain;
284   /* The symbol returned by the lookup, or NULL if no matching symbol
285      was found.  */
286   struct symbol *sym;
287   /* The block where the symbol was found, or NULL if no matching
288      symbol was found.  */
289   const struct block *block;
290   /* A pointer to the next entry with the same hash.  */
291   struct cache_entry *next;
292 };
293
294 /* The Ada symbol cache, used to store the result of Ada-mode symbol
295    lookups in the course of executing the user's commands.
296
297    The cache is implemented using a simple, fixed-sized hash.
298    The size is fixed on the grounds that there are not likely to be
299    all that many symbols looked up during any given session, regardless
300    of the size of the symbol table.  If we decide to go to a resizable
301    table, let's just use the stuff from libiberty instead.  */
302
303 #define HASH_SIZE 1009
304
305 struct ada_symbol_cache
306 {
307   /* An obstack used to store the entries in our cache.  */
308   struct obstack cache_space;
309
310   /* The root of the hash table used to implement our symbol cache.  */
311   struct cache_entry *root[HASH_SIZE];
312 };
313
314 static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
315
316 /* Maximum-sized dynamic type.  */
317 static unsigned int varsize_limit;
318
319 static const char ada_completer_word_break_characters[] =
320 #ifdef VMS
321   " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
322 #else
323   " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
324 #endif
325
326 /* The name of the symbol to use to get the name of the main subprogram.  */
327 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
328   = "__gnat_ada_main_program_name";
329
330 /* Limit on the number of warnings to raise per expression evaluation.  */
331 static int warning_limit = 2;
332
333 /* Number of warning messages issued; reset to 0 by cleanups after
334    expression evaluation.  */
335 static int warnings_issued = 0;
336
337 static const char *known_runtime_file_name_patterns[] = {
338   ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
339 };
340
341 static const char *known_auxiliary_function_name_patterns[] = {
342   ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
343 };
344
345 /* Maintenance-related settings for this module.  */
346
347 static struct cmd_list_element *maint_set_ada_cmdlist;
348 static struct cmd_list_element *maint_show_ada_cmdlist;
349
350 /* Implement the "maintenance set ada" (prefix) command.  */
351
352 static void
353 maint_set_ada_cmd (const char *args, int from_tty)
354 {
355   help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
356              gdb_stdout);
357 }
358
359 /* Implement the "maintenance show ada" (prefix) command.  */
360
361 static void
362 maint_show_ada_cmd (const char *args, int from_tty)
363 {
364   cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
365 }
366
367 /* The "maintenance ada set/show ignore-descriptive-type" value.  */
368
369 static int ada_ignore_descriptive_types_p = 0;
370
371                         /* Inferior-specific data.  */
372
373 /* Per-inferior data for this module.  */
374
375 struct ada_inferior_data
376 {
377   /* The ada__tags__type_specific_data type, which is used when decoding
378      tagged types.  With older versions of GNAT, this type was directly
379      accessible through a component ("tsd") in the object tag.  But this
380      is no longer the case, so we cache it for each inferior.  */
381   struct type *tsd_type;
382
383   /* The exception_support_info data.  This data is used to determine
384      how to implement support for Ada exception catchpoints in a given
385      inferior.  */
386   const struct exception_support_info *exception_info;
387 };
388
389 /* Our key to this module's inferior data.  */
390 static const struct inferior_data *ada_inferior_data;
391
392 /* A cleanup routine for our inferior data.  */
393 static void
394 ada_inferior_data_cleanup (struct inferior *inf, void *arg)
395 {
396   struct ada_inferior_data *data;
397
398   data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
399   if (data != NULL)
400     xfree (data);
401 }
402
403 /* Return our inferior data for the given inferior (INF).
404
405    This function always returns a valid pointer to an allocated
406    ada_inferior_data structure.  If INF's inferior data has not
407    been previously set, this functions creates a new one with all
408    fields set to zero, sets INF's inferior to it, and then returns
409    a pointer to that newly allocated ada_inferior_data.  */
410
411 static struct ada_inferior_data *
412 get_ada_inferior_data (struct inferior *inf)
413 {
414   struct ada_inferior_data *data;
415
416   data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
417   if (data == NULL)
418     {
419       data = XCNEW (struct ada_inferior_data);
420       set_inferior_data (inf, ada_inferior_data, data);
421     }
422
423   return data;
424 }
425
426 /* Perform all necessary cleanups regarding our module's inferior data
427    that is required after the inferior INF just exited.  */
428
429 static void
430 ada_inferior_exit (struct inferior *inf)
431 {
432   ada_inferior_data_cleanup (inf, NULL);
433   set_inferior_data (inf, ada_inferior_data, NULL);
434 }
435
436
437                         /* program-space-specific data.  */
438
439 /* This module's per-program-space data.  */
440 struct ada_pspace_data
441 {
442   /* The Ada symbol cache.  */
443   struct ada_symbol_cache *sym_cache;
444 };
445
446 /* Key to our per-program-space data.  */
447 static const struct program_space_data *ada_pspace_data_handle;
448
449 /* Return this module's data for the given program space (PSPACE).
450    If not is found, add a zero'ed one now.
451
452    This function always returns a valid object.  */
453
454 static struct ada_pspace_data *
455 get_ada_pspace_data (struct program_space *pspace)
456 {
457   struct ada_pspace_data *data;
458
459   data = ((struct ada_pspace_data *)
460           program_space_data (pspace, ada_pspace_data_handle));
461   if (data == NULL)
462     {
463       data = XCNEW (struct ada_pspace_data);
464       set_program_space_data (pspace, ada_pspace_data_handle, data);
465     }
466
467   return data;
468 }
469
470 /* The cleanup callback for this module's per-program-space data.  */
471
472 static void
473 ada_pspace_data_cleanup (struct program_space *pspace, void *data)
474 {
475   struct ada_pspace_data *pspace_data = (struct ada_pspace_data *) data;
476
477   if (pspace_data->sym_cache != NULL)
478     ada_free_symbol_cache (pspace_data->sym_cache);
479   xfree (pspace_data);
480 }
481
482                         /* Utilities */
483
484 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
485    all typedef layers have been peeled.  Otherwise, return TYPE.
486
487    Normally, we really expect a typedef type to only have 1 typedef layer.
488    In other words, we really expect the target type of a typedef type to be
489    a non-typedef type.  This is particularly true for Ada units, because
490    the language does not have a typedef vs not-typedef distinction.
491    In that respect, the Ada compiler has been trying to eliminate as many
492    typedef definitions in the debugging information, since they generally
493    do not bring any extra information (we still use typedef under certain
494    circumstances related mostly to the GNAT encoding).
495
496    Unfortunately, we have seen situations where the debugging information
497    generated by the compiler leads to such multiple typedef layers.  For
498    instance, consider the following example with stabs:
499
500      .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
501      .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
502
503    This is an error in the debugging information which causes type
504    pck__float_array___XUP to be defined twice, and the second time,
505    it is defined as a typedef of a typedef.
506
507    This is on the fringe of legality as far as debugging information is
508    concerned, and certainly unexpected.  But it is easy to handle these
509    situations correctly, so we can afford to be lenient in this case.  */
510
511 static struct type *
512 ada_typedef_target_type (struct type *type)
513 {
514   while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
515     type = TYPE_TARGET_TYPE (type);
516   return type;
517 }
518
519 /* Given DECODED_NAME a string holding a symbol name in its
520    decoded form (ie using the Ada dotted notation), returns
521    its unqualified name.  */
522
523 static const char *
524 ada_unqualified_name (const char *decoded_name)
525 {
526   const char *result;
527   
528   /* If the decoded name starts with '<', it means that the encoded
529      name does not follow standard naming conventions, and thus that
530      it is not your typical Ada symbol name.  Trying to unqualify it
531      is therefore pointless and possibly erroneous.  */
532   if (decoded_name[0] == '<')
533     return decoded_name;
534
535   result = strrchr (decoded_name, '.');
536   if (result != NULL)
537     result++;                   /* Skip the dot...  */
538   else
539     result = decoded_name;
540
541   return result;
542 }
543
544 /* Return a string starting with '<', followed by STR, and '>'.
545    The result is good until the next call.  */
546
547 static char *
548 add_angle_brackets (const char *str)
549 {
550   static char *result = NULL;
551
552   xfree (result);
553   result = xstrprintf ("<%s>", str);
554   return result;
555 }
556
557 static const char *
558 ada_get_gdb_completer_word_break_characters (void)
559 {
560   return ada_completer_word_break_characters;
561 }
562
563 /* Print an array element index using the Ada syntax.  */
564
565 static void
566 ada_print_array_index (struct value *index_value, struct ui_file *stream,
567                        const struct value_print_options *options)
568 {
569   LA_VALUE_PRINT (index_value, stream, options);
570   fprintf_filtered (stream, " => ");
571 }
572
573 /* Assuming VECT points to an array of *SIZE objects of size
574    ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
575    updating *SIZE as necessary and returning the (new) array.  */
576
577 void *
578 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
579 {
580   if (*size < min_size)
581     {
582       *size *= 2;
583       if (*size < min_size)
584         *size = min_size;
585       vect = xrealloc (vect, *size * element_size);
586     }
587   return vect;
588 }
589
590 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
591    suffix of FIELD_NAME beginning "___".  */
592
593 static int
594 field_name_match (const char *field_name, const char *target)
595 {
596   int len = strlen (target);
597
598   return
599     (strncmp (field_name, target, len) == 0
600      && (field_name[len] == '\0'
601          || (startswith (field_name + len, "___")
602              && strcmp (field_name + strlen (field_name) - 6,
603                         "___XVN") != 0)));
604 }
605
606
607 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
608    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
609    and return its index.  This function also handles fields whose name
610    have ___ suffixes because the compiler sometimes alters their name
611    by adding such a suffix to represent fields with certain constraints.
612    If the field could not be found, return a negative number if
613    MAYBE_MISSING is set.  Otherwise raise an error.  */
614
615 int
616 ada_get_field_index (const struct type *type, const char *field_name,
617                      int maybe_missing)
618 {
619   int fieldno;
620   struct type *struct_type = check_typedef ((struct type *) type);
621
622   for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
623     if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
624       return fieldno;
625
626   if (!maybe_missing)
627     error (_("Unable to find field %s in struct %s.  Aborting"),
628            field_name, TYPE_NAME (struct_type));
629
630   return -1;
631 }
632
633 /* The length of the prefix of NAME prior to any "___" suffix.  */
634
635 int
636 ada_name_prefix_len (const char *name)
637 {
638   if (name == NULL)
639     return 0;
640   else
641     {
642       const char *p = strstr (name, "___");
643
644       if (p == NULL)
645         return strlen (name);
646       else
647         return p - name;
648     }
649 }
650
651 /* Return non-zero if SUFFIX is a suffix of STR.
652    Return zero if STR is null.  */
653
654 static int
655 is_suffix (const char *str, const char *suffix)
656 {
657   int len1, len2;
658
659   if (str == NULL)
660     return 0;
661   len1 = strlen (str);
662   len2 = strlen (suffix);
663   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
664 }
665
666 /* The contents of value VAL, treated as a value of type TYPE.  The
667    result is an lval in memory if VAL is.  */
668
669 static struct value *
670 coerce_unspec_val_to_type (struct value *val, struct type *type)
671 {
672   type = ada_check_typedef (type);
673   if (value_type (val) == type)
674     return val;
675   else
676     {
677       struct value *result;
678
679       /* Make sure that the object size is not unreasonable before
680          trying to allocate some memory for it.  */
681       ada_ensure_varsize_limit (type);
682
683       if (value_lazy (val)
684           || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
685         result = allocate_value_lazy (type);
686       else
687         {
688           result = allocate_value (type);
689           value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
690         }
691       set_value_component_location (result, val);
692       set_value_bitsize (result, value_bitsize (val));
693       set_value_bitpos (result, value_bitpos (val));
694       set_value_address (result, value_address (val));
695       return result;
696     }
697 }
698
699 static const gdb_byte *
700 cond_offset_host (const gdb_byte *valaddr, long offset)
701 {
702   if (valaddr == NULL)
703     return NULL;
704   else
705     return valaddr + offset;
706 }
707
708 static CORE_ADDR
709 cond_offset_target (CORE_ADDR address, long offset)
710 {
711   if (address == 0)
712     return 0;
713   else
714     return address + offset;
715 }
716
717 /* Issue a warning (as for the definition of warning in utils.c, but
718    with exactly one argument rather than ...), unless the limit on the
719    number of warnings has passed during the evaluation of the current
720    expression.  */
721
722 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
723    provided by "complaint".  */
724 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
725
726 static void
727 lim_warning (const char *format, ...)
728 {
729   va_list args;
730
731   va_start (args, format);
732   warnings_issued += 1;
733   if (warnings_issued <= warning_limit)
734     vwarning (format, args);
735
736   va_end (args);
737 }
738
739 /* Issue an error if the size of an object of type T is unreasonable,
740    i.e. if it would be a bad idea to allocate a value of this type in
741    GDB.  */
742
743 void
744 ada_ensure_varsize_limit (const struct type *type)
745 {
746   if (TYPE_LENGTH (type) > varsize_limit)
747     error (_("object size is larger than varsize-limit"));
748 }
749
750 /* Maximum value of a SIZE-byte signed integer type.  */
751 static LONGEST
752 max_of_size (int size)
753 {
754   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
755
756   return top_bit | (top_bit - 1);
757 }
758
759 /* Minimum value of a SIZE-byte signed integer type.  */
760 static LONGEST
761 min_of_size (int size)
762 {
763   return -max_of_size (size) - 1;
764 }
765
766 /* Maximum value of a SIZE-byte unsigned integer type.  */
767 static ULONGEST
768 umax_of_size (int size)
769 {
770   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
771
772   return top_bit | (top_bit - 1);
773 }
774
775 /* Maximum value of integral type T, as a signed quantity.  */
776 static LONGEST
777 max_of_type (struct type *t)
778 {
779   if (TYPE_UNSIGNED (t))
780     return (LONGEST) umax_of_size (TYPE_LENGTH (t));
781   else
782     return max_of_size (TYPE_LENGTH (t));
783 }
784
785 /* Minimum value of integral type T, as a signed quantity.  */
786 static LONGEST
787 min_of_type (struct type *t)
788 {
789   if (TYPE_UNSIGNED (t)) 
790     return 0;
791   else
792     return min_of_size (TYPE_LENGTH (t));
793 }
794
795 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
796 LONGEST
797 ada_discrete_type_high_bound (struct type *type)
798 {
799   type = resolve_dynamic_type (type, NULL, 0);
800   switch (TYPE_CODE (type))
801     {
802     case TYPE_CODE_RANGE:
803       return TYPE_HIGH_BOUND (type);
804     case TYPE_CODE_ENUM:
805       return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
806     case TYPE_CODE_BOOL:
807       return 1;
808     case TYPE_CODE_CHAR:
809     case TYPE_CODE_INT:
810       return max_of_type (type);
811     default:
812       error (_("Unexpected type in ada_discrete_type_high_bound."));
813     }
814 }
815
816 /* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
817 LONGEST
818 ada_discrete_type_low_bound (struct type *type)
819 {
820   type = resolve_dynamic_type (type, NULL, 0);
821   switch (TYPE_CODE (type))
822     {
823     case TYPE_CODE_RANGE:
824       return TYPE_LOW_BOUND (type);
825     case TYPE_CODE_ENUM:
826       return TYPE_FIELD_ENUMVAL (type, 0);
827     case TYPE_CODE_BOOL:
828       return 0;
829     case TYPE_CODE_CHAR:
830     case TYPE_CODE_INT:
831       return min_of_type (type);
832     default:
833       error (_("Unexpected type in ada_discrete_type_low_bound."));
834     }
835 }
836
837 /* The identity on non-range types.  For range types, the underlying
838    non-range scalar type.  */
839
840 static struct type *
841 get_base_type (struct type *type)
842 {
843   while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
844     {
845       if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
846         return type;
847       type = TYPE_TARGET_TYPE (type);
848     }
849   return type;
850 }
851
852 /* Return a decoded version of the given VALUE.  This means returning
853    a value whose type is obtained by applying all the GNAT-specific
854    encondings, making the resulting type a static but standard description
855    of the initial type.  */
856
857 struct value *
858 ada_get_decoded_value (struct value *value)
859 {
860   struct type *type = ada_check_typedef (value_type (value));
861
862   if (ada_is_array_descriptor_type (type)
863       || (ada_is_constrained_packed_array_type (type)
864           && TYPE_CODE (type) != TYPE_CODE_PTR))
865     {
866       if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)  /* array access type.  */
867         value = ada_coerce_to_simple_array_ptr (value);
868       else
869         value = ada_coerce_to_simple_array (value);
870     }
871   else
872     value = ada_to_fixed_value (value);
873
874   return value;
875 }
876
877 /* Same as ada_get_decoded_value, but with the given TYPE.
878    Because there is no associated actual value for this type,
879    the resulting type might be a best-effort approximation in
880    the case of dynamic types.  */
881
882 struct type *
883 ada_get_decoded_type (struct type *type)
884 {
885   type = to_static_fixed_type (type);
886   if (ada_is_constrained_packed_array_type (type))
887     type = ada_coerce_to_simple_array_type (type);
888   return type;
889 }
890
891 \f
892
893                                 /* Language Selection */
894
895 /* If the main program is in Ada, return language_ada, otherwise return LANG
896    (the main program is in Ada iif the adainit symbol is found).  */
897
898 enum language
899 ada_update_initial_language (enum language lang)
900 {
901   if (lookup_minimal_symbol ("adainit", (const char *) NULL,
902                              (struct objfile *) NULL).minsym != NULL)
903     return language_ada;
904
905   return lang;
906 }
907
908 /* If the main procedure is written in Ada, then return its name.
909    The result is good until the next call.  Return NULL if the main
910    procedure doesn't appear to be in Ada.  */
911
912 char *
913 ada_main_name (void)
914 {
915   struct bound_minimal_symbol msym;
916   static gdb::unique_xmalloc_ptr<char> main_program_name;
917
918   /* For Ada, the name of the main procedure is stored in a specific
919      string constant, generated by the binder.  Look for that symbol,
920      extract its address, and then read that string.  If we didn't find
921      that string, then most probably the main procedure is not written
922      in Ada.  */
923   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
924
925   if (msym.minsym != NULL)
926     {
927       CORE_ADDR main_program_name_addr;
928       int err_code;
929
930       main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
931       if (main_program_name_addr == 0)
932         error (_("Invalid address for Ada main program name."));
933
934       target_read_string (main_program_name_addr, &main_program_name,
935                           1024, &err_code);
936
937       if (err_code != 0)
938         return NULL;
939       return main_program_name.get ();
940     }
941
942   /* The main procedure doesn't seem to be in Ada.  */
943   return NULL;
944 }
945 \f
946                                 /* Symbols */
947
948 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
949    of NULLs.  */
950
951 const struct ada_opname_map ada_opname_table[] = {
952   {"Oadd", "\"+\"", BINOP_ADD},
953   {"Osubtract", "\"-\"", BINOP_SUB},
954   {"Omultiply", "\"*\"", BINOP_MUL},
955   {"Odivide", "\"/\"", BINOP_DIV},
956   {"Omod", "\"mod\"", BINOP_MOD},
957   {"Orem", "\"rem\"", BINOP_REM},
958   {"Oexpon", "\"**\"", BINOP_EXP},
959   {"Olt", "\"<\"", BINOP_LESS},
960   {"Ole", "\"<=\"", BINOP_LEQ},
961   {"Ogt", "\">\"", BINOP_GTR},
962   {"Oge", "\">=\"", BINOP_GEQ},
963   {"Oeq", "\"=\"", BINOP_EQUAL},
964   {"One", "\"/=\"", BINOP_NOTEQUAL},
965   {"Oand", "\"and\"", BINOP_BITWISE_AND},
966   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
967   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
968   {"Oconcat", "\"&\"", BINOP_CONCAT},
969   {"Oabs", "\"abs\"", UNOP_ABS},
970   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
971   {"Oadd", "\"+\"", UNOP_PLUS},
972   {"Osubtract", "\"-\"", UNOP_NEG},
973   {NULL, NULL}
974 };
975
976 /* The "encoded" form of DECODED, according to GNAT conventions.  The
977    result is valid until the next call to ada_encode.  If
978    THROW_ERRORS, throw an error if invalid operator name is found.
979    Otherwise, return NULL in that case.  */
980
981 static char *
982 ada_encode_1 (const char *decoded, bool throw_errors)
983 {
984   static char *encoding_buffer = NULL;
985   static size_t encoding_buffer_size = 0;
986   const char *p;
987   int k;
988
989   if (decoded == NULL)
990     return NULL;
991
992   GROW_VECT (encoding_buffer, encoding_buffer_size,
993              2 * strlen (decoded) + 10);
994
995   k = 0;
996   for (p = decoded; *p != '\0'; p += 1)
997     {
998       if (*p == '.')
999         {
1000           encoding_buffer[k] = encoding_buffer[k + 1] = '_';
1001           k += 2;
1002         }
1003       else if (*p == '"')
1004         {
1005           const struct ada_opname_map *mapping;
1006
1007           for (mapping = ada_opname_table;
1008                mapping->encoded != NULL
1009                && !startswith (p, mapping->decoded); mapping += 1)
1010             ;
1011           if (mapping->encoded == NULL)
1012             {
1013               if (throw_errors)
1014                 error (_("invalid Ada operator name: %s"), p);
1015               else
1016                 return NULL;
1017             }
1018           strcpy (encoding_buffer + k, mapping->encoded);
1019           k += strlen (mapping->encoded);
1020           break;
1021         }
1022       else
1023         {
1024           encoding_buffer[k] = *p;
1025           k += 1;
1026         }
1027     }
1028
1029   encoding_buffer[k] = '\0';
1030   return encoding_buffer;
1031 }
1032
1033 /* The "encoded" form of DECODED, according to GNAT conventions.
1034    The result is valid until the next call to ada_encode.  */
1035
1036 char *
1037 ada_encode (const char *decoded)
1038 {
1039   return ada_encode_1 (decoded, true);
1040 }
1041
1042 /* Return NAME folded to lower case, or, if surrounded by single
1043    quotes, unfolded, but with the quotes stripped away.  Result good
1044    to next call.  */
1045
1046 char *
1047 ada_fold_name (const char *name)
1048 {
1049   static char *fold_buffer = NULL;
1050   static size_t fold_buffer_size = 0;
1051
1052   int len = strlen (name);
1053   GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
1054
1055   if (name[0] == '\'')
1056     {
1057       strncpy (fold_buffer, name + 1, len - 2);
1058       fold_buffer[len - 2] = '\000';
1059     }
1060   else
1061     {
1062       int i;
1063
1064       for (i = 0; i <= len; i += 1)
1065         fold_buffer[i] = tolower (name[i]);
1066     }
1067
1068   return fold_buffer;
1069 }
1070
1071 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
1072
1073 static int
1074 is_lower_alphanum (const char c)
1075 {
1076   return (isdigit (c) || (isalpha (c) && islower (c)));
1077 }
1078
1079 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1080    This function saves in LEN the length of that same symbol name but
1081    without either of these suffixes:
1082      . .{DIGIT}+
1083      . ${DIGIT}+
1084      . ___{DIGIT}+
1085      . __{DIGIT}+.
1086
1087    These are suffixes introduced by the compiler for entities such as
1088    nested subprogram for instance, in order to avoid name clashes.
1089    They do not serve any purpose for the debugger.  */
1090
1091 static void
1092 ada_remove_trailing_digits (const char *encoded, int *len)
1093 {
1094   if (*len > 1 && isdigit (encoded[*len - 1]))
1095     {
1096       int i = *len - 2;
1097
1098       while (i > 0 && isdigit (encoded[i]))
1099         i--;
1100       if (i >= 0 && encoded[i] == '.')
1101         *len = i;
1102       else if (i >= 0 && encoded[i] == '$')
1103         *len = i;
1104       else if (i >= 2 && startswith (encoded + i - 2, "___"))
1105         *len = i - 2;
1106       else if (i >= 1 && startswith (encoded + i - 1, "__"))
1107         *len = i - 1;
1108     }
1109 }
1110
1111 /* Remove the suffix introduced by the compiler for protected object
1112    subprograms.  */
1113
1114 static void
1115 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1116 {
1117   /* Remove trailing N.  */
1118
1119   /* Protected entry subprograms are broken into two
1120      separate subprograms: The first one is unprotected, and has
1121      a 'N' suffix; the second is the protected version, and has
1122      the 'P' suffix.  The second calls the first one after handling
1123      the protection.  Since the P subprograms are internally generated,
1124      we leave these names undecoded, giving the user a clue that this
1125      entity is internal.  */
1126
1127   if (*len > 1
1128       && encoded[*len - 1] == 'N'
1129       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1130     *len = *len - 1;
1131 }
1132
1133 /* Remove trailing X[bn]* suffixes (indicating names in package bodies).  */
1134
1135 static void
1136 ada_remove_Xbn_suffix (const char *encoded, int *len)
1137 {
1138   int i = *len - 1;
1139
1140   while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1141     i--;
1142
1143   if (encoded[i] != 'X')
1144     return;
1145
1146   if (i == 0)
1147     return;
1148
1149   if (isalnum (encoded[i-1]))
1150     *len = i;
1151 }
1152
1153 /* If ENCODED follows the GNAT entity encoding conventions, then return
1154    the decoded form of ENCODED.  Otherwise, return "<%s>" where "%s" is
1155    replaced by ENCODED.
1156
1157    The resulting string is valid until the next call of ada_decode.
1158    If the string is unchanged by decoding, the original string pointer
1159    is returned.  */
1160
1161 const char *
1162 ada_decode (const char *encoded)
1163 {
1164   int i, j;
1165   int len0;
1166   const char *p;
1167   char *decoded;
1168   int at_start_name;
1169   static char *decoding_buffer = NULL;
1170   static size_t decoding_buffer_size = 0;
1171
1172   /* The name of the Ada main procedure starts with "_ada_".
1173      This prefix is not part of the decoded name, so skip this part
1174      if we see this prefix.  */
1175   if (startswith (encoded, "_ada_"))
1176     encoded += 5;
1177
1178   /* If the name starts with '_', then it is not a properly encoded
1179      name, so do not attempt to decode it.  Similarly, if the name
1180      starts with '<', the name should not be decoded.  */
1181   if (encoded[0] == '_' || encoded[0] == '<')
1182     goto Suppress;
1183
1184   len0 = strlen (encoded);
1185
1186   ada_remove_trailing_digits (encoded, &len0);
1187   ada_remove_po_subprogram_suffix (encoded, &len0);
1188
1189   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1190      the suffix is located before the current "end" of ENCODED.  We want
1191      to avoid re-matching parts of ENCODED that have previously been
1192      marked as discarded (by decrementing LEN0).  */
1193   p = strstr (encoded, "___");
1194   if (p != NULL && p - encoded < len0 - 3)
1195     {
1196       if (p[3] == 'X')
1197         len0 = p - encoded;
1198       else
1199         goto Suppress;
1200     }
1201
1202   /* Remove any trailing TKB suffix.  It tells us that this symbol
1203      is for the body of a task, but that information does not actually
1204      appear in the decoded name.  */
1205
1206   if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1207     len0 -= 3;
1208
1209   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1210      from the TKB suffix because it is used for non-anonymous task
1211      bodies.  */
1212
1213   if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1214     len0 -= 2;
1215
1216   /* Remove trailing "B" suffixes.  */
1217   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1218
1219   if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1220     len0 -= 1;
1221
1222   /* Make decoded big enough for possible expansion by operator name.  */
1223
1224   GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1225   decoded = decoding_buffer;
1226
1227   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1228
1229   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1230     {
1231       i = len0 - 2;
1232       while ((i >= 0 && isdigit (encoded[i]))
1233              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1234         i -= 1;
1235       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1236         len0 = i - 1;
1237       else if (encoded[i] == '$')
1238         len0 = i;
1239     }
1240
1241   /* The first few characters that are not alphabetic are not part
1242      of any encoding we use, so we can copy them over verbatim.  */
1243
1244   for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1245     decoded[j] = encoded[i];
1246
1247   at_start_name = 1;
1248   while (i < len0)
1249     {
1250       /* Is this a symbol function?  */
1251       if (at_start_name && encoded[i] == 'O')
1252         {
1253           int k;
1254
1255           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1256             {
1257               int op_len = strlen (ada_opname_table[k].encoded);
1258               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1259                             op_len - 1) == 0)
1260                   && !isalnum (encoded[i + op_len]))
1261                 {
1262                   strcpy (decoded + j, ada_opname_table[k].decoded);
1263                   at_start_name = 0;
1264                   i += op_len;
1265                   j += strlen (ada_opname_table[k].decoded);
1266                   break;
1267                 }
1268             }
1269           if (ada_opname_table[k].encoded != NULL)
1270             continue;
1271         }
1272       at_start_name = 0;
1273
1274       /* Replace "TK__" with "__", which will eventually be translated
1275          into "." (just below).  */
1276
1277       if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1278         i += 2;
1279
1280       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1281          be translated into "." (just below).  These are internal names
1282          generated for anonymous blocks inside which our symbol is nested.  */
1283
1284       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1285           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1286           && isdigit (encoded [i+4]))
1287         {
1288           int k = i + 5;
1289           
1290           while (k < len0 && isdigit (encoded[k]))
1291             k++;  /* Skip any extra digit.  */
1292
1293           /* Double-check that the "__B_{DIGITS}+" sequence we found
1294              is indeed followed by "__".  */
1295           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1296             i = k;
1297         }
1298
1299       /* Remove _E{DIGITS}+[sb] */
1300
1301       /* Just as for protected object subprograms, there are 2 categories
1302          of subprograms created by the compiler for each entry.  The first
1303          one implements the actual entry code, and has a suffix following
1304          the convention above; the second one implements the barrier and
1305          uses the same convention as above, except that the 'E' is replaced
1306          by a 'B'.
1307
1308          Just as above, we do not decode the name of barrier functions
1309          to give the user a clue that the code he is debugging has been
1310          internally generated.  */
1311
1312       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1313           && isdigit (encoded[i+2]))
1314         {
1315           int k = i + 3;
1316
1317           while (k < len0 && isdigit (encoded[k]))
1318             k++;
1319
1320           if (k < len0
1321               && (encoded[k] == 'b' || encoded[k] == 's'))
1322             {
1323               k++;
1324               /* Just as an extra precaution, make sure that if this
1325                  suffix is followed by anything else, it is a '_'.
1326                  Otherwise, we matched this sequence by accident.  */
1327               if (k == len0
1328                   || (k < len0 && encoded[k] == '_'))
1329                 i = k;
1330             }
1331         }
1332
1333       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1334          the GNAT front-end in protected object subprograms.  */
1335
1336       if (i < len0 + 3
1337           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1338         {
1339           /* Backtrack a bit up until we reach either the begining of
1340              the encoded name, or "__".  Make sure that we only find
1341              digits or lowercase characters.  */
1342           const char *ptr = encoded + i - 1;
1343
1344           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1345             ptr--;
1346           if (ptr < encoded
1347               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1348             i++;
1349         }
1350
1351       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1352         {
1353           /* This is a X[bn]* sequence not separated from the previous
1354              part of the name with a non-alpha-numeric character (in other
1355              words, immediately following an alpha-numeric character), then
1356              verify that it is placed at the end of the encoded name.  If
1357              not, then the encoding is not valid and we should abort the
1358              decoding.  Otherwise, just skip it, it is used in body-nested
1359              package names.  */
1360           do
1361             i += 1;
1362           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1363           if (i < len0)
1364             goto Suppress;
1365         }
1366       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1367         {
1368          /* Replace '__' by '.'.  */
1369           decoded[j] = '.';
1370           at_start_name = 1;
1371           i += 2;
1372           j += 1;
1373         }
1374       else
1375         {
1376           /* It's a character part of the decoded name, so just copy it
1377              over.  */
1378           decoded[j] = encoded[i];
1379           i += 1;
1380           j += 1;
1381         }
1382     }
1383   decoded[j] = '\000';
1384
1385   /* Decoded names should never contain any uppercase character.
1386      Double-check this, and abort the decoding if we find one.  */
1387
1388   for (i = 0; decoded[i] != '\0'; i += 1)
1389     if (isupper (decoded[i]) || decoded[i] == ' ')
1390       goto Suppress;
1391
1392   if (strcmp (decoded, encoded) == 0)
1393     return encoded;
1394   else
1395     return decoded;
1396
1397 Suppress:
1398   GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1399   decoded = decoding_buffer;
1400   if (encoded[0] == '<')
1401     strcpy (decoded, encoded);
1402   else
1403     xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
1404   return decoded;
1405
1406 }
1407
1408 /* Table for keeping permanent unique copies of decoded names.  Once
1409    allocated, names in this table are never released.  While this is a
1410    storage leak, it should not be significant unless there are massive
1411    changes in the set of decoded names in successive versions of a 
1412    symbol table loaded during a single session.  */
1413 static struct htab *decoded_names_store;
1414
1415 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1416    in the language-specific part of GSYMBOL, if it has not been
1417    previously computed.  Tries to save the decoded name in the same
1418    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1419    in any case, the decoded symbol has a lifetime at least that of
1420    GSYMBOL).
1421    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1422    const, but nevertheless modified to a semantically equivalent form
1423    when a decoded name is cached in it.  */
1424
1425 const char *
1426 ada_decode_symbol (const struct general_symbol_info *arg)
1427 {
1428   struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1429   const char **resultp =
1430     &gsymbol->language_specific.demangled_name;
1431
1432   if (!gsymbol->ada_mangled)
1433     {
1434       const char *decoded = ada_decode (gsymbol->name);
1435       struct obstack *obstack = gsymbol->language_specific.obstack;
1436
1437       gsymbol->ada_mangled = 1;
1438
1439       if (obstack != NULL)
1440         *resultp
1441           = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
1442       else
1443         {
1444           /* Sometimes, we can't find a corresponding objfile, in
1445              which case, we put the result on the heap.  Since we only
1446              decode when needed, we hope this usually does not cause a
1447              significant memory leak (FIXME).  */
1448
1449           char **slot = (char **) htab_find_slot (decoded_names_store,
1450                                                   decoded, INSERT);
1451
1452           if (*slot == NULL)
1453             *slot = xstrdup (decoded);
1454           *resultp = *slot;
1455         }
1456     }
1457
1458   return *resultp;
1459 }
1460
1461 static char *
1462 ada_la_decode (const char *encoded, int options)
1463 {
1464   return xstrdup (ada_decode (encoded));
1465 }
1466
1467 /* Implement la_sniff_from_mangled_name for Ada.  */
1468
1469 static int
1470 ada_sniff_from_mangled_name (const char *mangled, char **out)
1471 {
1472   const char *demangled = ada_decode (mangled);
1473
1474   *out = NULL;
1475
1476   if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1477     {
1478       /* Set the gsymbol language to Ada, but still return 0.
1479          Two reasons for that:
1480
1481          1. For Ada, we prefer computing the symbol's decoded name
1482          on the fly rather than pre-compute it, in order to save
1483          memory (Ada projects are typically very large).
1484
1485          2. There are some areas in the definition of the GNAT
1486          encoding where, with a bit of bad luck, we might be able
1487          to decode a non-Ada symbol, generating an incorrect
1488          demangled name (Eg: names ending with "TB" for instance
1489          are identified as task bodies and so stripped from
1490          the decoded name returned).
1491
1492          Returning 1, here, but not setting *DEMANGLED, helps us get a
1493          little bit of the best of both worlds.  Because we're last,
1494          we should not affect any of the other languages that were
1495          able to demangle the symbol before us; we get to correctly
1496          tag Ada symbols as such; and even if we incorrectly tagged a
1497          non-Ada symbol, which should be rare, any routing through the
1498          Ada language should be transparent (Ada tries to behave much
1499          like C/C++ with non-Ada symbols).  */
1500       return 1;
1501     }
1502
1503   return 0;
1504 }
1505
1506 \f
1507
1508                                 /* Arrays */
1509
1510 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1511    generated by the GNAT compiler to describe the index type used
1512    for each dimension of an array, check whether it follows the latest
1513    known encoding.  If not, fix it up to conform to the latest encoding.
1514    Otherwise, do nothing.  This function also does nothing if
1515    INDEX_DESC_TYPE is NULL.
1516
1517    The GNAT encoding used to describle the array index type evolved a bit.
1518    Initially, the information would be provided through the name of each
1519    field of the structure type only, while the type of these fields was
1520    described as unspecified and irrelevant.  The debugger was then expected
1521    to perform a global type lookup using the name of that field in order
1522    to get access to the full index type description.  Because these global
1523    lookups can be very expensive, the encoding was later enhanced to make
1524    the global lookup unnecessary by defining the field type as being
1525    the full index type description.
1526
1527    The purpose of this routine is to allow us to support older versions
1528    of the compiler by detecting the use of the older encoding, and by
1529    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1530    we essentially replace each field's meaningless type by the associated
1531    index subtype).  */
1532
1533 void
1534 ada_fixup_array_indexes_type (struct type *index_desc_type)
1535 {
1536   int i;
1537
1538   if (index_desc_type == NULL)
1539     return;
1540   gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1541
1542   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1543      to check one field only, no need to check them all).  If not, return
1544      now.
1545
1546      If our INDEX_DESC_TYPE was generated using the older encoding,
1547      the field type should be a meaningless integer type whose name
1548      is not equal to the field name.  */
1549   if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1550       && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1551                  TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1552     return;
1553
1554   /* Fixup each field of INDEX_DESC_TYPE.  */
1555   for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1556    {
1557      const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1558      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1559
1560      if (raw_type)
1561        TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1562    }
1563 }
1564
1565 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors.  */
1566
1567 static const char *bound_name[] = {
1568   "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1569   "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1570 };
1571
1572 /* Maximum number of array dimensions we are prepared to handle.  */
1573
1574 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1575
1576
1577 /* The desc_* routines return primitive portions of array descriptors
1578    (fat pointers).  */
1579
1580 /* The descriptor or array type, if any, indicated by TYPE; removes
1581    level of indirection, if needed.  */
1582
1583 static struct type *
1584 desc_base_type (struct type *type)
1585 {
1586   if (type == NULL)
1587     return NULL;
1588   type = ada_check_typedef (type);
1589   if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1590     type = ada_typedef_target_type (type);
1591
1592   if (type != NULL
1593       && (TYPE_CODE (type) == TYPE_CODE_PTR
1594           || TYPE_CODE (type) == TYPE_CODE_REF))
1595     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1596   else
1597     return type;
1598 }
1599
1600 /* True iff TYPE indicates a "thin" array pointer type.  */
1601
1602 static int
1603 is_thin_pntr (struct type *type)
1604 {
1605   return
1606     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1607     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1608 }
1609
1610 /* The descriptor type for thin pointer type TYPE.  */
1611
1612 static struct type *
1613 thin_descriptor_type (struct type *type)
1614 {
1615   struct type *base_type = desc_base_type (type);
1616
1617   if (base_type == NULL)
1618     return NULL;
1619   if (is_suffix (ada_type_name (base_type), "___XVE"))
1620     return base_type;
1621   else
1622     {
1623       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1624
1625       if (alt_type == NULL)
1626         return base_type;
1627       else
1628         return alt_type;
1629     }
1630 }
1631
1632 /* A pointer to the array data for thin-pointer value VAL.  */
1633
1634 static struct value *
1635 thin_data_pntr (struct value *val)
1636 {
1637   struct type *type = ada_check_typedef (value_type (val));
1638   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1639
1640   data_type = lookup_pointer_type (data_type);
1641
1642   if (TYPE_CODE (type) == TYPE_CODE_PTR)
1643     return value_cast (data_type, value_copy (val));
1644   else
1645     return value_from_longest (data_type, value_address (val));
1646 }
1647
1648 /* True iff TYPE indicates a "thick" array pointer type.  */
1649
1650 static int
1651 is_thick_pntr (struct type *type)
1652 {
1653   type = desc_base_type (type);
1654   return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1655           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1656 }
1657
1658 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1659    pointer to one, the type of its bounds data; otherwise, NULL.  */
1660
1661 static struct type *
1662 desc_bounds_type (struct type *type)
1663 {
1664   struct type *r;
1665
1666   type = desc_base_type (type);
1667
1668   if (type == NULL)
1669     return NULL;
1670   else if (is_thin_pntr (type))
1671     {
1672       type = thin_descriptor_type (type);
1673       if (type == NULL)
1674         return NULL;
1675       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1676       if (r != NULL)
1677         return ada_check_typedef (r);
1678     }
1679   else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1680     {
1681       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1682       if (r != NULL)
1683         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1684     }
1685   return NULL;
1686 }
1687
1688 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1689    one, a pointer to its bounds data.   Otherwise NULL.  */
1690
1691 static struct value *
1692 desc_bounds (struct value *arr)
1693 {
1694   struct type *type = ada_check_typedef (value_type (arr));
1695
1696   if (is_thin_pntr (type))
1697     {
1698       struct type *bounds_type =
1699         desc_bounds_type (thin_descriptor_type (type));
1700       LONGEST addr;
1701
1702       if (bounds_type == NULL)
1703         error (_("Bad GNAT array descriptor"));
1704
1705       /* NOTE: The following calculation is not really kosher, but
1706          since desc_type is an XVE-encoded type (and shouldn't be),
1707          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1708       if (TYPE_CODE (type) == TYPE_CODE_PTR)
1709         addr = value_as_long (arr);
1710       else
1711         addr = value_address (arr);
1712
1713       return
1714         value_from_longest (lookup_pointer_type (bounds_type),
1715                             addr - TYPE_LENGTH (bounds_type));
1716     }
1717
1718   else if (is_thick_pntr (type))
1719     {
1720       struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1721                                                _("Bad GNAT array descriptor"));
1722       struct type *p_bounds_type = value_type (p_bounds);
1723
1724       if (p_bounds_type
1725           && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1726         {
1727           struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1728
1729           if (TYPE_STUB (target_type))
1730             p_bounds = value_cast (lookup_pointer_type
1731                                    (ada_check_typedef (target_type)),
1732                                    p_bounds);
1733         }
1734       else
1735         error (_("Bad GNAT array descriptor"));
1736
1737       return p_bounds;
1738     }
1739   else
1740     return NULL;
1741 }
1742
1743 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1744    position of the field containing the address of the bounds data.  */
1745
1746 static int
1747 fat_pntr_bounds_bitpos (struct type *type)
1748 {
1749   return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1750 }
1751
1752 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1753    size of the field containing the address of the bounds data.  */
1754
1755 static int
1756 fat_pntr_bounds_bitsize (struct type *type)
1757 {
1758   type = desc_base_type (type);
1759
1760   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1761     return TYPE_FIELD_BITSIZE (type, 1);
1762   else
1763     return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1764 }
1765
1766 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1767    pointer to one, the type of its array data (a array-with-no-bounds type);
1768    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1769    data.  */
1770
1771 static struct type *
1772 desc_data_target_type (struct type *type)
1773 {
1774   type = desc_base_type (type);
1775
1776   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1777   if (is_thin_pntr (type))
1778     return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
1779   else if (is_thick_pntr (type))
1780     {
1781       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1782
1783       if (data_type
1784           && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
1785         return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1786     }
1787
1788   return NULL;
1789 }
1790
1791 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1792    its array data.  */
1793
1794 static struct value *
1795 desc_data (struct value *arr)
1796 {
1797   struct type *type = value_type (arr);
1798
1799   if (is_thin_pntr (type))
1800     return thin_data_pntr (arr);
1801   else if (is_thick_pntr (type))
1802     return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1803                              _("Bad GNAT array descriptor"));
1804   else
1805     return NULL;
1806 }
1807
1808
1809 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1810    position of the field containing the address of the data.  */
1811
1812 static int
1813 fat_pntr_data_bitpos (struct type *type)
1814 {
1815   return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1816 }
1817
1818 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1819    size of the field containing the address of the data.  */
1820
1821 static int
1822 fat_pntr_data_bitsize (struct type *type)
1823 {
1824   type = desc_base_type (type);
1825
1826   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1827     return TYPE_FIELD_BITSIZE (type, 0);
1828   else
1829     return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1830 }
1831
1832 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1833    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1834    bound, if WHICH is 1.  The first bound is I=1.  */
1835
1836 static struct value *
1837 desc_one_bound (struct value *bounds, int i, int which)
1838 {
1839   return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1840                            _("Bad GNAT array descriptor bounds"));
1841 }
1842
1843 /* If BOUNDS is an array-bounds structure type, return the bit position
1844    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1845    bound, if WHICH is 1.  The first bound is I=1.  */
1846
1847 static int
1848 desc_bound_bitpos (struct type *type, int i, int which)
1849 {
1850   return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1851 }
1852
1853 /* If BOUNDS is an array-bounds structure type, return the bit field size
1854    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1855    bound, if WHICH is 1.  The first bound is I=1.  */
1856
1857 static int
1858 desc_bound_bitsize (struct type *type, int i, int which)
1859 {
1860   type = desc_base_type (type);
1861
1862   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1863     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1864   else
1865     return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1866 }
1867
1868 /* If TYPE is the type of an array-bounds structure, the type of its
1869    Ith bound (numbering from 1).  Otherwise, NULL.  */
1870
1871 static struct type *
1872 desc_index_type (struct type *type, int i)
1873 {
1874   type = desc_base_type (type);
1875
1876   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1877     return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1878   else
1879     return NULL;
1880 }
1881
1882 /* The number of index positions in the array-bounds type TYPE.
1883    Return 0 if TYPE is NULL.  */
1884
1885 static int
1886 desc_arity (struct type *type)
1887 {
1888   type = desc_base_type (type);
1889
1890   if (type != NULL)
1891     return TYPE_NFIELDS (type) / 2;
1892   return 0;
1893 }
1894
1895 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
1896    an array descriptor type (representing an unconstrained array
1897    type).  */
1898
1899 static int
1900 ada_is_direct_array_type (struct type *type)
1901 {
1902   if (type == NULL)
1903     return 0;
1904   type = ada_check_typedef (type);
1905   return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1906           || ada_is_array_descriptor_type (type));
1907 }
1908
1909 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1910  * to one.  */
1911
1912 static int
1913 ada_is_array_type (struct type *type)
1914 {
1915   while (type != NULL 
1916          && (TYPE_CODE (type) == TYPE_CODE_PTR 
1917              || TYPE_CODE (type) == TYPE_CODE_REF))
1918     type = TYPE_TARGET_TYPE (type);
1919   return ada_is_direct_array_type (type);
1920 }
1921
1922 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
1923
1924 int
1925 ada_is_simple_array_type (struct type *type)
1926 {
1927   if (type == NULL)
1928     return 0;
1929   type = ada_check_typedef (type);
1930   return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1931           || (TYPE_CODE (type) == TYPE_CODE_PTR
1932               && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1933                  == TYPE_CODE_ARRAY));
1934 }
1935
1936 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
1937
1938 int
1939 ada_is_array_descriptor_type (struct type *type)
1940 {
1941   struct type *data_type = desc_data_target_type (type);
1942
1943   if (type == NULL)
1944     return 0;
1945   type = ada_check_typedef (type);
1946   return (data_type != NULL
1947           && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1948           && desc_arity (desc_bounds_type (type)) > 0);
1949 }
1950
1951 /* Non-zero iff type is a partially mal-formed GNAT array
1952    descriptor.  FIXME: This is to compensate for some problems with
1953    debugging output from GNAT.  Re-examine periodically to see if it
1954    is still needed.  */
1955
1956 int
1957 ada_is_bogus_array_descriptor (struct type *type)
1958 {
1959   return
1960     type != NULL
1961     && TYPE_CODE (type) == TYPE_CODE_STRUCT
1962     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1963         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1964     && !ada_is_array_descriptor_type (type);
1965 }
1966
1967
1968 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1969    (fat pointer) returns the type of the array data described---specifically,
1970    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
1971    in from the descriptor; otherwise, they are left unspecified.  If
1972    the ARR denotes a null array descriptor and BOUNDS is non-zero,
1973    returns NULL.  The result is simply the type of ARR if ARR is not
1974    a descriptor.  */
1975 struct type *
1976 ada_type_of_array (struct value *arr, int bounds)
1977 {
1978   if (ada_is_constrained_packed_array_type (value_type (arr)))
1979     return decode_constrained_packed_array_type (value_type (arr));
1980
1981   if (!ada_is_array_descriptor_type (value_type (arr)))
1982     return value_type (arr);
1983
1984   if (!bounds)
1985     {
1986       struct type *array_type =
1987         ada_check_typedef (desc_data_target_type (value_type (arr)));
1988
1989       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1990         TYPE_FIELD_BITSIZE (array_type, 0) =
1991           decode_packed_array_bitsize (value_type (arr));
1992       
1993       return array_type;
1994     }
1995   else
1996     {
1997       struct type *elt_type;
1998       int arity;
1999       struct value *descriptor;
2000
2001       elt_type = ada_array_element_type (value_type (arr), -1);
2002       arity = ada_array_arity (value_type (arr));
2003
2004       if (elt_type == NULL || arity == 0)
2005         return ada_check_typedef (value_type (arr));
2006
2007       descriptor = desc_bounds (arr);
2008       if (value_as_long (descriptor) == 0)
2009         return NULL;
2010       while (arity > 0)
2011         {
2012           struct type *range_type = alloc_type_copy (value_type (arr));
2013           struct type *array_type = alloc_type_copy (value_type (arr));
2014           struct value *low = desc_one_bound (descriptor, arity, 0);
2015           struct value *high = desc_one_bound (descriptor, arity, 1);
2016
2017           arity -= 1;
2018           create_static_range_type (range_type, value_type (low),
2019                                     longest_to_int (value_as_long (low)),
2020                                     longest_to_int (value_as_long (high)));
2021           elt_type = create_array_type (array_type, elt_type, range_type);
2022
2023           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2024             {
2025               /* We need to store the element packed bitsize, as well as
2026                  recompute the array size, because it was previously
2027                  computed based on the unpacked element size.  */
2028               LONGEST lo = value_as_long (low);
2029               LONGEST hi = value_as_long (high);
2030
2031               TYPE_FIELD_BITSIZE (elt_type, 0) =
2032                 decode_packed_array_bitsize (value_type (arr));
2033               /* If the array has no element, then the size is already
2034                  zero, and does not need to be recomputed.  */
2035               if (lo < hi)
2036                 {
2037                   int array_bitsize =
2038                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2039
2040                   TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2041                 }
2042             }
2043         }
2044
2045       return lookup_pointer_type (elt_type);
2046     }
2047 }
2048
2049 /* If ARR does not represent an array, returns ARR unchanged.
2050    Otherwise, returns either a standard GDB array with bounds set
2051    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2052    GDB array.  Returns NULL if ARR is a null fat pointer.  */
2053
2054 struct value *
2055 ada_coerce_to_simple_array_ptr (struct value *arr)
2056 {
2057   if (ada_is_array_descriptor_type (value_type (arr)))
2058     {
2059       struct type *arrType = ada_type_of_array (arr, 1);
2060
2061       if (arrType == NULL)
2062         return NULL;
2063       return value_cast (arrType, value_copy (desc_data (arr)));
2064     }
2065   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2066     return decode_constrained_packed_array (arr);
2067   else
2068     return arr;
2069 }
2070
2071 /* If ARR does not represent an array, returns ARR unchanged.
2072    Otherwise, returns a standard GDB array describing ARR (which may
2073    be ARR itself if it already is in the proper form).  */
2074
2075 struct value *
2076 ada_coerce_to_simple_array (struct value *arr)
2077 {
2078   if (ada_is_array_descriptor_type (value_type (arr)))
2079     {
2080       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2081
2082       if (arrVal == NULL)
2083         error (_("Bounds unavailable for null array pointer."));
2084       ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
2085       return value_ind (arrVal);
2086     }
2087   else if (ada_is_constrained_packed_array_type (value_type (arr)))
2088     return decode_constrained_packed_array (arr);
2089   else
2090     return arr;
2091 }
2092
2093 /* If TYPE represents a GNAT array type, return it translated to an
2094    ordinary GDB array type (possibly with BITSIZE fields indicating
2095    packing).  For other types, is the identity.  */
2096
2097 struct type *
2098 ada_coerce_to_simple_array_type (struct type *type)
2099 {
2100   if (ada_is_constrained_packed_array_type (type))
2101     return decode_constrained_packed_array_type (type);
2102
2103   if (ada_is_array_descriptor_type (type))
2104     return ada_check_typedef (desc_data_target_type (type));
2105
2106   return type;
2107 }
2108
2109 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
2110
2111 static int
2112 ada_is_packed_array_type  (struct type *type)
2113 {
2114   if (type == NULL)
2115     return 0;
2116   type = desc_base_type (type);
2117   type = ada_check_typedef (type);
2118   return
2119     ada_type_name (type) != NULL
2120     && strstr (ada_type_name (type), "___XP") != NULL;
2121 }
2122
2123 /* Non-zero iff TYPE represents a standard GNAT constrained
2124    packed-array type.  */
2125
2126 int
2127 ada_is_constrained_packed_array_type (struct type *type)
2128 {
2129   return ada_is_packed_array_type (type)
2130     && !ada_is_array_descriptor_type (type);
2131 }
2132
2133 /* Non-zero iff TYPE represents an array descriptor for a
2134    unconstrained packed-array type.  */
2135
2136 static int
2137 ada_is_unconstrained_packed_array_type (struct type *type)
2138 {
2139   return ada_is_packed_array_type (type)
2140     && ada_is_array_descriptor_type (type);
2141 }
2142
2143 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2144    return the size of its elements in bits.  */
2145
2146 static long
2147 decode_packed_array_bitsize (struct type *type)
2148 {
2149   const char *raw_name;
2150   const char *tail;
2151   long bits;
2152
2153   /* Access to arrays implemented as fat pointers are encoded as a typedef
2154      of the fat pointer type.  We need the name of the fat pointer type
2155      to do the decoding, so strip the typedef layer.  */
2156   if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2157     type = ada_typedef_target_type (type);
2158
2159   raw_name = ada_type_name (ada_check_typedef (type));
2160   if (!raw_name)
2161     raw_name = ada_type_name (desc_base_type (type));
2162
2163   if (!raw_name)
2164     return 0;
2165
2166   tail = strstr (raw_name, "___XP");
2167   gdb_assert (tail != NULL);
2168
2169   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2170     {
2171       lim_warning
2172         (_("could not understand bit size information on packed array"));
2173       return 0;
2174     }
2175
2176   return bits;
2177 }
2178
2179 /* Given that TYPE is a standard GDB array type with all bounds filled
2180    in, and that the element size of its ultimate scalar constituents
2181    (that is, either its elements, or, if it is an array of arrays, its
2182    elements' elements, etc.) is *ELT_BITS, return an identical type,
2183    but with the bit sizes of its elements (and those of any
2184    constituent arrays) recorded in the BITSIZE components of its
2185    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2186    in bits.
2187
2188    Note that, for arrays whose index type has an XA encoding where
2189    a bound references a record discriminant, getting that discriminant,
2190    and therefore the actual value of that bound, is not possible
2191    because none of the given parameters gives us access to the record.
2192    This function assumes that it is OK in the context where it is being
2193    used to return an array whose bounds are still dynamic and where
2194    the length is arbitrary.  */
2195
2196 static struct type *
2197 constrained_packed_array_type (struct type *type, long *elt_bits)
2198 {
2199   struct type *new_elt_type;
2200   struct type *new_type;
2201   struct type *index_type_desc;
2202   struct type *index_type;
2203   LONGEST low_bound, high_bound;
2204
2205   type = ada_check_typedef (type);
2206   if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2207     return type;
2208
2209   index_type_desc = ada_find_parallel_type (type, "___XA");
2210   if (index_type_desc)
2211     index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2212                                       NULL);
2213   else
2214     index_type = TYPE_INDEX_TYPE (type);
2215
2216   new_type = alloc_type_copy (type);
2217   new_elt_type =
2218     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2219                                    elt_bits);
2220   create_array_type (new_type, new_elt_type, index_type);
2221   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2222   TYPE_NAME (new_type) = ada_type_name (type);
2223
2224   if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2225        && is_dynamic_type (check_typedef (index_type)))
2226       || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
2227     low_bound = high_bound = 0;
2228   if (high_bound < low_bound)
2229     *elt_bits = TYPE_LENGTH (new_type) = 0;
2230   else
2231     {
2232       *elt_bits *= (high_bound - low_bound + 1);
2233       TYPE_LENGTH (new_type) =
2234         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2235     }
2236
2237   TYPE_FIXED_INSTANCE (new_type) = 1;
2238   return new_type;
2239 }
2240
2241 /* The array type encoded by TYPE, where
2242    ada_is_constrained_packed_array_type (TYPE).  */
2243
2244 static struct type *
2245 decode_constrained_packed_array_type (struct type *type)
2246 {
2247   const char *raw_name = ada_type_name (ada_check_typedef (type));
2248   char *name;
2249   const char *tail;
2250   struct type *shadow_type;
2251   long bits;
2252
2253   if (!raw_name)
2254     raw_name = ada_type_name (desc_base_type (type));
2255
2256   if (!raw_name)
2257     return NULL;
2258
2259   name = (char *) alloca (strlen (raw_name) + 1);
2260   tail = strstr (raw_name, "___XP");
2261   type = desc_base_type (type);
2262
2263   memcpy (name, raw_name, tail - raw_name);
2264   name[tail - raw_name] = '\000';
2265
2266   shadow_type = ada_find_parallel_type_with_name (type, name);
2267
2268   if (shadow_type == NULL)
2269     {
2270       lim_warning (_("could not find bounds information on packed array"));
2271       return NULL;
2272     }
2273   shadow_type = check_typedef (shadow_type);
2274
2275   if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2276     {
2277       lim_warning (_("could not understand bounds "
2278                      "information on packed array"));
2279       return NULL;
2280     }
2281
2282   bits = decode_packed_array_bitsize (type);
2283   return constrained_packed_array_type (shadow_type, &bits);
2284 }
2285
2286 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2287    array, returns a simple array that denotes that array.  Its type is a
2288    standard GDB array type except that the BITSIZEs of the array
2289    target types are set to the number of bits in each element, and the
2290    type length is set appropriately.  */
2291
2292 static struct value *
2293 decode_constrained_packed_array (struct value *arr)
2294 {
2295   struct type *type;
2296
2297   /* If our value is a pointer, then dereference it. Likewise if
2298      the value is a reference.  Make sure that this operation does not
2299      cause the target type to be fixed, as this would indirectly cause
2300      this array to be decoded.  The rest of the routine assumes that
2301      the array hasn't been decoded yet, so we use the basic "coerce_ref"
2302      and "value_ind" routines to perform the dereferencing, as opposed
2303      to using "ada_coerce_ref" or "ada_value_ind".  */
2304   arr = coerce_ref (arr);
2305   if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
2306     arr = value_ind (arr);
2307
2308   type = decode_constrained_packed_array_type (value_type (arr));
2309   if (type == NULL)
2310     {
2311       error (_("can't unpack array"));
2312       return NULL;
2313     }
2314
2315   if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
2316       && ada_is_modular_type (value_type (arr)))
2317     {
2318        /* This is a (right-justified) modular type representing a packed
2319          array with no wrapper.  In order to interpret the value through
2320          the (left-justified) packed array type we just built, we must
2321          first left-justify it.  */
2322       int bit_size, bit_pos;
2323       ULONGEST mod;
2324
2325       mod = ada_modulus (value_type (arr)) - 1;
2326       bit_size = 0;
2327       while (mod > 0)
2328         {
2329           bit_size += 1;
2330           mod >>= 1;
2331         }
2332       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2333       arr = ada_value_primitive_packed_val (arr, NULL,
2334                                             bit_pos / HOST_CHAR_BIT,
2335                                             bit_pos % HOST_CHAR_BIT,
2336                                             bit_size,
2337                                             type);
2338     }
2339
2340   return coerce_unspec_val_to_type (arr, type);
2341 }
2342
2343
2344 /* The value of the element of packed array ARR at the ARITY indices
2345    given in IND.   ARR must be a simple array.  */
2346
2347 static struct value *
2348 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2349 {
2350   int i;
2351   int bits, elt_off, bit_off;
2352   long elt_total_bit_offset;
2353   struct type *elt_type;
2354   struct value *v;
2355
2356   bits = 0;
2357   elt_total_bit_offset = 0;
2358   elt_type = ada_check_typedef (value_type (arr));
2359   for (i = 0; i < arity; i += 1)
2360     {
2361       if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
2362           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2363         error
2364           (_("attempt to do packed indexing of "
2365              "something other than a packed array"));
2366       else
2367         {
2368           struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2369           LONGEST lowerbound, upperbound;
2370           LONGEST idx;
2371
2372           if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2373             {
2374               lim_warning (_("don't know bounds of array"));
2375               lowerbound = upperbound = 0;
2376             }
2377
2378           idx = pos_atr (ind[i]);
2379           if (idx < lowerbound || idx > upperbound)
2380             lim_warning (_("packed array index %ld out of bounds"),
2381                          (long) idx);
2382           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2383           elt_total_bit_offset += (idx - lowerbound) * bits;
2384           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2385         }
2386     }
2387   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2388   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2389
2390   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2391                                       bits, elt_type);
2392   return v;
2393 }
2394
2395 /* Non-zero iff TYPE includes negative integer values.  */
2396
2397 static int
2398 has_negatives (struct type *type)
2399 {
2400   switch (TYPE_CODE (type))
2401     {
2402     default:
2403       return 0;
2404     case TYPE_CODE_INT:
2405       return !TYPE_UNSIGNED (type);
2406     case TYPE_CODE_RANGE:
2407       return TYPE_LOW_BOUND (type) < 0;
2408     }
2409 }
2410
2411 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2412    unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
2413    the unpacked buffer.
2414
2415    The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2416    enough to contain at least BIT_OFFSET bits.  If not, an error is raised.
2417
2418    IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2419    zero otherwise.
2420
2421    IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2422
2423    IS_SCALAR is nonzero if the data corresponds to a signed type.  */
2424
2425 static void
2426 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2427                           gdb_byte *unpacked, int unpacked_len,
2428                           int is_big_endian, int is_signed_type,
2429                           int is_scalar)
2430 {
2431   int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2432   int src_idx;                  /* Index into the source area */
2433   int src_bytes_left;           /* Number of source bytes left to process.  */
2434   int srcBitsLeft;              /* Number of source bits left to move */
2435   int unusedLS;                 /* Number of bits in next significant
2436                                    byte of source that are unused */
2437
2438   int unpacked_idx;             /* Index into the unpacked buffer */
2439   int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */
2440
2441   unsigned long accum;          /* Staging area for bits being transferred */
2442   int accumSize;                /* Number of meaningful bits in accum */
2443   unsigned char sign;
2444
2445   /* Transmit bytes from least to most significant; delta is the direction
2446      the indices move.  */
2447   int delta = is_big_endian ? -1 : 1;
2448
2449   /* Make sure that unpacked is large enough to receive the BIT_SIZE
2450      bits from SRC.  .*/
2451   if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2452     error (_("Cannot unpack %d bits into buffer of %d bytes"),
2453            bit_size, unpacked_len);
2454
2455   srcBitsLeft = bit_size;
2456   src_bytes_left = src_len;
2457   unpacked_bytes_left = unpacked_len;
2458   sign = 0;
2459
2460   if (is_big_endian)
2461     {
2462       src_idx = src_len - 1;
2463       if (is_signed_type
2464           && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2465         sign = ~0;
2466
2467       unusedLS =
2468         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2469         % HOST_CHAR_BIT;
2470
2471       if (is_scalar)
2472         {
2473           accumSize = 0;
2474           unpacked_idx = unpacked_len - 1;
2475         }
2476       else
2477         {
2478           /* Non-scalar values must be aligned at a byte boundary...  */
2479           accumSize =
2480             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2481           /* ... And are placed at the beginning (most-significant) bytes
2482              of the target.  */
2483           unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2484           unpacked_bytes_left = unpacked_idx + 1;
2485         }
2486     }
2487   else
2488     {
2489       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2490
2491       src_idx = unpacked_idx = 0;
2492       unusedLS = bit_offset;
2493       accumSize = 0;
2494
2495       if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2496         sign = ~0;
2497     }
2498
2499   accum = 0;
2500   while (src_bytes_left > 0)
2501     {
2502       /* Mask for removing bits of the next source byte that are not
2503          part of the value.  */
2504       unsigned int unusedMSMask =
2505         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2506         1;
2507       /* Sign-extend bits for this byte.  */
2508       unsigned int signMask = sign & ~unusedMSMask;
2509
2510       accum |=
2511         (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2512       accumSize += HOST_CHAR_BIT - unusedLS;
2513       if (accumSize >= HOST_CHAR_BIT)
2514         {
2515           unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2516           accumSize -= HOST_CHAR_BIT;
2517           accum >>= HOST_CHAR_BIT;
2518           unpacked_bytes_left -= 1;
2519           unpacked_idx += delta;
2520         }
2521       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2522       unusedLS = 0;
2523       src_bytes_left -= 1;
2524       src_idx += delta;
2525     }
2526   while (unpacked_bytes_left > 0)
2527     {
2528       accum |= sign << accumSize;
2529       unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2530       accumSize -= HOST_CHAR_BIT;
2531       if (accumSize < 0)
2532         accumSize = 0;
2533       accum >>= HOST_CHAR_BIT;
2534       unpacked_bytes_left -= 1;
2535       unpacked_idx += delta;
2536     }
2537 }
2538
2539 /* Create a new value of type TYPE from the contents of OBJ starting
2540    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2541    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2542    assigning through the result will set the field fetched from.
2543    VALADDR is ignored unless OBJ is NULL, in which case,
2544    VALADDR+OFFSET must address the start of storage containing the 
2545    packed value.  The value returned  in this case is never an lval.
2546    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2547
2548 struct value *
2549 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2550                                 long offset, int bit_offset, int bit_size,
2551                                 struct type *type)
2552 {
2553   struct value *v;
2554   const gdb_byte *src;                /* First byte containing data to unpack */
2555   gdb_byte *unpacked;
2556   const int is_scalar = is_scalar_type (type);
2557   const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
2558   gdb::byte_vector staging;
2559
2560   type = ada_check_typedef (type);
2561
2562   if (obj == NULL)
2563     src = valaddr + offset;
2564   else
2565     src = value_contents (obj) + offset;
2566
2567   if (is_dynamic_type (type))
2568     {
2569       /* The length of TYPE might by dynamic, so we need to resolve
2570          TYPE in order to know its actual size, which we then use
2571          to create the contents buffer of the value we return.
2572          The difficulty is that the data containing our object is
2573          packed, and therefore maybe not at a byte boundary.  So, what
2574          we do, is unpack the data into a byte-aligned buffer, and then
2575          use that buffer as our object's value for resolving the type.  */
2576       int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2577       staging.resize (staging_len);
2578
2579       ada_unpack_from_contents (src, bit_offset, bit_size,
2580                                 staging.data (), staging.size (),
2581                                 is_big_endian, has_negatives (type),
2582                                 is_scalar);
2583       type = resolve_dynamic_type (type, staging.data (), 0);
2584       if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2585         {
2586           /* This happens when the length of the object is dynamic,
2587              and is actually smaller than the space reserved for it.
2588              For instance, in an array of variant records, the bit_size
2589              we're given is the array stride, which is constant and
2590              normally equal to the maximum size of its element.
2591              But, in reality, each element only actually spans a portion
2592              of that stride.  */
2593           bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2594         }
2595     }
2596
2597   if (obj == NULL)
2598     {
2599       v = allocate_value (type);
2600       src = valaddr + offset;
2601     }
2602   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2603     {
2604       int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2605       gdb_byte *buf;
2606
2607       v = value_at (type, value_address (obj) + offset);
2608       buf = (gdb_byte *) alloca (src_len);
2609       read_memory (value_address (v), buf, src_len);
2610       src = buf;
2611     }
2612   else
2613     {
2614       v = allocate_value (type);
2615       src = value_contents (obj) + offset;
2616     }
2617
2618   if (obj != NULL)
2619     {
2620       long new_offset = offset;
2621
2622       set_value_component_location (v, obj);
2623       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2624       set_value_bitsize (v, bit_size);
2625       if (value_bitpos (v) >= HOST_CHAR_BIT)
2626         {
2627           ++new_offset;
2628           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2629         }
2630       set_value_offset (v, new_offset);
2631
2632       /* Also set the parent value.  This is needed when trying to
2633          assign a new value (in inferior memory).  */
2634       set_value_parent (v, obj);
2635     }
2636   else
2637     set_value_bitsize (v, bit_size);
2638   unpacked = value_contents_writeable (v);
2639
2640   if (bit_size == 0)
2641     {
2642       memset (unpacked, 0, TYPE_LENGTH (type));
2643       return v;
2644     }
2645
2646   if (staging.size () == TYPE_LENGTH (type))
2647     {
2648       /* Small short-cut: If we've unpacked the data into a buffer
2649          of the same size as TYPE's length, then we can reuse that,
2650          instead of doing the unpacking again.  */
2651       memcpy (unpacked, staging.data (), staging.size ());
2652     }
2653   else
2654     ada_unpack_from_contents (src, bit_offset, bit_size,
2655                               unpacked, TYPE_LENGTH (type),
2656                               is_big_endian, has_negatives (type), is_scalar);
2657
2658   return v;
2659 }
2660
2661 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2662    TARGET, starting at bit offset TARG_OFFSET.  SOURCE and TARGET must
2663    not overlap.  */
2664 static void
2665 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
2666            int src_offset, int n, int bits_big_endian_p)
2667 {
2668   unsigned int accum, mask;
2669   int accum_bits, chunk_size;
2670
2671   target += targ_offset / HOST_CHAR_BIT;
2672   targ_offset %= HOST_CHAR_BIT;
2673   source += src_offset / HOST_CHAR_BIT;
2674   src_offset %= HOST_CHAR_BIT;
2675   if (bits_big_endian_p)
2676     {
2677       accum = (unsigned char) *source;
2678       source += 1;
2679       accum_bits = HOST_CHAR_BIT - src_offset;
2680
2681       while (n > 0)
2682         {
2683           int unused_right;
2684
2685           accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2686           accum_bits += HOST_CHAR_BIT;
2687           source += 1;
2688           chunk_size = HOST_CHAR_BIT - targ_offset;
2689           if (chunk_size > n)
2690             chunk_size = n;
2691           unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2692           mask = ((1 << chunk_size) - 1) << unused_right;
2693           *target =
2694             (*target & ~mask)
2695             | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2696           n -= chunk_size;
2697           accum_bits -= chunk_size;
2698           target += 1;
2699           targ_offset = 0;
2700         }
2701     }
2702   else
2703     {
2704       accum = (unsigned char) *source >> src_offset;
2705       source += 1;
2706       accum_bits = HOST_CHAR_BIT - src_offset;
2707
2708       while (n > 0)
2709         {
2710           accum = accum + ((unsigned char) *source << accum_bits);
2711           accum_bits += HOST_CHAR_BIT;
2712           source += 1;
2713           chunk_size = HOST_CHAR_BIT - targ_offset;
2714           if (chunk_size > n)
2715             chunk_size = n;
2716           mask = ((1 << chunk_size) - 1) << targ_offset;
2717           *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2718           n -= chunk_size;
2719           accum_bits -= chunk_size;
2720           accum >>= chunk_size;
2721           target += 1;
2722           targ_offset = 0;
2723         }
2724     }
2725 }
2726
2727 /* Store the contents of FROMVAL into the location of TOVAL.
2728    Return a new value with the location of TOVAL and contents of
2729    FROMVAL.   Handles assignment into packed fields that have
2730    floating-point or non-scalar types.  */
2731
2732 static struct value *
2733 ada_value_assign (struct value *toval, struct value *fromval)
2734 {
2735   struct type *type = value_type (toval);
2736   int bits = value_bitsize (toval);
2737
2738   toval = ada_coerce_ref (toval);
2739   fromval = ada_coerce_ref (fromval);
2740
2741   if (ada_is_direct_array_type (value_type (toval)))
2742     toval = ada_coerce_to_simple_array (toval);
2743   if (ada_is_direct_array_type (value_type (fromval)))
2744     fromval = ada_coerce_to_simple_array (fromval);
2745
2746   if (!deprecated_value_modifiable (toval))
2747     error (_("Left operand of assignment is not a modifiable lvalue."));
2748
2749   if (VALUE_LVAL (toval) == lval_memory
2750       && bits > 0
2751       && (TYPE_CODE (type) == TYPE_CODE_FLT
2752           || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2753     {
2754       int len = (value_bitpos (toval)
2755                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2756       int from_size;
2757       gdb_byte *buffer = (gdb_byte *) alloca (len);
2758       struct value *val;
2759       CORE_ADDR to_addr = value_address (toval);
2760
2761       if (TYPE_CODE (type) == TYPE_CODE_FLT)
2762         fromval = value_cast (type, fromval);
2763
2764       read_memory (to_addr, buffer, len);
2765       from_size = value_bitsize (fromval);
2766       if (from_size == 0)
2767         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2768       if (gdbarch_bits_big_endian (get_type_arch (type)))
2769         move_bits (buffer, value_bitpos (toval),
2770                    value_contents (fromval), from_size - bits, bits, 1);
2771       else
2772         move_bits (buffer, value_bitpos (toval),
2773                    value_contents (fromval), 0, bits, 0);
2774       write_memory_with_notification (to_addr, buffer, len);
2775
2776       val = value_copy (toval);
2777       memcpy (value_contents_raw (val), value_contents (fromval),
2778               TYPE_LENGTH (type));
2779       deprecated_set_value_type (val, type);
2780
2781       return val;
2782     }
2783
2784   return value_assign (toval, fromval);
2785 }
2786
2787
2788 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2789    CONTAINER, assign the contents of VAL to COMPONENTS's place in
2790    CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2791    COMPONENT, and not the inferior's memory.  The current contents
2792    of COMPONENT are ignored.
2793
2794    Although not part of the initial design, this function also works
2795    when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2796    had a null address, and COMPONENT had an address which is equal to
2797    its offset inside CONTAINER.  */
2798
2799 static void
2800 value_assign_to_component (struct value *container, struct value *component,
2801                            struct value *val)
2802 {
2803   LONGEST offset_in_container =
2804     (LONGEST)  (value_address (component) - value_address (container));
2805   int bit_offset_in_container =
2806     value_bitpos (component) - value_bitpos (container);
2807   int bits;
2808
2809   val = value_cast (value_type (component), val);
2810
2811   if (value_bitsize (component) == 0)
2812     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2813   else
2814     bits = value_bitsize (component);
2815
2816   if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2817     move_bits (value_contents_writeable (container) + offset_in_container,
2818                value_bitpos (container) + bit_offset_in_container,
2819                value_contents (val),
2820                TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2821                bits, 1);
2822   else
2823     move_bits (value_contents_writeable (container) + offset_in_container,
2824                value_bitpos (container) + bit_offset_in_container,
2825                value_contents (val), 0, bits, 0);
2826 }
2827
2828 /* The value of the element of array ARR at the ARITY indices given in IND.
2829    ARR may be either a simple array, GNAT array descriptor, or pointer
2830    thereto.  */
2831
2832 struct value *
2833 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2834 {
2835   int k;
2836   struct value *elt;
2837   struct type *elt_type;
2838
2839   elt = ada_coerce_to_simple_array (arr);
2840
2841   elt_type = ada_check_typedef (value_type (elt));
2842   if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2843       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2844     return value_subscript_packed (elt, arity, ind);
2845
2846   for (k = 0; k < arity; k += 1)
2847     {
2848       if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2849         error (_("too many subscripts (%d expected)"), k);
2850       elt = value_subscript (elt, pos_atr (ind[k]));
2851     }
2852   return elt;
2853 }
2854
2855 /* Assuming ARR is a pointer to a GDB array, the value of the element
2856    of *ARR at the ARITY indices given in IND.
2857    Does not read the entire array into memory.
2858
2859    Note: Unlike what one would expect, this function is used instead of
2860    ada_value_subscript for basically all non-packed array types.  The reason
2861    for this is that a side effect of doing our own pointer arithmetics instead
2862    of relying on value_subscript is that there is no implicit typedef peeling.
2863    This is important for arrays of array accesses, where it allows us to
2864    preserve the fact that the array's element is an array access, where the
2865    access part os encoded in a typedef layer.  */
2866
2867 static struct value *
2868 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2869 {
2870   int k;
2871   struct value *array_ind = ada_value_ind (arr);
2872   struct type *type
2873     = check_typedef (value_enclosing_type (array_ind));
2874
2875   if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2876       && TYPE_FIELD_BITSIZE (type, 0) > 0)
2877     return value_subscript_packed (array_ind, arity, ind);
2878
2879   for (k = 0; k < arity; k += 1)
2880     {
2881       LONGEST lwb, upb;
2882       struct value *lwb_value;
2883
2884       if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2885         error (_("too many subscripts (%d expected)"), k);
2886       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2887                         value_copy (arr));
2888       get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2889       lwb_value = value_from_longest (value_type(ind[k]), lwb);
2890       arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
2891       type = TYPE_TARGET_TYPE (type);
2892     }
2893
2894   return value_ind (arr);
2895 }
2896
2897 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2898    actual type of ARRAY_PTR is ignored), returns the Ada slice of
2899    HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
2900    this array is LOW, as per Ada rules.  */
2901 static struct value *
2902 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2903                           int low, int high)
2904 {
2905   struct type *type0 = ada_check_typedef (type);
2906   struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
2907   struct type *index_type
2908     = create_static_range_type (NULL, base_index_type, low, high);
2909   struct type *slice_type = create_array_type_with_stride
2910                               (NULL, TYPE_TARGET_TYPE (type0), index_type,
2911                                get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2912                                TYPE_FIELD_BITSIZE (type0, 0));
2913   int base_low =  ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2914   LONGEST base_low_pos, low_pos;
2915   CORE_ADDR base;
2916
2917   if (!discrete_position (base_index_type, low, &low_pos)
2918       || !discrete_position (base_index_type, base_low, &base_low_pos))
2919     {
2920       warning (_("unable to get positions in slice, use bounds instead"));
2921       low_pos = low;
2922       base_low_pos = base_low;
2923     }
2924
2925   base = value_as_address (array_ptr)
2926     + ((low_pos - base_low_pos)
2927        * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
2928   return value_at_lazy (slice_type, base);
2929 }
2930
2931
2932 static struct value *
2933 ada_value_slice (struct value *array, int low, int high)
2934 {
2935   struct type *type = ada_check_typedef (value_type (array));
2936   struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2937   struct type *index_type
2938     = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2939   struct type *slice_type = create_array_type_with_stride
2940                               (NULL, TYPE_TARGET_TYPE (type), index_type,
2941                                get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2942                                TYPE_FIELD_BITSIZE (type, 0));
2943   LONGEST low_pos, high_pos;
2944
2945   if (!discrete_position (base_index_type, low, &low_pos)
2946       || !discrete_position (base_index_type, high, &high_pos))
2947     {
2948       warning (_("unable to get positions in slice, use bounds instead"));
2949       low_pos = low;
2950       high_pos = high;
2951     }
2952
2953   return value_cast (slice_type,
2954                      value_slice (array, low, high_pos - low_pos + 1));
2955 }
2956
2957 /* If type is a record type in the form of a standard GNAT array
2958    descriptor, returns the number of dimensions for type.  If arr is a
2959    simple array, returns the number of "array of"s that prefix its
2960    type designation.  Otherwise, returns 0.  */
2961
2962 int
2963 ada_array_arity (struct type *type)
2964 {
2965   int arity;
2966
2967   if (type == NULL)
2968     return 0;
2969
2970   type = desc_base_type (type);
2971
2972   arity = 0;
2973   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2974     return desc_arity (desc_bounds_type (type));
2975   else
2976     while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2977       {
2978         arity += 1;
2979         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2980       }
2981
2982   return arity;
2983 }
2984
2985 /* If TYPE is a record type in the form of a standard GNAT array
2986    descriptor or a simple array type, returns the element type for
2987    TYPE after indexing by NINDICES indices, or by all indices if
2988    NINDICES is -1.  Otherwise, returns NULL.  */
2989
2990 struct type *
2991 ada_array_element_type (struct type *type, int nindices)
2992 {
2993   type = desc_base_type (type);
2994
2995   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2996     {
2997       int k;
2998       struct type *p_array_type;
2999
3000       p_array_type = desc_data_target_type (type);
3001
3002       k = ada_array_arity (type);
3003       if (k == 0)
3004         return NULL;
3005
3006       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
3007       if (nindices >= 0 && k > nindices)
3008         k = nindices;
3009       while (k > 0 && p_array_type != NULL)
3010         {
3011           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
3012           k -= 1;
3013         }
3014       return p_array_type;
3015     }
3016   else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
3017     {
3018       while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
3019         {
3020           type = TYPE_TARGET_TYPE (type);
3021           nindices -= 1;
3022         }
3023       return type;
3024     }
3025
3026   return NULL;
3027 }
3028
3029 /* The type of nth index in arrays of given type (n numbering from 1).
3030    Does not examine memory.  Throws an error if N is invalid or TYPE
3031    is not an array type.  NAME is the name of the Ada attribute being
3032    evaluated ('range, 'first, 'last, or 'length); it is used in building
3033    the error message.  */
3034
3035 static struct type *
3036 ada_index_type (struct type *type, int n, const char *name)
3037 {
3038   struct type *result_type;
3039
3040   type = desc_base_type (type);
3041
3042   if (n < 0 || n > ada_array_arity (type))
3043     error (_("invalid dimension number to '%s"), name);
3044
3045   if (ada_is_simple_array_type (type))
3046     {
3047       int i;
3048
3049       for (i = 1; i < n; i += 1)
3050         type = TYPE_TARGET_TYPE (type);
3051       result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
3052       /* FIXME: The stabs type r(0,0);bound;bound in an array type
3053          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
3054          perhaps stabsread.c would make more sense.  */
3055       if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
3056         result_type = NULL;
3057     }
3058   else
3059     {
3060       result_type = desc_index_type (desc_bounds_type (type), n);
3061       if (result_type == NULL)
3062         error (_("attempt to take bound of something that is not an array"));
3063     }
3064
3065   return result_type;
3066 }
3067
3068 /* Given that arr is an array type, returns the lower bound of the
3069    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3070    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
3071    array-descriptor type.  It works for other arrays with bounds supplied
3072    by run-time quantities other than discriminants.  */
3073
3074 static LONGEST
3075 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3076 {
3077   struct type *type, *index_type_desc, *index_type;
3078   int i;
3079
3080   gdb_assert (which == 0 || which == 1);
3081
3082   if (ada_is_constrained_packed_array_type (arr_type))
3083     arr_type = decode_constrained_packed_array_type (arr_type);
3084
3085   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3086     return (LONGEST) - which;
3087
3088   if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3089     type = TYPE_TARGET_TYPE (arr_type);
3090   else
3091     type = arr_type;
3092
3093   if (TYPE_FIXED_INSTANCE (type))
3094     {
3095       /* The array has already been fixed, so we do not need to
3096          check the parallel ___XA type again.  That encoding has
3097          already been applied, so ignore it now.  */
3098       index_type_desc = NULL;
3099     }
3100   else
3101     {
3102       index_type_desc = ada_find_parallel_type (type, "___XA");
3103       ada_fixup_array_indexes_type (index_type_desc);
3104     }
3105
3106   if (index_type_desc != NULL)
3107     index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3108                                       NULL);
3109   else
3110     {
3111       struct type *elt_type = check_typedef (type);
3112
3113       for (i = 1; i < n; i++)
3114         elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3115
3116       index_type = TYPE_INDEX_TYPE (elt_type);
3117     }
3118
3119   return
3120     (LONGEST) (which == 0
3121                ? ada_discrete_type_low_bound (index_type)
3122                : ada_discrete_type_high_bound (index_type));
3123 }
3124
3125 /* Given that arr is an array value, returns the lower bound of the
3126    nth index (numbering from 1) if WHICH is 0, and the upper bound if
3127    WHICH is 1.  This routine will also work for arrays with bounds
3128    supplied by run-time quantities other than discriminants.  */
3129
3130 static LONGEST
3131 ada_array_bound (struct value *arr, int n, int which)
3132 {
3133   struct type *arr_type;
3134
3135   if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3136     arr = value_ind (arr);
3137   arr_type = value_enclosing_type (arr);
3138
3139   if (ada_is_constrained_packed_array_type (arr_type))
3140     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3141   else if (ada_is_simple_array_type (arr_type))
3142     return ada_array_bound_from_type (arr_type, n, which);
3143   else
3144     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3145 }
3146
3147 /* Given that arr is an array value, returns the length of the
3148    nth index.  This routine will also work for arrays with bounds
3149    supplied by run-time quantities other than discriminants.
3150    Does not work for arrays indexed by enumeration types with representation
3151    clauses at the moment.  */
3152
3153 static LONGEST
3154 ada_array_length (struct value *arr, int n)
3155 {
3156   struct type *arr_type, *index_type;
3157   int low, high;
3158
3159   if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3160     arr = value_ind (arr);
3161   arr_type = value_enclosing_type (arr);
3162
3163   if (ada_is_constrained_packed_array_type (arr_type))
3164     return ada_array_length (decode_constrained_packed_array (arr), n);
3165
3166   if (ada_is_simple_array_type (arr_type))
3167     {
3168       low = ada_array_bound_from_type (arr_type, n, 0);
3169       high = ada_array_bound_from_type (arr_type, n, 1);
3170     }
3171   else
3172     {
3173       low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3174       high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3175     }
3176
3177   arr_type = check_typedef (arr_type);
3178   index_type = ada_index_type (arr_type, n, "length");
3179   if (index_type != NULL)
3180     {
3181       struct type *base_type;
3182       if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3183         base_type = TYPE_TARGET_TYPE (index_type);
3184       else
3185         base_type = index_type;
3186
3187       low = pos_atr (value_from_longest (base_type, low));
3188       high = pos_atr (value_from_longest (base_type, high));
3189     }
3190   return high - low + 1;
3191 }
3192
3193 /* An empty array whose type is that of ARR_TYPE (an array type),
3194    with bounds LOW to LOW-1.  */
3195
3196 static struct value *
3197 empty_array (struct type *arr_type, int low)
3198 {
3199   struct type *arr_type0 = ada_check_typedef (arr_type);
3200   struct type *index_type
3201     = create_static_range_type
3202         (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)),  low, low - 1);
3203   struct type *elt_type = ada_array_element_type (arr_type0, 1);
3204
3205   return allocate_value (create_array_type (NULL, elt_type, index_type));
3206 }
3207 \f
3208
3209                                 /* Name resolution */
3210
3211 /* The "decoded" name for the user-definable Ada operator corresponding
3212    to OP.  */
3213
3214 static const char *
3215 ada_decoded_op_name (enum exp_opcode op)
3216 {
3217   int i;
3218
3219   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3220     {
3221       if (ada_opname_table[i].op == op)
3222         return ada_opname_table[i].decoded;
3223     }
3224   error (_("Could not find operator name for opcode"));
3225 }
3226
3227
3228 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3229    references (marked by OP_VAR_VALUE nodes in which the symbol has an
3230    undefined namespace) and converts operators that are
3231    user-defined into appropriate function calls.  If CONTEXT_TYPE is
3232    non-null, it provides a preferred result type [at the moment, only
3233    type void has any effect---causing procedures to be preferred over
3234    functions in calls].  A null CONTEXT_TYPE indicates that a non-void
3235    return type is preferred.  May change (expand) *EXP.  */
3236
3237 static void
3238 resolve (expression_up *expp, int void_context_p)
3239 {
3240   struct type *context_type = NULL;
3241   int pc = 0;
3242
3243   if (void_context_p)
3244     context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3245
3246   resolve_subexp (expp, &pc, 1, context_type);
3247 }
3248
3249 /* Resolve the operator of the subexpression beginning at
3250    position *POS of *EXPP.  "Resolving" consists of replacing
3251    the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3252    with their resolutions, replacing built-in operators with
3253    function calls to user-defined operators, where appropriate, and,
3254    when DEPROCEDURE_P is non-zero, converting function-valued variables
3255    into parameterless calls.  May expand *EXPP.  The CONTEXT_TYPE functions
3256    are as in ada_resolve, above.  */
3257
3258 static struct value *
3259 resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
3260                 struct type *context_type)
3261 {
3262   int pc = *pos;
3263   int i;
3264   struct expression *exp;       /* Convenience: == *expp.  */
3265   enum exp_opcode op = (*expp)->elts[pc].opcode;
3266   struct value **argvec;        /* Vector of operand types (alloca'ed).  */
3267   int nargs;                    /* Number of operands.  */
3268   int oplen;
3269   struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
3270
3271   argvec = NULL;
3272   nargs = 0;
3273   exp = expp->get ();
3274
3275   /* Pass one: resolve operands, saving their types and updating *pos,
3276      if needed.  */
3277   switch (op)
3278     {
3279     case OP_FUNCALL:
3280       if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3281           && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3282         *pos += 7;
3283       else
3284         {
3285           *pos += 3;
3286           resolve_subexp (expp, pos, 0, NULL);
3287         }
3288       nargs = longest_to_int (exp->elts[pc + 1].longconst);
3289       break;
3290
3291     case UNOP_ADDR:
3292       *pos += 1;
3293       resolve_subexp (expp, pos, 0, NULL);
3294       break;
3295
3296     case UNOP_QUAL:
3297       *pos += 3;
3298       resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
3299       break;
3300
3301     case OP_ATR_MODULUS:
3302     case OP_ATR_SIZE:
3303     case OP_ATR_TAG:
3304     case OP_ATR_FIRST:
3305     case OP_ATR_LAST:
3306     case OP_ATR_LENGTH:
3307     case OP_ATR_POS:
3308     case OP_ATR_VAL:
3309     case OP_ATR_MIN:
3310     case OP_ATR_MAX:
3311     case TERNOP_IN_RANGE:
3312     case BINOP_IN_BOUNDS:
3313     case UNOP_IN_RANGE:
3314     case OP_AGGREGATE:
3315     case OP_OTHERS:
3316     case OP_CHOICES:
3317     case OP_POSITIONAL:
3318     case OP_DISCRETE_RANGE:
3319     case OP_NAME:
3320       ada_forward_operator_length (exp, pc, &oplen, &nargs);
3321       *pos += oplen;
3322       break;
3323
3324     case BINOP_ASSIGN:
3325       {
3326         struct value *arg1;
3327
3328         *pos += 1;
3329         arg1 = resolve_subexp (expp, pos, 0, NULL);
3330         if (arg1 == NULL)
3331           resolve_subexp (expp, pos, 1, NULL);
3332         else
3333           resolve_subexp (expp, pos, 1, value_type (arg1));
3334         break;
3335       }
3336
3337     case UNOP_CAST:
3338       *pos += 3;
3339       nargs = 1;
3340       break;
3341
3342     case BINOP_ADD:
3343     case BINOP_SUB:
3344     case BINOP_MUL:
3345     case BINOP_DIV:
3346     case BINOP_REM:
3347     case BINOP_MOD:
3348     case BINOP_EXP:
3349     case BINOP_CONCAT:
3350     case BINOP_LOGICAL_AND:
3351     case BINOP_LOGICAL_OR:
3352     case BINOP_BITWISE_AND:
3353     case BINOP_BITWISE_IOR:
3354     case BINOP_BITWISE_XOR:
3355
3356     case BINOP_EQUAL:
3357     case BINOP_NOTEQUAL:
3358     case BINOP_LESS:
3359     case BINOP_GTR:
3360     case BINOP_LEQ:
3361     case BINOP_GEQ:
3362
3363     case BINOP_REPEAT:
3364     case BINOP_SUBSCRIPT:
3365     case BINOP_COMMA:
3366       *pos += 1;
3367       nargs = 2;
3368       break;
3369
3370     case UNOP_NEG:
3371     case UNOP_PLUS:
3372     case UNOP_LOGICAL_NOT:
3373     case UNOP_ABS:
3374     case UNOP_IND:
3375       *pos += 1;
3376       nargs = 1;
3377       break;
3378
3379     case OP_LONG:
3380     case OP_FLOAT:
3381     case OP_VAR_VALUE:
3382     case OP_VAR_MSYM_VALUE:
3383       *pos += 4;
3384       break;
3385
3386     case OP_TYPE:
3387     case OP_BOOL:
3388     case OP_LAST:
3389     case OP_INTERNALVAR:
3390       *pos += 3;
3391       break;
3392
3393     case UNOP_MEMVAL:
3394       *pos += 3;
3395       nargs = 1;
3396       break;
3397
3398     case OP_REGISTER:
3399       *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3400       break;
3401
3402     case STRUCTOP_STRUCT:
3403       *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3404       nargs = 1;
3405       break;
3406
3407     case TERNOP_SLICE:
3408       *pos += 1;
3409       nargs = 3;
3410       break;
3411
3412     case OP_STRING:
3413       break;
3414
3415     default:
3416       error (_("Unexpected operator during name resolution"));
3417     }
3418
3419   argvec = XALLOCAVEC (struct value *, nargs + 1);
3420   for (i = 0; i < nargs; i += 1)
3421     argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3422   argvec[i] = NULL;
3423   exp = expp->get ();
3424
3425   /* Pass two: perform any resolution on principal operator.  */
3426   switch (op)
3427     {
3428     default:
3429       break;
3430
3431     case OP_VAR_VALUE:
3432       if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
3433         {
3434           struct block_symbol *candidates;
3435           int n_candidates;
3436
3437           n_candidates =
3438             ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3439                                     (exp->elts[pc + 2].symbol),
3440                                     exp->elts[pc + 1].block, VAR_DOMAIN,
3441                                     &candidates);
3442           make_cleanup (xfree, candidates);
3443
3444           if (n_candidates > 1)
3445             {
3446               /* Types tend to get re-introduced locally, so if there
3447                  are any local symbols that are not types, first filter
3448                  out all types.  */
3449               int j;
3450               for (j = 0; j < n_candidates; j += 1)
3451                 switch (SYMBOL_CLASS (candidates[j].symbol))
3452                   {
3453                   case LOC_REGISTER:
3454                   case LOC_ARG:
3455                   case LOC_REF_ARG:
3456                   case LOC_REGPARM_ADDR:
3457                   case LOC_LOCAL:
3458                   case LOC_COMPUTED:
3459                     goto FoundNonType;
3460                   default:
3461                     break;
3462                   }
3463             FoundNonType:
3464               if (j < n_candidates)
3465                 {
3466                   j = 0;
3467                   while (j < n_candidates)
3468                     {
3469                       if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
3470                         {
3471                           candidates[j] = candidates[n_candidates - 1];
3472                           n_candidates -= 1;
3473                         }
3474                       else
3475                         j += 1;
3476                     }
3477                 }
3478             }
3479
3480           if (n_candidates == 0)
3481             error (_("No definition found for %s"),
3482                    SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3483           else if (n_candidates == 1)
3484             i = 0;
3485           else if (deprocedure_p
3486                    && !is_nonfunction (candidates, n_candidates))
3487             {
3488               i = ada_resolve_function
3489                 (candidates, n_candidates, NULL, 0,
3490                  SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3491                  context_type);
3492               if (i < 0)
3493                 error (_("Could not find a match for %s"),
3494                        SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3495             }
3496           else
3497             {
3498               printf_filtered (_("Multiple matches for %s\n"),
3499                                SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3500               user_select_syms (candidates, n_candidates, 1);
3501               i = 0;
3502             }
3503
3504           exp->elts[pc + 1].block = candidates[i].block;
3505           exp->elts[pc + 2].symbol = candidates[i].symbol;
3506           innermost_block.update (candidates[i]);
3507         }
3508
3509       if (deprocedure_p
3510           && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3511               == TYPE_CODE_FUNC))
3512         {
3513           replace_operator_with_call (expp, pc, 0, 0,
3514                                       exp->elts[pc + 2].symbol,
3515                                       exp->elts[pc + 1].block);
3516           exp = expp->get ();
3517         }
3518       break;
3519
3520     case OP_FUNCALL:
3521       {
3522         if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3523             && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3524           {
3525             struct block_symbol *candidates;
3526             int n_candidates;
3527
3528             n_candidates =
3529               ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3530                                       (exp->elts[pc + 5].symbol),
3531                                       exp->elts[pc + 4].block, VAR_DOMAIN,
3532                                       &candidates);
3533             make_cleanup (xfree, candidates);
3534
3535             if (n_candidates == 1)
3536               i = 0;
3537             else
3538               {
3539                 i = ada_resolve_function
3540                   (candidates, n_candidates,
3541                    argvec, nargs,
3542                    SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3543                    context_type);
3544                 if (i < 0)
3545                   error (_("Could not find a match for %s"),
3546                          SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3547               }
3548
3549             exp->elts[pc + 4].block = candidates[i].block;
3550             exp->elts[pc + 5].symbol = candidates[i].symbol;
3551             innermost_block.update (candidates[i]);
3552           }
3553       }
3554       break;
3555     case BINOP_ADD:
3556     case BINOP_SUB:
3557     case BINOP_MUL:
3558     case BINOP_DIV:
3559     case BINOP_REM:
3560     case BINOP_MOD:
3561     case BINOP_CONCAT:
3562     case BINOP_BITWISE_AND:
3563     case BINOP_BITWISE_IOR:
3564     case BINOP_BITWISE_XOR:
3565     case BINOP_EQUAL:
3566     case BINOP_NOTEQUAL:
3567     case BINOP_LESS:
3568     case BINOP_GTR:
3569     case BINOP_LEQ:
3570     case BINOP_GEQ:
3571     case BINOP_EXP:
3572     case UNOP_NEG:
3573     case UNOP_PLUS:
3574     case UNOP_LOGICAL_NOT:
3575     case UNOP_ABS:
3576       if (possible_user_operator_p (op, argvec))
3577         {
3578           struct block_symbol *candidates;
3579           int n_candidates;
3580
3581           n_candidates =
3582             ada_lookup_symbol_list (ada_decoded_op_name (op),
3583                                     (struct block *) NULL, VAR_DOMAIN,
3584                                     &candidates);
3585           make_cleanup (xfree, candidates);
3586
3587           i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
3588                                     ada_decoded_op_name (op), NULL);
3589           if (i < 0)
3590             break;
3591
3592           replace_operator_with_call (expp, pc, nargs, 1,
3593                                       candidates[i].symbol,
3594                                       candidates[i].block);
3595           exp = expp->get ();
3596         }
3597       break;
3598
3599     case OP_TYPE:
3600     case OP_REGISTER:
3601       do_cleanups (old_chain);
3602       return NULL;
3603     }
3604
3605   *pos = pc;
3606   do_cleanups (old_chain);
3607   if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3608     return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3609                                     exp->elts[pc + 1].objfile,
3610                                     exp->elts[pc + 2].msymbol);
3611   else
3612     return evaluate_subexp_type (exp, pos);
3613 }
3614
3615 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  If
3616    MAY_DEREF is non-zero, the formal may be a pointer and the actual
3617    a non-pointer.  */
3618 /* The term "match" here is rather loose.  The match is heuristic and
3619    liberal.  */
3620
3621 static int
3622 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3623 {
3624   ftype = ada_check_typedef (ftype);
3625   atype = ada_check_typedef (atype);
3626
3627   if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3628     ftype = TYPE_TARGET_TYPE (ftype);
3629   if (TYPE_CODE (atype) == TYPE_CODE_REF)
3630     atype = TYPE_TARGET_TYPE (atype);
3631
3632   switch (TYPE_CODE (ftype))
3633     {
3634     default:
3635       return TYPE_CODE (ftype) == TYPE_CODE (atype);
3636     case TYPE_CODE_PTR:
3637       if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3638         return ada_type_match (TYPE_TARGET_TYPE (ftype),
3639                                TYPE_TARGET_TYPE (atype), 0);
3640       else
3641         return (may_deref
3642                 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3643     case TYPE_CODE_INT:
3644     case TYPE_CODE_ENUM:
3645     case TYPE_CODE_RANGE:
3646       switch (TYPE_CODE (atype))
3647         {
3648         case TYPE_CODE_INT:
3649         case TYPE_CODE_ENUM:
3650         case TYPE_CODE_RANGE:
3651           return 1;
3652         default:
3653           return 0;
3654         }
3655
3656     case TYPE_CODE_ARRAY:
3657       return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3658               || ada_is_array_descriptor_type (atype));
3659
3660     case TYPE_CODE_STRUCT:
3661       if (ada_is_array_descriptor_type (ftype))
3662         return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3663                 || ada_is_array_descriptor_type (atype));
3664       else
3665         return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3666                 && !ada_is_array_descriptor_type (atype));
3667
3668     case TYPE_CODE_UNION:
3669     case TYPE_CODE_FLT:
3670       return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3671     }
3672 }
3673
3674 /* Return non-zero if the formals of FUNC "sufficiently match" the
3675    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3676    may also be an enumeral, in which case it is treated as a 0-
3677    argument function.  */
3678
3679 static int
3680 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3681 {
3682   int i;
3683   struct type *func_type = SYMBOL_TYPE (func);
3684
3685   if (SYMBOL_CLASS (func) == LOC_CONST
3686       && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3687     return (n_actuals == 0);
3688   else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3689     return 0;
3690
3691   if (TYPE_NFIELDS (func_type) != n_actuals)
3692     return 0;
3693
3694   for (i = 0; i < n_actuals; i += 1)
3695     {
3696       if (actuals[i] == NULL)
3697         return 0;
3698       else
3699         {
3700           struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3701                                                                    i));
3702           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3703
3704           if (!ada_type_match (ftype, atype, 1))
3705             return 0;
3706         }
3707     }
3708   return 1;
3709 }
3710
3711 /* False iff function type FUNC_TYPE definitely does not produce a value
3712    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3713    FUNC_TYPE is not a valid function type with a non-null return type
3714    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3715
3716 static int
3717 return_match (struct type *func_type, struct type *context_type)
3718 {
3719   struct type *return_type;
3720
3721   if (func_type == NULL)
3722     return 1;
3723
3724   if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3725     return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3726   else
3727     return_type = get_base_type (func_type);
3728   if (return_type == NULL)
3729     return 1;
3730
3731   context_type = get_base_type (context_type);
3732
3733   if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3734     return context_type == NULL || return_type == context_type;
3735   else if (context_type == NULL)
3736     return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3737   else
3738     return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3739 }
3740
3741
3742 /* Returns the index in SYMS[0..NSYMS-1] that contains  the symbol for the
3743    function (if any) that matches the types of the NARGS arguments in
3744    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
3745    that returns that type, then eliminate matches that don't.  If
3746    CONTEXT_TYPE is void and there is at least one match that does not
3747    return void, eliminate all matches that do.
3748
3749    Asks the user if there is more than one match remaining.  Returns -1
3750    if there is no such symbol or none is selected.  NAME is used
3751    solely for messages.  May re-arrange and modify SYMS in
3752    the process; the index returned is for the modified vector.  */
3753
3754 static int
3755 ada_resolve_function (struct block_symbol syms[],
3756                       int nsyms, struct value **args, int nargs,
3757                       const char *name, struct type *context_type)
3758 {
3759   int fallback;
3760   int k;
3761   int m;                        /* Number of hits */
3762
3763   m = 0;
3764   /* In the first pass of the loop, we only accept functions matching
3765      context_type.  If none are found, we add a second pass of the loop
3766      where every function is accepted.  */
3767   for (fallback = 0; m == 0 && fallback < 2; fallback++)
3768     {
3769       for (k = 0; k < nsyms; k += 1)
3770         {
3771           struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
3772
3773           if (ada_args_match (syms[k].symbol, args, nargs)
3774               && (fallback || return_match (type, context_type)))
3775             {
3776               syms[m] = syms[k];
3777               m += 1;
3778             }
3779         }
3780     }
3781
3782   /* If we got multiple matches, ask the user which one to use.  Don't do this
3783      interactive thing during completion, though, as the purpose of the
3784      completion is providing a list of all possible matches.  Prompting the
3785      user to filter it down would be completely unexpected in this case.  */
3786   if (m == 0)
3787     return -1;
3788   else if (m > 1 && !parse_completion)
3789     {
3790       printf_filtered (_("Multiple matches for %s\n"), name);
3791       user_select_syms (syms, m, 1);
3792       return 0;
3793     }
3794   return 0;
3795 }
3796
3797 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3798    in a listing of choices during disambiguation (see sort_choices, below).
3799    The idea is that overloadings of a subprogram name from the
3800    same package should sort in their source order.  We settle for ordering
3801    such symbols by their trailing number (__N  or $N).  */
3802
3803 static int
3804 encoded_ordered_before (const char *N0, const char *N1)
3805 {
3806   if (N1 == NULL)
3807     return 0;
3808   else if (N0 == NULL)
3809     return 1;
3810   else
3811     {
3812       int k0, k1;
3813
3814       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3815         ;
3816       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3817         ;
3818       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3819           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3820         {
3821           int n0, n1;
3822
3823           n0 = k0;
3824           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3825             n0 -= 1;
3826           n1 = k1;
3827           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3828             n1 -= 1;
3829           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3830             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3831         }
3832       return (strcmp (N0, N1) < 0);
3833     }
3834 }
3835
3836 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3837    encoded names.  */
3838
3839 static void
3840 sort_choices (struct block_symbol syms[], int nsyms)
3841 {
3842   int i;
3843
3844   for (i = 1; i < nsyms; i += 1)
3845     {
3846       struct block_symbol sym = syms[i];
3847       int j;
3848
3849       for (j = i - 1; j >= 0; j -= 1)
3850         {
3851           if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3852                                       SYMBOL_LINKAGE_NAME (sym.symbol)))
3853             break;
3854           syms[j + 1] = syms[j];
3855         }
3856       syms[j + 1] = sym;
3857     }
3858 }
3859
3860 /* Whether GDB should display formals and return types for functions in the
3861    overloads selection menu.  */
3862 static int print_signatures = 1;
3863
3864 /* Print the signature for SYM on STREAM according to the FLAGS options.  For
3865    all but functions, the signature is just the name of the symbol.  For
3866    functions, this is the name of the function, the list of types for formals
3867    and the return type (if any).  */
3868
3869 static void
3870 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3871                             const struct type_print_options *flags)
3872 {
3873   struct type *type = SYMBOL_TYPE (sym);
3874
3875   fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3876   if (!print_signatures
3877       || type == NULL
3878       || TYPE_CODE (type) != TYPE_CODE_FUNC)
3879     return;
3880
3881   if (TYPE_NFIELDS (type) > 0)
3882     {
3883       int i;
3884
3885       fprintf_filtered (stream, " (");
3886       for (i = 0; i < TYPE_NFIELDS (type); ++i)
3887         {
3888           if (i > 0)
3889             fprintf_filtered (stream, "; ");
3890           ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3891                           flags);
3892         }
3893       fprintf_filtered (stream, ")");
3894     }
3895   if (TYPE_TARGET_TYPE (type) != NULL
3896       && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3897     {
3898       fprintf_filtered (stream, " return ");
3899       ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3900     }
3901 }
3902
3903 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0 
3904    by asking the user (if necessary), returning the number selected, 
3905    and setting the first elements of SYMS items.  Error if no symbols
3906    selected.  */
3907
3908 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3909    to be re-integrated one of these days.  */
3910
3911 int
3912 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3913 {
3914   int i;
3915   int *chosen = XALLOCAVEC (int , nsyms);
3916   int n_chosen;
3917   int first_choice = (max_results == 1) ? 1 : 2;
3918   const char *select_mode = multiple_symbols_select_mode ();
3919
3920   if (max_results < 1)
3921     error (_("Request to select 0 symbols!"));
3922   if (nsyms <= 1)
3923     return nsyms;
3924
3925   if (select_mode == multiple_symbols_cancel)
3926     error (_("\
3927 canceled because the command is ambiguous\n\
3928 See set/show multiple-symbol."));
3929   
3930   /* If select_mode is "all", then return all possible symbols.
3931      Only do that if more than one symbol can be selected, of course.
3932      Otherwise, display the menu as usual.  */
3933   if (select_mode == multiple_symbols_all && max_results > 1)
3934     return nsyms;
3935
3936   printf_unfiltered (_("[0] cancel\n"));
3937   if (max_results > 1)
3938     printf_unfiltered (_("[1] all\n"));
3939
3940   sort_choices (syms, nsyms);
3941
3942   for (i = 0; i < nsyms; i += 1)
3943     {
3944       if (syms[i].symbol == NULL)
3945         continue;
3946
3947       if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
3948         {
3949           struct symtab_and_line sal =
3950             find_function_start_sal (syms[i].symbol, 1);
3951
3952           printf_unfiltered ("[%d] ", i + first_choice);
3953           ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3954                                       &type_print_raw_options);
3955           if (sal.symtab == NULL)
3956             printf_unfiltered (_(" at <no source file available>:%d\n"),
3957                                sal.line);
3958           else
3959             printf_unfiltered (_(" at %s:%d\n"),
3960                                symtab_to_filename_for_display (sal.symtab),
3961                                sal.line);
3962           continue;
3963         }
3964       else
3965         {
3966           int is_enumeral =
3967             (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3968              && SYMBOL_TYPE (syms[i].symbol) != NULL
3969              && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
3970           struct symtab *symtab = NULL;
3971
3972           if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3973             symtab = symbol_symtab (syms[i].symbol);
3974
3975           if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
3976             {
3977               printf_unfiltered ("[%d] ", i + first_choice);
3978               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3979                                           &type_print_raw_options);
3980               printf_unfiltered (_(" at %s:%d\n"),
3981                                  symtab_to_filename_for_display (symtab),
3982                                  SYMBOL_LINE (syms[i].symbol));
3983             }
3984           else if (is_enumeral
3985                    && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
3986             {
3987               printf_unfiltered (("[%d] "), i + first_choice);
3988               ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
3989                               gdb_stdout, -1, 0, &type_print_raw_options);
3990               printf_unfiltered (_("'(%s) (enumeral)\n"),
3991                                  SYMBOL_PRINT_NAME (syms[i].symbol));
3992             }
3993           else
3994             {
3995               printf_unfiltered ("[%d] ", i + first_choice);
3996               ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3997                                           &type_print_raw_options);
3998
3999               if (symtab != NULL)
4000                 printf_unfiltered (is_enumeral
4001                                    ? _(" in %s (enumeral)\n")
4002                                    : _(" at %s:?\n"),
4003                                    symtab_to_filename_for_display (symtab));
4004               else
4005                 printf_unfiltered (is_enumeral
4006                                    ? _(" (enumeral)\n")
4007                                    : _(" at ?\n"));
4008             }
4009         }
4010     }
4011
4012   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4013                              "overload-choice");
4014
4015   for (i = 0; i < n_chosen; i += 1)
4016     syms[i] = syms[chosen[i]];
4017
4018   return n_chosen;
4019 }
4020
4021 /* Read and validate a set of numeric choices from the user in the
4022    range 0 .. N_CHOICES-1.  Place the results in increasing
4023    order in CHOICES[0 .. N-1], and return N.
4024
4025    The user types choices as a sequence of numbers on one line
4026    separated by blanks, encoding them as follows:
4027
4028      + A choice of 0 means to cancel the selection, throwing an error.
4029      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
4030      + The user chooses k by typing k+IS_ALL_CHOICE+1.
4031
4032    The user is not allowed to choose more than MAX_RESULTS values.
4033
4034    ANNOTATION_SUFFIX, if present, is used to annotate the input
4035    prompts (for use with the -f switch).  */
4036
4037 int
4038 get_selections (int *choices, int n_choices, int max_results,
4039                 int is_all_choice, const char *annotation_suffix)
4040 {
4041   char *args;
4042   const char *prompt;
4043   int n_chosen;
4044   int first_choice = is_all_choice ? 2 : 1;
4045
4046   prompt = getenv ("PS2");
4047   if (prompt == NULL)
4048     prompt = "> ";
4049
4050   args = command_line_input (prompt, 0, annotation_suffix);
4051
4052   if (args == NULL)
4053     error_no_arg (_("one or more choice numbers"));
4054
4055   n_chosen = 0;
4056
4057   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4058      order, as given in args.  Choices are validated.  */
4059   while (1)
4060     {
4061       char *args2;
4062       int choice, j;
4063
4064       args = skip_spaces (args);
4065       if (*args == '\0' && n_chosen == 0)
4066         error_no_arg (_("one or more choice numbers"));
4067       else if (*args == '\0')
4068         break;
4069
4070       choice = strtol (args, &args2, 10);
4071       if (args == args2 || choice < 0
4072           || choice > n_choices + first_choice - 1)
4073         error (_("Argument must be choice number"));
4074       args = args2;
4075
4076       if (choice == 0)
4077         error (_("cancelled"));
4078
4079       if (choice < first_choice)
4080         {
4081           n_chosen = n_choices;
4082           for (j = 0; j < n_choices; j += 1)
4083             choices[j] = j;
4084           break;
4085         }
4086       choice -= first_choice;
4087
4088       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4089         {
4090         }
4091
4092       if (j < 0 || choice != choices[j])
4093         {
4094           int k;
4095
4096           for (k = n_chosen - 1; k > j; k -= 1)
4097             choices[k + 1] = choices[k];
4098           choices[j + 1] = choice;
4099           n_chosen += 1;
4100         }
4101     }
4102
4103   if (n_chosen > max_results)
4104     error (_("Select no more than %d of the above"), max_results);
4105
4106   return n_chosen;
4107 }
4108
4109 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4110    on the function identified by SYM and BLOCK, and taking NARGS
4111    arguments.  Update *EXPP as needed to hold more space.  */
4112
4113 static void
4114 replace_operator_with_call (expression_up *expp, int pc, int nargs,
4115                             int oplen, struct symbol *sym,
4116                             const struct block *block)
4117 {
4118   /* A new expression, with 6 more elements (3 for funcall, 4 for function
4119      symbol, -oplen for operator being replaced).  */
4120   struct expression *newexp = (struct expression *)
4121     xzalloc (sizeof (struct expression)
4122              + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
4123   struct expression *exp = expp->get ();
4124
4125   newexp->nelts = exp->nelts + 7 - oplen;
4126   newexp->language_defn = exp->language_defn;
4127   newexp->gdbarch = exp->gdbarch;
4128   memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
4129   memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4130           EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
4131
4132   newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4133   newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4134
4135   newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4136   newexp->elts[pc + 4].block = block;
4137   newexp->elts[pc + 5].symbol = sym;
4138
4139   expp->reset (newexp);
4140 }
4141
4142 /* Type-class predicates */
4143
4144 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4145    or FLOAT).  */
4146
4147 static int
4148 numeric_type_p (struct type *type)
4149 {
4150   if (type == NULL)
4151     return 0;
4152   else
4153     {
4154       switch (TYPE_CODE (type))
4155         {
4156         case TYPE_CODE_INT:
4157         case TYPE_CODE_FLT:
4158           return 1;
4159         case TYPE_CODE_RANGE:
4160           return (type == TYPE_TARGET_TYPE (type)
4161                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
4162         default:
4163           return 0;
4164         }
4165     }
4166 }
4167
4168 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
4169
4170 static int
4171 integer_type_p (struct type *type)
4172 {
4173   if (type == NULL)
4174     return 0;
4175   else
4176     {
4177       switch (TYPE_CODE (type))
4178         {
4179         case TYPE_CODE_INT:
4180           return 1;
4181         case TYPE_CODE_RANGE:
4182           return (type == TYPE_TARGET_TYPE (type)
4183                   || integer_type_p (TYPE_TARGET_TYPE (type)));
4184         default:
4185           return 0;
4186         }
4187     }
4188 }
4189
4190 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
4191
4192 static int
4193 scalar_type_p (struct type *type)
4194 {
4195   if (type == NULL)
4196     return 0;
4197   else
4198     {
4199       switch (TYPE_CODE (type))
4200         {
4201         case TYPE_CODE_INT:
4202         case TYPE_CODE_RANGE:
4203         case TYPE_CODE_ENUM:
4204         case TYPE_CODE_FLT:
4205           return 1;
4206         default:
4207           return 0;
4208         }
4209     }
4210 }
4211
4212 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
4213
4214 static int
4215 discrete_type_p (struct type *type)
4216 {
4217   if (type == NULL)
4218     return 0;
4219   else
4220     {
4221       switch (TYPE_CODE (type))
4222         {
4223         case TYPE_CODE_INT:
4224         case TYPE_CODE_RANGE:
4225         case TYPE_CODE_ENUM:
4226         case TYPE_CODE_BOOL:
4227           return 1;
4228         default:
4229           return 0;
4230         }
4231     }
4232 }
4233
4234 /* Returns non-zero if OP with operands in the vector ARGS could be
4235    a user-defined function.  Errs on the side of pre-defined operators
4236    (i.e., result 0).  */
4237
4238 static int
4239 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4240 {
4241   struct type *type0 =
4242     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4243   struct type *type1 =
4244     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4245
4246   if (type0 == NULL)
4247     return 0;
4248
4249   switch (op)
4250     {
4251     default:
4252       return 0;
4253
4254     case BINOP_ADD:
4255     case BINOP_SUB:
4256     case BINOP_MUL:
4257     case BINOP_DIV:
4258       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4259
4260     case BINOP_REM:
4261     case BINOP_MOD:
4262     case BINOP_BITWISE_AND:
4263     case BINOP_BITWISE_IOR:
4264     case BINOP_BITWISE_XOR:
4265       return (!(integer_type_p (type0) && integer_type_p (type1)));
4266
4267     case BINOP_EQUAL:
4268     case BINOP_NOTEQUAL:
4269     case BINOP_LESS:
4270     case BINOP_GTR:
4271     case BINOP_LEQ:
4272     case BINOP_GEQ:
4273       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4274
4275     case BINOP_CONCAT:
4276       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4277
4278     case BINOP_EXP:
4279       return (!(numeric_type_p (type0) && integer_type_p (type1)));
4280
4281     case UNOP_NEG:
4282     case UNOP_PLUS:
4283     case UNOP_LOGICAL_NOT:
4284     case UNOP_ABS:
4285       return (!numeric_type_p (type0));
4286
4287     }
4288 }
4289 \f
4290                                 /* Renaming */
4291
4292 /* NOTES: 
4293
4294    1. In the following, we assume that a renaming type's name may
4295       have an ___XD suffix.  It would be nice if this went away at some
4296       point.
4297    2. We handle both the (old) purely type-based representation of 
4298       renamings and the (new) variable-based encoding.  At some point,
4299       it is devoutly to be hoped that the former goes away 
4300       (FIXME: hilfinger-2007-07-09).
4301    3. Subprogram renamings are not implemented, although the XRS
4302       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
4303
4304 /* If SYM encodes a renaming, 
4305
4306        <renaming> renames <renamed entity>,
4307
4308    sets *LEN to the length of the renamed entity's name,
4309    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4310    the string describing the subcomponent selected from the renamed
4311    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4312    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4313    are undefined).  Otherwise, returns a value indicating the category
4314    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4315    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4316    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
4317    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4318    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4319    may be NULL, in which case they are not assigned.
4320
4321    [Currently, however, GCC does not generate subprogram renamings.]  */
4322
4323 enum ada_renaming_category
4324 ada_parse_renaming (struct symbol *sym,
4325                     const char **renamed_entity, int *len, 
4326                     const char **renaming_expr)
4327 {
4328   enum ada_renaming_category kind;
4329   const char *info;
4330   const char *suffix;
4331
4332   if (sym == NULL)
4333     return ADA_NOT_RENAMING;
4334   switch (SYMBOL_CLASS (sym)) 
4335     {
4336     default:
4337       return ADA_NOT_RENAMING;
4338     case LOC_TYPEDEF:
4339       return parse_old_style_renaming (SYMBOL_TYPE (sym), 
4340                                        renamed_entity, len, renaming_expr);
4341     case LOC_LOCAL:
4342     case LOC_STATIC:
4343     case LOC_COMPUTED:
4344     case LOC_OPTIMIZED_OUT:
4345       info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4346       if (info == NULL)
4347         return ADA_NOT_RENAMING;
4348       switch (info[5])
4349         {
4350         case '_':
4351           kind = ADA_OBJECT_RENAMING;
4352           info += 6;
4353           break;
4354         case 'E':
4355           kind = ADA_EXCEPTION_RENAMING;
4356           info += 7;
4357           break;
4358         case 'P':
4359           kind = ADA_PACKAGE_RENAMING;
4360           info += 7;
4361           break;
4362         case 'S':
4363           kind = ADA_SUBPROGRAM_RENAMING;
4364           info += 7;
4365           break;
4366         default:
4367           return ADA_NOT_RENAMING;
4368         }
4369     }
4370
4371   if (renamed_entity != NULL)
4372     *renamed_entity = info;
4373   suffix = strstr (info, "___XE");
4374   if (suffix == NULL || suffix == info)
4375     return ADA_NOT_RENAMING;
4376   if (len != NULL)
4377     *len = strlen (info) - strlen (suffix);
4378   suffix += 5;
4379   if (renaming_expr != NULL)
4380     *renaming_expr = suffix;
4381   return kind;
4382 }
4383
4384 /* Assuming TYPE encodes a renaming according to the old encoding in
4385    exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4386    *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above.  Returns
4387    ADA_NOT_RENAMING otherwise.  */
4388 static enum ada_renaming_category
4389 parse_old_style_renaming (struct type *type,
4390                           const char **renamed_entity, int *len, 
4391                           const char **renaming_expr)
4392 {
4393   enum ada_renaming_category kind;
4394   const char *name;
4395   const char *info;
4396   const char *suffix;
4397
4398   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM 
4399       || TYPE_NFIELDS (type) != 1)
4400     return ADA_NOT_RENAMING;
4401
4402   name = type_name_no_tag (type);
4403   if (name == NULL)
4404     return ADA_NOT_RENAMING;
4405   
4406   name = strstr (name, "___XR");
4407   if (name == NULL)
4408     return ADA_NOT_RENAMING;
4409   switch (name[5])
4410     {
4411     case '\0':
4412     case '_':
4413       kind = ADA_OBJECT_RENAMING;
4414       break;
4415     case 'E':
4416       kind = ADA_EXCEPTION_RENAMING;
4417       break;
4418     case 'P':
4419       kind = ADA_PACKAGE_RENAMING;
4420       break;
4421     case 'S':
4422       kind = ADA_SUBPROGRAM_RENAMING;
4423       break;
4424     default:
4425       return ADA_NOT_RENAMING;
4426     }
4427
4428   info = TYPE_FIELD_NAME (type, 0);
4429   if (info == NULL)
4430     return ADA_NOT_RENAMING;
4431   if (renamed_entity != NULL)
4432     *renamed_entity = info;
4433   suffix = strstr (info, "___XE");
4434   if (renaming_expr != NULL)
4435     *renaming_expr = suffix + 5;
4436   if (suffix == NULL || suffix == info)
4437     return ADA_NOT_RENAMING;
4438   if (len != NULL)
4439     *len = suffix - info;
4440   return kind;
4441 }
4442
4443 /* Compute the value of the given RENAMING_SYM, which is expected to
4444    be a symbol encoding a renaming expression.  BLOCK is the block
4445    used to evaluate the renaming.  */
4446
4447 static struct value *
4448 ada_read_renaming_var_value (struct symbol *renaming_sym,
4449                              const struct block *block)
4450 {
4451   const char *sym_name;
4452
4453   sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4454   expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4455   return evaluate_expression (expr.get ());
4456 }
4457 \f
4458
4459                                 /* Evaluation: Function Calls */
4460
4461 /* Return an lvalue containing the value VAL.  This is the identity on
4462    lvalues, and otherwise has the side-effect of allocating memory
4463    in the inferior where a copy of the value contents is copied.  */
4464
4465 static struct value *
4466 ensure_lval (struct value *val)
4467 {
4468   if (VALUE_LVAL (val) == not_lval
4469       || VALUE_LVAL (val) == lval_internalvar)
4470     {
4471       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4472       const CORE_ADDR addr =
4473         value_as_long (value_allocate_space_in_inferior (len));
4474
4475       VALUE_LVAL (val) = lval_memory;
4476       set_value_address (val, addr);
4477       write_memory (addr, value_contents (val), len);
4478     }
4479
4480   return val;
4481 }
4482
4483 /* Return the value ACTUAL, converted to be an appropriate value for a
4484    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4485    allocating any necessary descriptors (fat pointers), or copies of
4486    values not residing in memory, updating it as needed.  */
4487
4488 struct value *
4489 ada_convert_actual (struct value *actual, struct type *formal_type0)
4490 {
4491   struct type *actual_type = ada_check_typedef (value_type (actual));
4492   struct type *formal_type = ada_check_typedef (formal_type0);
4493   struct type *formal_target =
4494     TYPE_CODE (formal_type) == TYPE_CODE_PTR
4495     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4496   struct type *actual_target =
4497     TYPE_CODE (actual_type) == TYPE_CODE_PTR
4498     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4499
4500   if (ada_is_array_descriptor_type (formal_target)
4501       && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
4502     return make_array_descriptor (formal_type, actual);
4503   else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4504            || TYPE_CODE (formal_type) == TYPE_CODE_REF)
4505     {
4506       struct value *result;
4507
4508       if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4509           && ada_is_array_descriptor_type (actual_target))
4510         result = desc_data (actual);
4511       else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4512         {
4513           if (VALUE_LVAL (actual) != lval_memory)
4514             {
4515               struct value *val;
4516
4517               actual_type = ada_check_typedef (value_type (actual));
4518               val = allocate_value (actual_type);
4519               memcpy ((char *) value_contents_raw (val),
4520                       (char *) value_contents (actual),
4521                       TYPE_LENGTH (actual_type));
4522               actual = ensure_lval (val);
4523             }
4524           result = value_addr (actual);
4525         }
4526       else
4527         return actual;
4528       return value_cast_pointers (formal_type, result, 0);
4529     }
4530   else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4531     return ada_value_ind (actual);
4532   else if (ada_is_aligner_type (formal_type))
4533     {
4534       /* We need to turn this parameter into an aligner type
4535          as well.  */
4536       struct value *aligner = allocate_value (formal_type);
4537       struct value *component = ada_value_struct_elt (aligner, "F", 0);
4538
4539       value_assign_to_component (aligner, component, actual);
4540       return aligner;
4541     }
4542
4543   return actual;
4544 }
4545
4546 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4547    type TYPE.  This is usually an inefficient no-op except on some targets
4548    (such as AVR) where the representation of a pointer and an address
4549    differs.  */
4550
4551 static CORE_ADDR
4552 value_pointer (struct value *value, struct type *type)
4553 {
4554   struct gdbarch *gdbarch = get_type_arch (type);
4555   unsigned len = TYPE_LENGTH (type);
4556   gdb_byte *buf = (gdb_byte *) alloca (len);
4557   CORE_ADDR addr;
4558
4559   addr = value_address (value);
4560   gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4561   addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4562   return addr;
4563 }
4564
4565
4566 /* Push a descriptor of type TYPE for array value ARR on the stack at
4567    *SP, updating *SP to reflect the new descriptor.  Return either
4568    an lvalue representing the new descriptor, or (if TYPE is a pointer-
4569    to-descriptor type rather than a descriptor type), a struct value *
4570    representing a pointer to this descriptor.  */
4571
4572 static struct value *
4573 make_array_descriptor (struct type *type, struct value *arr)
4574 {
4575   struct type *bounds_type = desc_bounds_type (type);
4576   struct type *desc_type = desc_base_type (type);
4577   struct value *descriptor = allocate_value (desc_type);
4578   struct value *bounds = allocate_value (bounds_type);
4579   int i;
4580
4581   for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4582        i > 0; i -= 1)
4583     {
4584       modify_field (value_type (bounds), value_contents_writeable (bounds),
4585                     ada_array_bound (arr, i, 0),
4586                     desc_bound_bitpos (bounds_type, i, 0),
4587                     desc_bound_bitsize (bounds_type, i, 0));
4588       modify_field (value_type (bounds), value_contents_writeable (bounds),
4589                     ada_array_bound (arr, i, 1),
4590                     desc_bound_bitpos (bounds_type, i, 1),
4591                     desc_bound_bitsize (bounds_type, i, 1));
4592     }
4593
4594   bounds = ensure_lval (bounds);
4595
4596   modify_field (value_type (descriptor),
4597                 value_contents_writeable (descriptor),
4598                 value_pointer (ensure_lval (arr),
4599                                TYPE_FIELD_TYPE (desc_type, 0)),
4600                 fat_pntr_data_bitpos (desc_type),
4601                 fat_pntr_data_bitsize (desc_type));
4602
4603   modify_field (value_type (descriptor),
4604                 value_contents_writeable (descriptor),
4605                 value_pointer (bounds,
4606                                TYPE_FIELD_TYPE (desc_type, 1)),
4607                 fat_pntr_bounds_bitpos (desc_type),
4608                 fat_pntr_bounds_bitsize (desc_type));
4609
4610   descriptor = ensure_lval (descriptor);
4611
4612   if (TYPE_CODE (type) == TYPE_CODE_PTR)
4613     return value_addr (descriptor);
4614   else
4615     return descriptor;
4616 }
4617 \f
4618                                 /* Symbol Cache Module */
4619
4620 /* Performance measurements made as of 2010-01-15 indicate that
4621    this cache does bring some noticeable improvements.  Depending
4622    on the type of entity being printed, the cache can make it as much
4623    as an order of magnitude faster than without it.
4624
4625    The descriptive type DWARF extension has significantly reduced
4626    the need for this cache, at least when DWARF is being used.  However,
4627    even in this case, some expensive name-based symbol searches are still
4628    sometimes necessary - to find an XVZ variable, mostly.  */
4629
4630 /* Initialize the contents of SYM_CACHE.  */
4631
4632 static void
4633 ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4634 {
4635   obstack_init (&sym_cache->cache_space);
4636   memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4637 }
4638
4639 /* Free the memory used by SYM_CACHE.  */
4640
4641 static void
4642 ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
4643 {
4644   obstack_free (&sym_cache->cache_space, NULL);
4645   xfree (sym_cache);
4646 }
4647
4648 /* Return the symbol cache associated to the given program space PSPACE.
4649    If not allocated for this PSPACE yet, allocate and initialize one.  */
4650
4651 static struct ada_symbol_cache *
4652 ada_get_symbol_cache (struct program_space *pspace)
4653 {
4654   struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4655
4656   if (pspace_data->sym_cache == NULL)
4657     {
4658       pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4659       ada_init_symbol_cache (pspace_data->sym_cache);
4660     }
4661
4662   return pspace_data->sym_cache;
4663 }
4664
4665 /* Clear all entries from the symbol cache.  */
4666
4667 static void
4668 ada_clear_symbol_cache (void)
4669 {
4670   struct ada_symbol_cache *sym_cache
4671     = ada_get_symbol_cache (current_program_space);
4672
4673   obstack_free (&sym_cache->cache_space, NULL);
4674   ada_init_symbol_cache (sym_cache);
4675 }
4676
4677 /* Search our cache for an entry matching NAME and DOMAIN.
4678    Return it if found, or NULL otherwise.  */
4679
4680 static struct cache_entry **
4681 find_entry (const char *name, domain_enum domain)
4682 {
4683   struct ada_symbol_cache *sym_cache
4684     = ada_get_symbol_cache (current_program_space);
4685   int h = msymbol_hash (name) % HASH_SIZE;
4686   struct cache_entry **e;
4687
4688   for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4689     {
4690       if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4691         return e;
4692     }
4693   return NULL;
4694 }
4695
4696 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4697    Return 1 if found, 0 otherwise.
4698
4699    If an entry was found and SYM is not NULL, set *SYM to the entry's
4700    SYM.  Same principle for BLOCK if not NULL.  */
4701
4702 static int
4703 lookup_cached_symbol (const char *name, domain_enum domain,
4704                       struct symbol **sym, const struct block **block)
4705 {
4706   struct cache_entry **e = find_entry (name, domain);
4707
4708   if (e == NULL)
4709     return 0;
4710   if (sym != NULL)
4711     *sym = (*e)->sym;
4712   if (block != NULL)
4713     *block = (*e)->block;
4714   return 1;
4715 }
4716
4717 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4718    in domain DOMAIN, save this result in our symbol cache.  */
4719
4720 static void
4721 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4722               const struct block *block)
4723 {
4724   struct ada_symbol_cache *sym_cache
4725     = ada_get_symbol_cache (current_program_space);
4726   int h;
4727   char *copy;
4728   struct cache_entry *e;
4729
4730   /* Symbols for builtin types don't have a block.
4731      For now don't cache such symbols.  */
4732   if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4733     return;
4734
4735   /* If the symbol is a local symbol, then do not cache it, as a search
4736      for that symbol depends on the context.  To determine whether
4737      the symbol is local or not, we check the block where we found it
4738      against the global and static blocks of its associated symtab.  */
4739   if (sym
4740       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4741                             GLOBAL_BLOCK) != block
4742       && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4743                             STATIC_BLOCK) != block)
4744     return;
4745
4746   h = msymbol_hash (name) % HASH_SIZE;
4747   e = XOBNEW (&sym_cache->cache_space, cache_entry);
4748   e->next = sym_cache->root[h];
4749   sym_cache->root[h] = e;
4750   e->name = copy
4751     = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
4752   strcpy (copy, name);
4753   e->sym = sym;
4754   e->domain = domain;
4755   e->block = block;
4756 }
4757 \f
4758                                 /* Symbol Lookup */
4759
4760 /* Return the symbol name match type that should be used used when
4761    searching for all symbols matching LOOKUP_NAME.
4762
4763    LOOKUP_NAME is expected to be a symbol name after transformation
4764    for Ada lookups.  */
4765
4766 static symbol_name_match_type
4767 name_match_type_from_name (const char *lookup_name)
4768 {
4769   return (strstr (lookup_name, "__") == NULL
4770           ? symbol_name_match_type::WILD
4771           : symbol_name_match_type::FULL);
4772 }
4773
4774 /* Return the result of a standard (literal, C-like) lookup of NAME in
4775    given DOMAIN, visible from lexical block BLOCK.  */
4776
4777 static struct symbol *
4778 standard_lookup (const char *name, const struct block *block,
4779                  domain_enum domain)
4780 {
4781   /* Initialize it just to avoid a GCC false warning.  */
4782   struct block_symbol sym = {NULL, NULL};
4783
4784   if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4785     return sym.symbol;
4786   sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4787   cache_symbol (name, domain, sym.symbol, sym.block);
4788   return sym.symbol;
4789 }
4790
4791
4792 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4793    in the symbol fields of SYMS[0..N-1].  We treat enumerals as functions, 
4794    since they contend in overloading in the same way.  */
4795 static int
4796 is_nonfunction (struct block_symbol syms[], int n)
4797 {
4798   int i;
4799
4800   for (i = 0; i < n; i += 1)
4801     if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4802         && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4803             || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
4804       return 1;
4805
4806   return 0;
4807 }
4808
4809 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4810    struct types.  Otherwise, they may not.  */
4811
4812 static int
4813 equiv_types (struct type *type0, struct type *type1)
4814 {
4815   if (type0 == type1)
4816     return 1;
4817   if (type0 == NULL || type1 == NULL
4818       || TYPE_CODE (type0) != TYPE_CODE (type1))
4819     return 0;
4820   if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
4821        || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4822       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4823       && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4824     return 1;
4825
4826   return 0;
4827 }
4828
4829 /* True iff SYM0 represents the same entity as SYM1, or one that is
4830    no more defined than that of SYM1.  */
4831
4832 static int
4833 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4834 {
4835   if (sym0 == sym1)
4836     return 1;
4837   if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4838       || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4839     return 0;
4840
4841   switch (SYMBOL_CLASS (sym0))
4842     {
4843     case LOC_UNDEF:
4844       return 1;
4845     case LOC_TYPEDEF:
4846       {
4847         struct type *type0 = SYMBOL_TYPE (sym0);
4848         struct type *type1 = SYMBOL_TYPE (sym1);
4849         const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4850         const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4851         int len0 = strlen (name0);
4852
4853         return
4854           TYPE_CODE (type0) == TYPE_CODE (type1)
4855           && (equiv_types (type0, type1)
4856               || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4857                   && startswith (name1 + len0, "___XV")));
4858       }
4859     case LOC_CONST:
4860       return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4861         && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4862     default:
4863       return 0;
4864     }
4865 }
4866
4867 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4868    records in OBSTACKP.  Do nothing if SYM is a duplicate.  */
4869
4870 static void
4871 add_defn_to_vec (struct obstack *obstackp,
4872                  struct symbol *sym,
4873                  const struct block *block)
4874 {
4875   int i;
4876   struct block_symbol *prevDefns = defns_collected (obstackp, 0);
4877
4878   /* Do not try to complete stub types, as the debugger is probably
4879      already scanning all symbols matching a certain name at the
4880      time when this function is called.  Trying to replace the stub
4881      type by its associated full type will cause us to restart a scan
4882      which may lead to an infinite recursion.  Instead, the client
4883      collecting the matching symbols will end up collecting several
4884      matches, with at least one of them complete.  It can then filter
4885      out the stub ones if needed.  */
4886
4887   for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4888     {
4889       if (lesseq_defined_than (sym, prevDefns[i].symbol))
4890         return;
4891       else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4892         {
4893           prevDefns[i].symbol = sym;
4894           prevDefns[i].block = block;
4895           return;
4896         }
4897     }
4898
4899   {
4900     struct block_symbol info;
4901
4902     info.symbol = sym;
4903     info.block = block;
4904     obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4905   }
4906 }
4907
4908 /* Number of block_symbol structures currently collected in current vector in
4909    OBSTACKP.  */
4910
4911 static int
4912 num_defns_collected (struct obstack *obstackp)
4913 {
4914   return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4915 }
4916
4917 /* Vector of block_symbol structures currently collected in current vector in
4918    OBSTACKP.  If FINISH, close off the vector and return its final address.  */
4919
4920 static struct block_symbol *
4921 defns_collected (struct obstack *obstackp, int finish)
4922 {
4923   if (finish)
4924     return (struct block_symbol *) obstack_finish (obstackp);
4925   else
4926     return (struct block_symbol *) obstack_base (obstackp);
4927 }
4928
4929 /* Return a bound minimal symbol matching NAME according to Ada
4930    decoding rules.  Returns an invalid symbol if there is no such
4931    minimal symbol.  Names prefixed with "standard__" are handled
4932    specially: "standard__" is first stripped off, and only static and
4933    global symbols are searched.  */
4934
4935 struct bound_minimal_symbol
4936 ada_lookup_simple_minsym (const char *name)
4937 {
4938   struct bound_minimal_symbol result;
4939   struct objfile *objfile;
4940   struct minimal_symbol *msymbol;
4941
4942   memset (&result, 0, sizeof (result));
4943
4944   symbol_name_match_type match_type = name_match_type_from_name (name);
4945   lookup_name_info lookup_name (name, match_type);
4946
4947   symbol_name_matcher_ftype *match_name
4948     = ada_get_symbol_name_matcher (lookup_name);
4949
4950   ALL_MSYMBOLS (objfile, msymbol)
4951   {
4952     if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
4953         && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4954       {
4955         result.minsym = msymbol;
4956         result.objfile = objfile;
4957         break;
4958       }
4959   }
4960
4961   return result;
4962 }
4963
4964 /* For all subprograms that statically enclose the subprogram of the
4965    selected frame, add symbols matching identifier NAME in DOMAIN
4966    and their blocks to the list of data in OBSTACKP, as for
4967    ada_add_block_symbols (q.v.).   If WILD_MATCH_P, treat as NAME
4968    with a wildcard prefix.  */
4969
4970 static void
4971 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4972                                   const lookup_name_info &lookup_name,
4973                                   domain_enum domain)
4974 {
4975 }
4976
4977 /* True if TYPE is definitely an artificial type supplied to a symbol
4978    for which no debugging information was given in the symbol file.  */
4979
4980 static int
4981 is_nondebugging_type (struct type *type)
4982 {
4983   const char *name = ada_type_name (type);
4984
4985   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4986 }
4987
4988 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4989    that are deemed "identical" for practical purposes.
4990
4991    This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4992    types and that their number of enumerals is identical (in other
4993    words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)).  */
4994
4995 static int
4996 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4997 {
4998   int i;
4999
5000   /* The heuristic we use here is fairly conservative.  We consider
5001      that 2 enumerate types are identical if they have the same
5002      number of enumerals and that all enumerals have the same
5003      underlying value and name.  */
5004
5005   /* All enums in the type should have an identical underlying value.  */
5006   for (i = 0; i < TYPE_NFIELDS (type1); i++)
5007     if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
5008       return 0;
5009
5010   /* All enumerals should also have the same name (modulo any numerical
5011      suffix).  */
5012   for (i = 0; i < TYPE_NFIELDS (type1); i++)
5013     {
5014       const char *name_1 = TYPE_FIELD_NAME (type1, i);
5015       const char *name_2 = TYPE_FIELD_NAME (type2, i);
5016       int len_1 = strlen (name_1);
5017       int len_2 = strlen (name_2);
5018
5019       ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
5020       ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
5021       if (len_1 != len_2
5022           || strncmp (TYPE_FIELD_NAME (type1, i),
5023                       TYPE_FIELD_NAME (type2, i),
5024                       len_1) != 0)
5025         return 0;
5026     }
5027
5028   return 1;
5029 }
5030
5031 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
5032    that are deemed "identical" for practical purposes.  Sometimes,
5033    enumerals are not strictly identical, but their types are so similar
5034    that they can be considered identical.
5035
5036    For instance, consider the following code:
5037
5038       type Color is (Black, Red, Green, Blue, White);
5039       type RGB_Color is new Color range Red .. Blue;
5040
5041    Type RGB_Color is a subrange of an implicit type which is a copy
5042    of type Color. If we call that implicit type RGB_ColorB ("B" is
5043    for "Base Type"), then type RGB_ColorB is a copy of type Color.
5044    As a result, when an expression references any of the enumeral
5045    by name (Eg. "print green"), the expression is technically
5046    ambiguous and the user should be asked to disambiguate. But
5047    doing so would only hinder the user, since it wouldn't matter
5048    what choice he makes, the outcome would always be the same.
5049    So, for practical purposes, we consider them as the same.  */
5050
5051 static int
5052 symbols_are_identical_enums (struct block_symbol *syms, int nsyms)
5053 {
5054   int i;
5055
5056   /* Before performing a thorough comparison check of each type,
5057      we perform a series of inexpensive checks.  We expect that these
5058      checks will quickly fail in the vast majority of cases, and thus
5059      help prevent the unnecessary use of a more expensive comparison.
5060      Said comparison also expects us to make some of these checks
5061      (see ada_identical_enum_types_p).  */
5062
5063   /* Quick check: All symbols should have an enum type.  */
5064   for (i = 0; i < nsyms; i++)
5065     if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
5066       return 0;
5067
5068   /* Quick check: They should all have the same value.  */
5069   for (i = 1; i < nsyms; i++)
5070     if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
5071       return 0;
5072
5073   /* Quick check: They should all have the same number of enumerals.  */
5074   for (i = 1; i < nsyms; i++)
5075     if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5076         != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
5077       return 0;
5078
5079   /* All the sanity checks passed, so we might have a set of
5080      identical enumeration types.  Perform a more complete
5081      comparison of the type of each symbol.  */
5082   for (i = 1; i < nsyms; i++)
5083     if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5084                                      SYMBOL_TYPE (syms[0].symbol)))
5085       return 0;
5086
5087   return 1;
5088 }
5089
5090 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
5091    duplicate other symbols in the list (The only case I know of where
5092    this happens is when object files containing stabs-in-ecoff are
5093    linked with files containing ordinary ecoff debugging symbols (or no
5094    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.
5095    Returns the number of items in the modified list.  */
5096
5097 static int
5098 remove_extra_symbols (struct block_symbol *syms, int nsyms)
5099 {
5100   int i, j;
5101
5102   /* We should never be called with less than 2 symbols, as there
5103      cannot be any extra symbol in that case.  But it's easy to
5104      handle, since we have nothing to do in that case.  */
5105   if (nsyms < 2)
5106     return nsyms;
5107
5108   i = 0;
5109   while (i < nsyms)
5110     {
5111       int remove_p = 0;
5112
5113       /* If two symbols have the same name and one of them is a stub type,
5114          the get rid of the stub.  */
5115
5116       if (TYPE_STUB (SYMBOL_TYPE (syms[i].symbol))
5117           && SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL)
5118         {
5119           for (j = 0; j < nsyms; j++)
5120             {
5121               if (j != i
5122                   && !TYPE_STUB (SYMBOL_TYPE (syms[j].symbol))
5123                   && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5124                   && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5125                              SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0)
5126                 remove_p = 1;
5127             }
5128         }
5129
5130       /* Two symbols with the same name, same class and same address
5131          should be identical.  */
5132
5133       else if (SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL
5134           && SYMBOL_CLASS (syms[i].symbol) == LOC_STATIC
5135           && is_nondebugging_type (SYMBOL_TYPE (syms[i].symbol)))
5136         {
5137           for (j = 0; j < nsyms; j += 1)
5138             {
5139               if (i != j
5140                   && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5141                   && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5142                              SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0
5143                   && SYMBOL_CLASS (syms[i].symbol)
5144                        == SYMBOL_CLASS (syms[j].symbol)
5145                   && SYMBOL_VALUE_ADDRESS (syms[i].symbol)
5146                   == SYMBOL_VALUE_ADDRESS (syms[j].symbol))
5147                 remove_p = 1;
5148             }
5149         }
5150       
5151       if (remove_p)
5152         {
5153           for (j = i + 1; j < nsyms; j += 1)
5154             syms[j - 1] = syms[j];
5155           nsyms -= 1;
5156         }
5157
5158       i += 1;
5159     }
5160
5161   /* If all the remaining symbols are identical enumerals, then
5162      just keep the first one and discard the rest.
5163
5164      Unlike what we did previously, we do not discard any entry
5165      unless they are ALL identical.  This is because the symbol
5166      comparison is not a strict comparison, but rather a practical
5167      comparison.  If all symbols are considered identical, then
5168      we can just go ahead and use the first one and discard the rest.
5169      But if we cannot reduce the list to a single element, we have
5170      to ask the user to disambiguate anyways.  And if we have to
5171      present a multiple-choice menu, it's less confusing if the list
5172      isn't missing some choices that were identical and yet distinct.  */
5173   if (symbols_are_identical_enums (syms, nsyms))
5174     nsyms = 1;
5175
5176   return nsyms;
5177 }
5178
5179 /* Given a type that corresponds to a renaming entity, use the type name
5180    to extract the scope (package name or function name, fully qualified,
5181    and following the GNAT encoding convention) where this renaming has been
5182    defined.  */
5183
5184 static std::string
5185 xget_renaming_scope (struct type *renaming_type)
5186 {
5187   /* The renaming types adhere to the following convention:
5188      <scope>__<rename>___<XR extension>.
5189      So, to extract the scope, we search for the "___XR" extension,
5190      and then backtrack until we find the first "__".  */
5191
5192   const char *name = type_name_no_tag (renaming_type);
5193   const char *suffix = strstr (name, "___XR");
5194   const char *last;
5195
5196   /* Now, backtrack a bit until we find the first "__".  Start looking
5197      at suffix - 3, as the <rename> part is at least one character long.  */
5198
5199   for (last = suffix - 3; last > name; last--)
5200     if (last[0] == '_' && last[1] == '_')
5201       break;
5202
5203   /* Make a copy of scope and return it.  */
5204   return std::string (name, last);
5205 }
5206
5207 /* Return nonzero if NAME corresponds to a package name.  */
5208
5209 static int
5210 is_package_name (const char *name)
5211 {
5212   /* Here, We take advantage of the fact that no symbols are generated
5213      for packages, while symbols are generated for each function.
5214      So the condition for NAME represent a package becomes equivalent
5215      to NAME not existing in our list of symbols.  There is only one
5216      small complication with library-level functions (see below).  */
5217
5218   char *fun_name;
5219
5220   /* If it is a function that has not been defined at library level,
5221      then we should be able to look it up in the symbols.  */
5222   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5223     return 0;
5224
5225   /* Library-level function names start with "_ada_".  See if function
5226      "_ada_" followed by NAME can be found.  */
5227
5228   /* Do a quick check that NAME does not contain "__", since library-level
5229      functions names cannot contain "__" in them.  */
5230   if (strstr (name, "__") != NULL)
5231     return 0;
5232
5233   fun_name = xstrprintf ("_ada_%s", name);
5234
5235   return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
5236 }
5237
5238 /* Return nonzero if SYM corresponds to a renaming entity that is
5239    not visible from FUNCTION_NAME.  */
5240
5241 static int
5242 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5243 {
5244   if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5245     return 0;
5246
5247   std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
5248
5249   /* If the rename has been defined in a package, then it is visible.  */
5250   if (is_package_name (scope.c_str ()))
5251     return 0;
5252
5253   /* Check that the rename is in the current function scope by checking
5254      that its name starts with SCOPE.  */
5255
5256   /* If the function name starts with "_ada_", it means that it is
5257      a library-level function.  Strip this prefix before doing the
5258      comparison, as the encoding for the renaming does not contain
5259      this prefix.  */
5260   if (startswith (function_name, "_ada_"))
5261     function_name += 5;
5262
5263   return !startswith (function_name, scope.c_str ());
5264 }
5265
5266 /* Remove entries from SYMS that corresponds to a renaming entity that
5267    is not visible from the function associated with CURRENT_BLOCK or
5268    that is superfluous due to the presence of more specific renaming
5269    information.  Places surviving symbols in the initial entries of
5270    SYMS and returns the number of surviving symbols.
5271    
5272    Rationale:
5273    First, in cases where an object renaming is implemented as a
5274    reference variable, GNAT may produce both the actual reference
5275    variable and the renaming encoding.  In this case, we discard the
5276    latter.
5277
5278    Second, GNAT emits a type following a specified encoding for each renaming
5279    entity.  Unfortunately, STABS currently does not support the definition
5280    of types that are local to a given lexical block, so all renamings types
5281    are emitted at library level.  As a consequence, if an application
5282    contains two renaming entities using the same name, and a user tries to
5283    print the value of one of these entities, the result of the ada symbol
5284    lookup will also contain the wrong renaming type.
5285
5286    This function partially covers for this limitation by attempting to
5287    remove from the SYMS list renaming symbols that should be visible
5288    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
5289    method with the current information available.  The implementation
5290    below has a couple of limitations (FIXME: brobecker-2003-05-12):  
5291    
5292       - When the user tries to print a rename in a function while there
5293         is another rename entity defined in a package:  Normally, the
5294         rename in the function has precedence over the rename in the
5295         package, so the latter should be removed from the list.  This is
5296         currently not the case.
5297         
5298       - This function will incorrectly remove valid renames if
5299         the CURRENT_BLOCK corresponds to a function which symbol name
5300         has been changed by an "Export" pragma.  As a consequence,
5301         the user will be unable to print such rename entities.  */
5302
5303 static int
5304 remove_irrelevant_renamings (struct block_symbol *syms,
5305                              int nsyms, const struct block *current_block)
5306 {
5307   struct symbol *current_function;
5308   const char *current_function_name;
5309   int i;
5310   int is_new_style_renaming;
5311
5312   /* If there is both a renaming foo___XR... encoded as a variable and
5313      a simple variable foo in the same block, discard the latter.
5314      First, zero out such symbols, then compress.  */
5315   is_new_style_renaming = 0;
5316   for (i = 0; i < nsyms; i += 1)
5317     {
5318       struct symbol *sym = syms[i].symbol;
5319       const struct block *block = syms[i].block;
5320       const char *name;
5321       const char *suffix;
5322
5323       if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5324         continue;
5325       name = SYMBOL_LINKAGE_NAME (sym);
5326       suffix = strstr (name, "___XR");
5327
5328       if (suffix != NULL)
5329         {
5330           int name_len = suffix - name;
5331           int j;
5332
5333           is_new_style_renaming = 1;
5334           for (j = 0; j < nsyms; j += 1)
5335             if (i != j && syms[j].symbol != NULL
5336                 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].symbol),
5337                             name_len) == 0
5338                 && block == syms[j].block)
5339               syms[j].symbol = NULL;
5340         }
5341     }
5342   if (is_new_style_renaming)
5343     {
5344       int j, k;
5345
5346       for (j = k = 0; j < nsyms; j += 1)
5347         if (syms[j].symbol != NULL)
5348             {
5349               syms[k] = syms[j];
5350               k += 1;
5351             }
5352       return k;
5353     }
5354
5355   /* Extract the function name associated to CURRENT_BLOCK.
5356      Abort if unable to do so.  */
5357
5358   if (current_block == NULL)
5359     return nsyms;
5360
5361   current_function = block_linkage_function (current_block);
5362   if (current_function == NULL)
5363     return nsyms;
5364
5365   current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5366   if (current_function_name == NULL)
5367     return nsyms;
5368
5369   /* Check each of the symbols, and remove it from the list if it is
5370      a type corresponding to a renaming that is out of the scope of
5371      the current block.  */
5372
5373   i = 0;
5374   while (i < nsyms)
5375     {
5376       if (ada_parse_renaming (syms[i].symbol, NULL, NULL, NULL)
5377           == ADA_OBJECT_RENAMING
5378           && old_renaming_is_invisible (syms[i].symbol, current_function_name))
5379         {
5380           int j;
5381
5382           for (j = i + 1; j < nsyms; j += 1)
5383             syms[j - 1] = syms[j];
5384           nsyms -= 1;
5385         }
5386       else
5387         i += 1;
5388     }
5389
5390   return nsyms;
5391 }
5392
5393 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5394    whose name and domain match NAME and DOMAIN respectively.
5395    If no match was found, then extend the search to "enclosing"
5396    routines (in other words, if we're inside a nested function,
5397    search the symbols defined inside the enclosing functions).
5398    If WILD_MATCH_P is nonzero, perform the naming matching in
5399    "wild" mode (see function "wild_match" for more info).
5400
5401    Note: This function assumes that OBSTACKP has 0 (zero) element in it.  */
5402
5403 static void
5404 ada_add_local_symbols (struct obstack *obstackp,
5405                        const lookup_name_info &lookup_name,
5406                        const struct block *block, domain_enum domain)
5407 {
5408   int block_depth = 0;
5409
5410   while (block != NULL)
5411     {
5412       block_depth += 1;
5413       ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5414
5415       /* If we found a non-function match, assume that's the one.  */
5416       if (is_nonfunction (defns_collected (obstackp, 0),
5417                           num_defns_collected (obstackp)))
5418         return;
5419
5420       block = BLOCK_SUPERBLOCK (block);
5421     }
5422
5423   /* If no luck so far, try to find NAME as a local symbol in some lexically
5424      enclosing subprogram.  */
5425   if (num_defns_collected (obstackp) == 0 && block_depth > 2)
5426     add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
5427 }
5428
5429 /* An object of this type is used as the user_data argument when
5430    calling the map_matching_symbols method.  */
5431
5432 struct match_data
5433 {
5434   struct objfile *objfile;
5435   struct obstack *obstackp;
5436   struct symbol *arg_sym;
5437   int found_sym;
5438 };
5439
5440 /* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
5441    to a list of symbols.  DATA0 is a pointer to a struct match_data *
5442    containing the obstack that collects the symbol list, the file that SYM
5443    must come from, a flag indicating whether a non-argument symbol has
5444    been found in the current block, and the last argument symbol
5445    passed in SYM within the current block (if any).  When SYM is null,
5446    marking the end of a block, the argument symbol is added if no
5447    other has been found.  */
5448
5449 static int
5450 aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
5451 {
5452   struct match_data *data = (struct match_data *) data0;
5453   
5454   if (sym == NULL)
5455     {
5456       if (!data->found_sym && data->arg_sym != NULL) 
5457         add_defn_to_vec (data->obstackp,
5458                          fixup_symbol_section (data->arg_sym, data->objfile),
5459                          block);
5460       data->found_sym = 0;
5461       data->arg_sym = NULL;
5462     }
5463   else 
5464     {
5465       if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5466         return 0;
5467       else if (SYMBOL_IS_ARGUMENT (sym))
5468         data->arg_sym = sym;
5469       else
5470         {
5471           data->found_sym = 1;
5472           add_defn_to_vec (data->obstackp,
5473                            fixup_symbol_section (sym, data->objfile),
5474                            block);
5475         }
5476     }
5477   return 0;
5478 }
5479
5480 /* Helper for add_nonlocal_symbols.  Find symbols in DOMAIN which are
5481    targeted by renamings matching LOOKUP_NAME in BLOCK.  Add these
5482    symbols to OBSTACKP.  Return whether we found such symbols.  */
5483
5484 static int
5485 ada_add_block_renamings (struct obstack *obstackp,
5486                          const struct block *block,
5487                          const lookup_name_info &lookup_name,
5488                          domain_enum domain)
5489 {
5490   struct using_direct *renaming;
5491   int defns_mark = num_defns_collected (obstackp);
5492
5493   symbol_name_matcher_ftype *name_match
5494     = ada_get_symbol_name_matcher (lookup_name);
5495
5496   for (renaming = block_using (block);
5497        renaming != NULL;
5498        renaming = renaming->next)
5499     {
5500       const char *r_name;
5501
5502       /* Avoid infinite recursions: skip this renaming if we are actually
5503          already traversing it.
5504
5505          Currently, symbol lookup in Ada don't use the namespace machinery from
5506          C++/Fortran support: skip namespace imports that use them.  */
5507       if (renaming->searched
5508           || (renaming->import_src != NULL
5509               && renaming->import_src[0] != '\0')
5510           || (renaming->import_dest != NULL
5511               && renaming->import_dest[0] != '\0'))
5512         continue;
5513       renaming->searched = 1;
5514
5515       /* TODO: here, we perform another name-based symbol lookup, which can
5516          pull its own multiple overloads.  In theory, we should be able to do
5517          better in this case since, in DWARF, DW_AT_import is a DIE reference,
5518          not a simple name.  But in order to do this, we would need to enhance
5519          the DWARF reader to associate a symbol to this renaming, instead of a
5520          name.  So, for now, we do something simpler: re-use the C++/Fortran
5521          namespace machinery.  */
5522       r_name = (renaming->alias != NULL
5523                 ? renaming->alias
5524                 : renaming->declaration);
5525       if (name_match (r_name, lookup_name, NULL))
5526         {
5527           lookup_name_info decl_lookup_name (renaming->declaration,
5528                                              lookup_name.match_type ());
5529           ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5530                                1, NULL);
5531         }
5532       renaming->searched = 0;
5533     }
5534   return num_defns_collected (obstackp) != defns_mark;
5535 }
5536
5537 /* Implements compare_names, but only applying the comparision using
5538    the given CASING.  */
5539
5540 static int
5541 compare_names_with_case (const char *string1, const char *string2,
5542                          enum case_sensitivity casing)
5543 {
5544   while (*string1 != '\0' && *string2 != '\0')
5545     {
5546       char c1, c2;
5547
5548       if (isspace (*string1) || isspace (*string2))
5549         return strcmp_iw_ordered (string1, string2);
5550
5551       if (casing == case_sensitive_off)
5552         {
5553           c1 = tolower (*string1);
5554           c2 = tolower (*string2);
5555         }
5556       else
5557         {
5558           c1 = *string1;
5559           c2 = *string2;
5560         }
5561       if (c1 != c2)
5562         break;
5563
5564       string1 += 1;
5565       string2 += 1;
5566     }
5567
5568   switch (*string1)
5569     {
5570     case '(':
5571       return strcmp_iw_ordered (string1, string2);
5572     case '_':
5573       if (*string2 == '\0')
5574         {
5575           if (is_name_suffix (string1))
5576             return 0;
5577           else
5578             return 1;
5579         }
5580       /* FALLTHROUGH */
5581     default:
5582       if (*string2 == '(')
5583         return strcmp_iw_ordered (string1, string2);
5584       else
5585         {
5586           if (casing == case_sensitive_off)
5587             return tolower (*string1) - tolower (*string2);
5588           else
5589             return *string1 - *string2;
5590         }
5591     }
5592 }
5593
5594 /* Compare STRING1 to STRING2, with results as for strcmp.
5595    Compatible with strcmp_iw_ordered in that...
5596
5597        strcmp_iw_ordered (STRING1, STRING2) <= 0
5598
5599    ... implies...
5600
5601        compare_names (STRING1, STRING2) <= 0
5602
5603    (they may differ as to what symbols compare equal).  */
5604
5605 static int
5606 compare_names (const char *string1, const char *string2)
5607 {
5608   int result;
5609
5610   /* Similar to what strcmp_iw_ordered does, we need to perform
5611      a case-insensitive comparison first, and only resort to
5612      a second, case-sensitive, comparison if the first one was
5613      not sufficient to differentiate the two strings.  */
5614
5615   result = compare_names_with_case (string1, string2, case_sensitive_off);
5616   if (result == 0)
5617     result = compare_names_with_case (string1, string2, case_sensitive_on);
5618
5619   return result;
5620 }
5621
5622 /* Convenience function to get at the Ada encoded lookup name for
5623    LOOKUP_NAME, as a C string.  */
5624
5625 static const char *
5626 ada_lookup_name (const lookup_name_info &lookup_name)
5627 {
5628   return lookup_name.ada ().lookup_name ().c_str ();
5629 }
5630
5631 /* Add to OBSTACKP all non-local symbols whose name and domain match
5632    LOOKUP_NAME and DOMAIN respectively.  The search is performed on
5633    GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5634    symbols otherwise.  */
5635
5636 static void
5637 add_nonlocal_symbols (struct obstack *obstackp,
5638                       const lookup_name_info &lookup_name,
5639                       domain_enum domain, int global)
5640 {
5641   struct objfile *objfile;
5642   struct compunit_symtab *cu;
5643   struct match_data data;
5644
5645   memset (&data, 0, sizeof data);
5646   data.obstackp = obstackp;
5647
5648   bool is_wild_match = lookup_name.ada ().wild_match_p ();
5649
5650   ALL_OBJFILES (objfile)
5651     {
5652       data.objfile = objfile;
5653
5654       if (is_wild_match)
5655         objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5656                                                domain, global,
5657                                                aux_add_nonlocal_symbols, &data,
5658                                                symbol_name_match_type::WILD,
5659                                                NULL);
5660       else
5661         objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5662                                                domain, global,
5663                                                aux_add_nonlocal_symbols, &data,
5664                                                symbol_name_match_type::FULL,
5665                                                compare_names);
5666
5667       ALL_OBJFILE_COMPUNITS (objfile, cu)
5668         {
5669           const struct block *global_block
5670             = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5671
5672           if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5673                                        domain))
5674             data.found_sym = 1;
5675         }
5676     }
5677
5678   if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5679     {
5680       const char *name = ada_lookup_name (lookup_name);
5681       std::string name1 = std::string ("<_ada_") + name + '>';
5682
5683       ALL_OBJFILES (objfile)
5684         {
5685           data.objfile = objfile;
5686           objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5687                                                  domain, global,
5688                                                  aux_add_nonlocal_symbols,
5689                                                  &data,
5690                                                  symbol_name_match_type::FULL,
5691                                                  compare_names);
5692         }
5693     }           
5694 }
5695
5696 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5697    FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5698    returning the number of matches.  Add these to OBSTACKP.
5699
5700    When FULL_SEARCH is non-zero, any non-function/non-enumeral
5701    symbol match within the nest of blocks whose innermost member is BLOCK,
5702    is the one match returned (no other matches in that or
5703    enclosing blocks is returned).  If there are any matches in or
5704    surrounding BLOCK, then these alone are returned.
5705
5706    Names prefixed with "standard__" are handled specially:
5707    "standard__" is first stripped off (by the lookup_name
5708    constructor), and only static and global symbols are searched.
5709
5710    If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5711    to lookup global symbols.  */
5712
5713 static void
5714 ada_add_all_symbols (struct obstack *obstackp,
5715                      const struct block *block,
5716                      const lookup_name_info &lookup_name,
5717                      domain_enum domain,
5718                      int full_search,
5719                      int *made_global_lookup_p)
5720 {
5721   struct symbol *sym;
5722
5723   if (made_global_lookup_p)
5724     *made_global_lookup_p = 0;
5725
5726   /* Special case: If the user specifies a symbol name inside package
5727      Standard, do a non-wild matching of the symbol name without
5728      the "standard__" prefix.  This was primarily introduced in order
5729      to allow the user to specifically access the standard exceptions
5730      using, for instance, Standard.Constraint_Error when Constraint_Error
5731      is ambiguous (due to the user defining its own Constraint_Error
5732      entity inside its program).  */
5733   if (lookup_name.ada ().standard_p ())
5734     block = NULL;
5735
5736   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
5737
5738   if (block != NULL)
5739     {
5740       if (full_search)
5741         ada_add_local_symbols (obstackp, lookup_name, block, domain);
5742       else
5743         {
5744           /* In the !full_search case we're are being called by
5745              ada_iterate_over_symbols, and we don't want to search
5746              superblocks.  */
5747           ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5748         }
5749       if (num_defns_collected (obstackp) > 0 || !full_search)
5750         return;
5751     }
5752
5753   /* No non-global symbols found.  Check our cache to see if we have
5754      already performed this search before.  If we have, then return
5755      the same result.  */
5756
5757   if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5758                             domain, &sym, &block))
5759     {
5760       if (sym != NULL)
5761         add_defn_to_vec (obstackp, sym, block);
5762       return;
5763     }
5764
5765   if (made_global_lookup_p)
5766     *made_global_lookup_p = 1;
5767
5768   /* Search symbols from all global blocks.  */
5769  
5770   add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
5771
5772   /* Now add symbols from all per-file blocks if we've gotten no hits
5773      (not strictly correct, but perhaps better than an error).  */
5774
5775   if (num_defns_collected (obstackp) == 0)
5776     add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
5777 }
5778
5779 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5780    is non-zero, enclosing scope and in global scopes, returning the number of
5781    matches.
5782    Sets *RESULTS to point to a newly allocated vector of (SYM,BLOCK) tuples,
5783    indicating the symbols found and the blocks and symbol tables (if
5784    any) in which they were found.  This vector should be freed when
5785    no longer useful.
5786
5787    When full_search is non-zero, any non-function/non-enumeral
5788    symbol match within the nest of blocks whose innermost member is BLOCK,
5789    is the one match returned (no other matches in that or
5790    enclosing blocks is returned).  If there are any matches in or
5791    surrounding BLOCK, then these alone are returned.
5792
5793    Names prefixed with "standard__" are handled specially: "standard__"
5794    is first stripped off, and only static and global symbols are searched.  */
5795
5796 static int
5797 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5798                                const struct block *block,
5799                                domain_enum domain,
5800                                struct block_symbol **results,
5801                                int full_search)
5802 {
5803   int syms_from_global_search;
5804   int ndefns;
5805   int results_size;
5806   auto_obstack obstack;
5807
5808   ada_add_all_symbols (&obstack, block, lookup_name,
5809                        domain, full_search, &syms_from_global_search);
5810
5811   ndefns = num_defns_collected (&obstack);
5812
5813   results_size = obstack_object_size (&obstack);
5814   *results = (struct block_symbol *) malloc (results_size);
5815   memcpy (*results, defns_collected (&obstack, 1), results_size);
5816
5817   ndefns = remove_extra_symbols (*results, ndefns);
5818
5819   if (ndefns == 0 && full_search && syms_from_global_search)
5820     cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5821
5822   if (ndefns == 1 && full_search && syms_from_global_search)
5823     cache_symbol (ada_lookup_name (lookup_name), domain,
5824                   (*results)[0].symbol, (*results)[0].block);
5825
5826   ndefns = remove_irrelevant_renamings (*results, ndefns, block);
5827
5828   return ndefns;
5829 }
5830
5831 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5832    in global scopes, returning the number of matches, and setting *RESULTS
5833    to a newly-allocated vector of (SYM,BLOCK) tuples.  This newly-allocated
5834    vector should be freed when no longer useful.
5835
5836    See ada_lookup_symbol_list_worker for further details.  */
5837
5838 int
5839 ada_lookup_symbol_list (const char *name, const struct block *block,
5840                         domain_enum domain, struct block_symbol **results)
5841 {
5842   symbol_name_match_type name_match_type = name_match_type_from_name (name);
5843   lookup_name_info lookup_name (name, name_match_type);
5844
5845   return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
5846 }
5847
5848 /* Implementation of the la_iterate_over_symbols method.  */
5849
5850 static void
5851 ada_iterate_over_symbols
5852   (const struct block *block, const lookup_name_info &name,
5853    domain_enum domain,
5854    gdb::function_view<symbol_found_callback_ftype> callback)
5855 {
5856   int ndefs, i;
5857   struct block_symbol *results;
5858   struct cleanup *old_chain;
5859
5860   ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5861   old_chain = make_cleanup (xfree, results);
5862
5863   for (i = 0; i < ndefs; ++i)
5864     {
5865       if (!callback (results[i].symbol))
5866         break;
5867     }
5868
5869   do_cleanups (old_chain);
5870 }
5871
5872 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5873    to 1, but choosing the first symbol found if there are multiple
5874    choices.
5875
5876    The result is stored in *INFO, which must be non-NULL.
5877    If no match is found, INFO->SYM is set to NULL.  */
5878
5879 void
5880 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5881                            domain_enum domain,
5882                            struct block_symbol *info)
5883 {
5884   /* Since we already have an encoded name, wrap it in '<>' to force a
5885      verbatim match.  Otherwise, if the name happens to not look like
5886      an encoded name (because it doesn't include a "__"),
5887      ada_lookup_name_info would re-encode/fold it again, and that
5888      would e.g., incorrectly lowercase object renaming names like
5889      "R28b" -> "r28b".  */
5890   std::string verbatim = std::string ("<") + name + '>';
5891
5892   gdb_assert (info != NULL);
5893   *info = ada_lookup_symbol (verbatim.c_str (), block, domain, NULL);
5894 }
5895
5896 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5897    scope and in global scopes, or NULL if none.  NAME is folded and
5898    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
5899    choosing the first symbol if there are multiple choices.
5900    If IS_A_FIELD_OF_THIS is not NULL, it is set to zero.  */
5901
5902 struct block_symbol
5903 ada_lookup_symbol (const char *name, const struct block *block0,
5904                    domain_enum domain, int *is_a_field_of_this)
5905 {
5906   if (is_a_field_of_this != NULL)
5907     *is_a_field_of_this = 0;
5908
5909   struct block_symbol *candidates;
5910   int n_candidates;
5911   struct cleanup *old_chain;
5912
5913   n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
5914   old_chain = make_cleanup (xfree, candidates);
5915
5916   if (n_candidates == 0)
5917     {
5918       do_cleanups (old_chain);
5919       return {};
5920     }
5921
5922   block_symbol info = candidates[0];
5923   info.symbol = fixup_symbol_section (info.symbol, NULL);
5924
5925   do_cleanups (old_chain);
5926
5927   return info;
5928 }
5929
5930 static struct block_symbol
5931 ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5932                             const char *name,
5933                             const struct block *block,
5934                             const domain_enum domain)
5935 {
5936   struct block_symbol sym;
5937
5938   sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
5939   if (sym.symbol != NULL)
5940     return sym;
5941
5942   /* If we haven't found a match at this point, try the primitive
5943      types.  In other languages, this search is performed before
5944      searching for global symbols in order to short-circuit that
5945      global-symbol search if it happens that the name corresponds
5946      to a primitive type.  But we cannot do the same in Ada, because
5947      it is perfectly legitimate for a program to declare a type which
5948      has the same name as a standard type.  If looking up a type in
5949      that situation, we have traditionally ignored the primitive type
5950      in favor of user-defined types.  This is why, unlike most other
5951      languages, we search the primitive types this late and only after
5952      having searched the global symbols without success.  */
5953
5954   if (domain == VAR_DOMAIN)
5955     {
5956       struct gdbarch *gdbarch;
5957
5958       if (block == NULL)
5959         gdbarch = target_gdbarch ();
5960       else
5961         gdbarch = block_gdbarch (block);
5962       sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5963       if (sym.symbol != NULL)
5964         return sym;
5965     }
5966
5967   return (struct block_symbol) {NULL, NULL};
5968 }
5969
5970
5971 /* True iff STR is a possible encoded suffix of a normal Ada name
5972    that is to be ignored for matching purposes.  Suffixes of parallel
5973    names (e.g., XVE) are not included here.  Currently, the possible suffixes
5974    are given by any of the regular expressions:
5975
5976    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
5977    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
5978    TKB              [subprogram suffix for task bodies]
5979    _E[0-9]+[bs]$    [protected object entry suffixes]
5980    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5981
5982    Also, any leading "__[0-9]+" sequence is skipped before the suffix
5983    match is performed.  This sequence is used to differentiate homonyms,
5984    is an optional part of a valid name suffix.  */
5985
5986 static int
5987 is_name_suffix (const char *str)
5988 {
5989   int k;
5990   const char *matching;
5991   const int len = strlen (str);
5992
5993   /* Skip optional leading __[0-9]+.  */
5994
5995   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5996     {
5997       str += 3;
5998       while (isdigit (str[0]))
5999         str += 1;
6000     }
6001   
6002   /* [.$][0-9]+ */
6003
6004   if (str[0] == '.' || str[0] == '$')
6005     {
6006       matching = str + 1;
6007       while (isdigit (matching[0]))
6008         matching += 1;
6009       if (matching[0] == '\0')
6010         return 1;
6011     }
6012
6013   /* ___[0-9]+ */
6014
6015   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
6016     {
6017       matching = str + 3;
6018       while (isdigit (matching[0]))
6019         matching += 1;
6020       if (matching[0] == '\0')
6021         return 1;
6022     }
6023
6024   /* "TKB" suffixes are used for subprograms implementing task bodies.  */
6025
6026   if (strcmp (str, "TKB") == 0)
6027     return 1;
6028
6029 #if 0
6030   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
6031      with a N at the end.  Unfortunately, the compiler uses the same
6032      convention for other internal types it creates.  So treating
6033      all entity names that end with an "N" as a name suffix causes
6034      some regressions.  For instance, consider the case of an enumerated
6035      type.  To support the 'Image attribute, it creates an array whose
6036      name ends with N.
6037      Having a single character like this as a suffix carrying some
6038      information is a bit risky.  Perhaps we should change the encoding
6039      to be something like "_N" instead.  In the meantime, do not do
6040      the following check.  */
6041   /* Protected Object Subprograms */
6042   if (len == 1 && str [0] == 'N')
6043     return 1;
6044 #endif
6045
6046   /* _E[0-9]+[bs]$ */
6047   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
6048     {
6049       matching = str + 3;
6050       while (isdigit (matching[0]))
6051         matching += 1;
6052       if ((matching[0] == 'b' || matching[0] == 's')
6053           && matching [1] == '\0')
6054         return 1;
6055     }
6056
6057   /* ??? We should not modify STR directly, as we are doing below.  This
6058      is fine in this case, but may become problematic later if we find
6059      that this alternative did not work, and want to try matching
6060      another one from the begining of STR.  Since we modified it, we
6061      won't be able to find the begining of the string anymore!  */
6062   if (str[0] == 'X')
6063     {
6064       str += 1;
6065       while (str[0] != '_' && str[0] != '\0')
6066         {
6067           if (str[0] != 'n' && str[0] != 'b')
6068             return 0;
6069           str += 1;
6070         }
6071     }
6072
6073   if (str[0] == '\000')
6074     return 1;
6075
6076   if (str[0] == '_')
6077     {
6078       if (str[1] != '_' || str[2] == '\000')
6079         return 0;
6080       if (str[2] == '_')
6081         {
6082           if (strcmp (str + 3, "JM") == 0)
6083             return 1;
6084           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6085              the LJM suffix in favor of the JM one.  But we will
6086              still accept LJM as a valid suffix for a reasonable
6087              amount of time, just to allow ourselves to debug programs
6088              compiled using an older version of GNAT.  */
6089           if (strcmp (str + 3, "LJM") == 0)
6090             return 1;
6091           if (str[3] != 'X')
6092             return 0;
6093           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6094               || str[4] == 'U' || str[4] == 'P')
6095             return 1;
6096           if (str[4] == 'R' && str[5] != 'T')
6097             return 1;
6098           return 0;
6099         }
6100       if (!isdigit (str[2]))
6101         return 0;
6102       for (k = 3; str[k] != '\0'; k += 1)
6103         if (!isdigit (str[k]) && str[k] != '_')
6104           return 0;
6105       return 1;
6106     }
6107   if (str[0] == '$' && isdigit (str[1]))
6108     {
6109       for (k = 2; str[k] != '\0'; k += 1)
6110         if (!isdigit (str[k]) && str[k] != '_')
6111           return 0;
6112       return 1;
6113     }
6114   return 0;
6115 }
6116
6117 /* Return non-zero if the string starting at NAME and ending before
6118    NAME_END contains no capital letters.  */
6119
6120 static int
6121 is_valid_name_for_wild_match (const char *name0)
6122 {
6123   const char *decoded_name = ada_decode (name0);
6124   int i;
6125
6126   /* If the decoded name starts with an angle bracket, it means that
6127      NAME0 does not follow the GNAT encoding format.  It should then
6128      not be allowed as a possible wild match.  */
6129   if (decoded_name[0] == '<')
6130     return 0;
6131
6132   for (i=0; decoded_name[i] != '\0'; i++)
6133     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6134       return 0;
6135
6136   return 1;
6137 }
6138
6139 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6140    that could start a simple name.  Assumes that *NAMEP points into
6141    the string beginning at NAME0.  */
6142
6143 static int
6144 advance_wild_match (const char **namep, const char *name0, int target0)
6145 {
6146   const char *name = *namep;
6147
6148   while (1)
6149     {
6150       int t0, t1;
6151
6152       t0 = *name;
6153       if (t0 == '_')
6154         {
6155           t1 = name[1];
6156           if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6157             {
6158               name += 1;
6159               if (name == name0 + 5 && startswith (name0, "_ada"))
6160                 break;
6161               else
6162                 name += 1;
6163             }
6164           else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6165                                  || name[2] == target0))
6166             {
6167               name += 2;
6168               break;
6169             }
6170           else
6171             return 0;
6172         }
6173       else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6174         name += 1;
6175       else
6176         return 0;
6177     }
6178
6179   *namep = name;
6180   return 1;
6181 }
6182
6183 /* Return true iff NAME encodes a name of the form prefix.PATN.
6184    Ignores any informational suffixes of NAME (i.e., for which
6185    is_name_suffix is true).  Assumes that PATN is a lower-cased Ada
6186    simple name.  */
6187
6188 static bool
6189 wild_match (const char *name, const char *patn)
6190 {
6191   const char *p;
6192   const char *name0 = name;
6193
6194   while (1)
6195     {
6196       const char *match = name;
6197
6198       if (*name == *patn)
6199         {
6200           for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6201             if (*p != *name)
6202               break;
6203           if (*p == '\0' && is_name_suffix (name))
6204             return match == name0 || is_valid_name_for_wild_match (name0);
6205
6206           if (name[-1] == '_')
6207             name -= 1;
6208         }
6209       if (!advance_wild_match (&name, name0, *patn))
6210         return false;
6211     }
6212 }
6213
6214 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6215    any trailing suffixes that encode debugging information or leading
6216    _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6217    information that is ignored).  */
6218
6219 static bool
6220 full_match (const char *sym_name, const char *search_name)
6221 {
6222   size_t search_name_len = strlen (search_name);
6223
6224   if (strncmp (sym_name, search_name, search_name_len) == 0
6225       && is_name_suffix (sym_name + search_name_len))
6226     return true;
6227
6228   if (startswith (sym_name, "_ada_")
6229       && strncmp (sym_name + 5, search_name, search_name_len) == 0
6230       && is_name_suffix (sym_name + search_name_len + 5))
6231     return true;
6232
6233   return false;
6234 }
6235
6236 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6237    *defn_symbols, updating the list of symbols in OBSTACKP (if
6238    necessary).  OBJFILE is the section containing BLOCK.  */
6239
6240 static void
6241 ada_add_block_symbols (struct obstack *obstackp,
6242                        const struct block *block,
6243                        const lookup_name_info &lookup_name,
6244                        domain_enum domain, struct objfile *objfile)
6245 {
6246   struct block_iterator iter;
6247   /* A matching argument symbol, if any.  */
6248   struct symbol *arg_sym;
6249   /* Set true when we find a matching non-argument symbol.  */
6250   int found_sym;
6251   struct symbol *sym;
6252
6253   arg_sym = NULL;
6254   found_sym = 0;
6255   for (sym = block_iter_match_first (block, lookup_name, &iter);
6256        sym != NULL;
6257        sym = block_iter_match_next (lookup_name, &iter))
6258     {
6259       if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6260                                  SYMBOL_DOMAIN (sym), domain))
6261         {
6262           if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6263             {
6264               if (SYMBOL_IS_ARGUMENT (sym))
6265                 arg_sym = sym;
6266               else
6267                 {
6268                   found_sym = 1;
6269                   add_defn_to_vec (obstackp,
6270                                    fixup_symbol_section (sym, objfile),
6271                                    block);
6272                 }
6273             }
6274         }
6275     }
6276
6277   /* Handle renamings.  */
6278
6279   if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
6280     found_sym = 1;
6281
6282   if (!found_sym && arg_sym != NULL)
6283     {
6284       add_defn_to_vec (obstackp,
6285                        fixup_symbol_section (arg_sym, objfile),
6286                        block);
6287     }
6288
6289   if (!lookup_name.ada ().wild_match_p ())
6290     {
6291       arg_sym = NULL;
6292       found_sym = 0;
6293       const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6294       const char *name = ada_lookup_name.c_str ();
6295       size_t name_len = ada_lookup_name.size ();
6296
6297       ALL_BLOCK_SYMBOLS (block, iter, sym)
6298       {
6299         if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6300                                    SYMBOL_DOMAIN (sym), domain))
6301           {
6302             int cmp;
6303
6304             cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6305             if (cmp == 0)
6306               {
6307                 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
6308                 if (cmp == 0)
6309                   cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6310                                  name_len);
6311               }
6312
6313             if (cmp == 0
6314                 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6315               {
6316                 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6317                   {
6318                     if (SYMBOL_IS_ARGUMENT (sym))
6319                       arg_sym = sym;
6320                     else
6321                       {
6322                         found_sym = 1;
6323                         add_defn_to_vec (obstackp,
6324                                          fixup_symbol_section (sym, objfile),
6325                                          block);
6326                       }
6327                   }
6328               }
6329           }
6330       }
6331
6332       /* NOTE: This really shouldn't be needed for _ada_ symbols.
6333          They aren't parameters, right?  */
6334       if (!found_sym && arg_sym != NULL)
6335         {
6336           add_defn_to_vec (obstackp,
6337                            fixup_symbol_section (arg_sym, objfile),
6338                            block);
6339         }
6340     }
6341 }
6342 \f
6343
6344                                 /* Symbol Completion */
6345
6346 /* See symtab.h.  */
6347
6348 bool
6349 ada_lookup_name_info::matches
6350   (const char *sym_name,
6351    symbol_name_match_type match_type,
6352    completion_match_result *comp_match_res) const
6353 {
6354   bool match = false;
6355   const char *text = m_encoded_name.c_str ();
6356   size_t text_len = m_encoded_name.size ();
6357
6358   /* First, test against the fully qualified name of the symbol.  */
6359
6360   if (strncmp (sym_name, text, text_len) == 0)
6361     match = true;
6362
6363   if (match && !m_encoded_p)
6364     {
6365       /* One needed check before declaring a positive match is to verify
6366          that iff we are doing a verbatim match, the decoded version
6367          of the symbol name starts with '<'.  Otherwise, this symbol name
6368          is not a suitable completion.  */
6369       const char *sym_name_copy = sym_name;
6370       bool has_angle_bracket;
6371
6372       sym_name = ada_decode (sym_name);
6373       has_angle_bracket = (sym_name[0] == '<');
6374       match = (has_angle_bracket == m_verbatim_p);
6375       sym_name = sym_name_copy;
6376     }
6377
6378   if (match && !m_verbatim_p)
6379     {
6380       /* When doing non-verbatim match, another check that needs to
6381          be done is to verify that the potentially matching symbol name
6382          does not include capital letters, because the ada-mode would
6383          not be able to understand these symbol names without the
6384          angle bracket notation.  */
6385       const char *tmp;
6386
6387       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6388       if (*tmp != '\0')
6389         match = false;
6390     }
6391
6392   /* Second: Try wild matching...  */
6393
6394   if (!match && m_wild_match_p)
6395     {
6396       /* Since we are doing wild matching, this means that TEXT
6397          may represent an unqualified symbol name.  We therefore must
6398          also compare TEXT against the unqualified name of the symbol.  */
6399       sym_name = ada_unqualified_name (ada_decode (sym_name));
6400
6401       if (strncmp (sym_name, text, text_len) == 0)
6402         match = true;
6403     }
6404
6405   /* Finally: If we found a match, prepare the result to return.  */
6406
6407   if (!match)
6408     return false;
6409
6410   if (comp_match_res != NULL)
6411     {
6412       std::string &match_str = comp_match_res->match.storage ();
6413
6414       if (!m_encoded_p)
6415         match_str = ada_decode (sym_name);
6416       else
6417         {
6418           if (m_verbatim_p)
6419             match_str = add_angle_brackets (sym_name);
6420           else
6421             match_str = sym_name;
6422
6423         }
6424
6425       comp_match_res->set_match (match_str.c_str ());
6426     }
6427
6428   return true;
6429 }
6430
6431 /* Add the list of possible symbol names completing TEXT to TRACKER.
6432    WORD is the entire command on which completion is made.  */
6433
6434 static void
6435 ada_collect_symbol_completion_matches (completion_tracker &tracker,
6436                                        complete_symbol_mode mode,
6437                                        symbol_name_match_type name_match_type,
6438                                        const char *text, const char *word,
6439                                        enum type_code code)
6440 {
6441   struct symbol *sym;
6442   struct compunit_symtab *s;
6443   struct minimal_symbol *msymbol;
6444   struct objfile *objfile;
6445   const struct block *b, *surrounding_static_block = 0;
6446   struct block_iterator iter;
6447   struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
6448
6449   gdb_assert (code == TYPE_CODE_UNDEF);
6450
6451   lookup_name_info lookup_name (text, name_match_type, true);
6452
6453   /* First, look at the partial symtab symbols.  */
6454   expand_symtabs_matching (NULL,
6455                            lookup_name,
6456                            NULL,
6457                            NULL,
6458                            ALL_DOMAIN);
6459
6460   /* At this point scan through the misc symbol vectors and add each
6461      symbol you find to the list.  Eventually we want to ignore
6462      anything that isn't a text symbol (everything else will be
6463      handled by the psymtab code above).  */
6464
6465   ALL_MSYMBOLS (objfile, msymbol)
6466   {
6467     QUIT;
6468
6469     if (completion_skip_symbol (mode, msymbol))
6470       continue;
6471
6472     language symbol_language = MSYMBOL_LANGUAGE (msymbol);
6473
6474     /* Ada minimal symbols won't have their language set to Ada.  If
6475        we let completion_list_add_name compare using the
6476        default/C-like matcher, then when completing e.g., symbols in a
6477        package named "pck", we'd match internal Ada symbols like
6478        "pckS", which are invalid in an Ada expression, unless you wrap
6479        them in '<' '>' to request a verbatim match.
6480
6481        Unfortunately, some Ada encoded names successfully demangle as
6482        C++ symbols (using an old mangling scheme), such as "name__2Xn"
6483        -> "Xn::name(void)" and thus some Ada minimal symbols end up
6484        with the wrong language set.  Paper over that issue here.  */
6485     if (symbol_language == language_auto
6486         || symbol_language == language_cplus)
6487       symbol_language = language_ada;
6488
6489     completion_list_add_name (tracker,
6490                               symbol_language,
6491                               MSYMBOL_LINKAGE_NAME (msymbol),
6492                               lookup_name, text, word);
6493   }
6494
6495   /* Search upwards from currently selected frame (so that we can
6496      complete on local vars.  */
6497
6498   for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6499     {
6500       if (!BLOCK_SUPERBLOCK (b))
6501         surrounding_static_block = b;   /* For elmin of dups */
6502
6503       ALL_BLOCK_SYMBOLS (b, iter, sym)
6504       {
6505         if (completion_skip_symbol (mode, sym))
6506           continue;
6507
6508         completion_list_add_name (tracker,
6509                                   SYMBOL_LANGUAGE (sym),
6510                                   SYMBOL_LINKAGE_NAME (sym),
6511                                   lookup_name, text, word);
6512       }
6513     }
6514
6515   /* Go through the symtabs and check the externs and statics for
6516      symbols which match.  */
6517
6518   ALL_COMPUNITS (objfile, s)
6519   {
6520     QUIT;
6521     b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
6522     ALL_BLOCK_SYMBOLS (b, iter, sym)
6523     {
6524       if (completion_skip_symbol (mode, sym))
6525         continue;
6526
6527       completion_list_add_name (tracker,
6528                                 SYMBOL_LANGUAGE (sym),
6529                                 SYMBOL_LINKAGE_NAME (sym),
6530                                 lookup_name, text, word);
6531     }
6532   }
6533
6534   ALL_COMPUNITS (objfile, s)
6535   {
6536     QUIT;
6537     b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
6538     /* Don't do this block twice.  */
6539     if (b == surrounding_static_block)
6540       continue;
6541     ALL_BLOCK_SYMBOLS (b, iter, sym)
6542     {
6543       if (completion_skip_symbol (mode, sym))
6544         continue;
6545
6546       completion_list_add_name (tracker,
6547                                 SYMBOL_LANGUAGE (sym),
6548                                 SYMBOL_LINKAGE_NAME (sym),
6549                                 lookup_name, text, word);
6550     }
6551   }
6552
6553   do_cleanups (old_chain);
6554 }
6555
6556                                 /* Field Access */
6557
6558 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6559    for tagged types.  */
6560
6561 static int
6562 ada_is_dispatch_table_ptr_type (struct type *type)
6563 {
6564   const char *name;
6565
6566   if (TYPE_CODE (type) != TYPE_CODE_PTR)
6567     return 0;
6568
6569   name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6570   if (name == NULL)
6571     return 0;
6572
6573   return (strcmp (name, "ada__tags__dispatch_table") == 0);
6574 }
6575
6576 /* Return non-zero if TYPE is an interface tag.  */
6577
6578 static int
6579 ada_is_interface_tag (struct type *type)
6580 {
6581   const char *name = TYPE_NAME (type);
6582
6583   if (name == NULL)
6584     return 0;
6585
6586   return (strcmp (name, "ada__tags__interface_tag") == 0);
6587 }
6588
6589 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6590    to be invisible to users.  */
6591
6592 int
6593 ada_is_ignored_field (struct type *type, int field_num)
6594 {
6595   if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6596     return 1;
6597
6598   /* Check the name of that field.  */
6599   {
6600     const char *name = TYPE_FIELD_NAME (type, field_num);
6601
6602     /* Anonymous field names should not be printed.
6603        brobecker/2007-02-20: I don't think this can actually happen
6604        but we don't want to print the value of annonymous fields anyway.  */
6605     if (name == NULL)
6606       return 1;
6607
6608     /* Normally, fields whose name start with an underscore ("_")
6609        are fields that have been internally generated by the compiler,
6610        and thus should not be printed.  The "_parent" field is special,
6611        however: This is a field internally generated by the compiler
6612        for tagged types, and it contains the components inherited from
6613        the parent type.  This field should not be printed as is, but
6614        should not be ignored either.  */
6615     if (name[0] == '_' && !startswith (name, "_parent"))
6616       return 1;
6617   }
6618
6619   /* If this is the dispatch table of a tagged type or an interface tag,
6620      then ignore.  */
6621   if (ada_is_tagged_type (type, 1)
6622       && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6623           || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
6624     return 1;
6625
6626   /* Not a special field, so it should not be ignored.  */
6627   return 0;
6628 }
6629
6630 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
6631    pointer or reference type whose ultimate target has a tag field.  */
6632
6633 int
6634 ada_is_tagged_type (struct type *type, int refok)
6635 {
6636   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6637 }
6638
6639 /* True iff TYPE represents the type of X'Tag */
6640
6641 int
6642 ada_is_tag_type (struct type *type)
6643 {
6644   type = ada_check_typedef (type);
6645
6646   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6647     return 0;
6648   else
6649     {
6650       const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6651
6652       return (name != NULL
6653               && strcmp (name, "ada__tags__dispatch_table") == 0);
6654     }
6655 }
6656
6657 /* The type of the tag on VAL.  */
6658
6659 struct type *
6660 ada_tag_type (struct value *val)
6661 {
6662   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6663 }
6664
6665 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6666    retired at Ada 05).  */
6667
6668 static int
6669 is_ada95_tag (struct value *tag)
6670 {
6671   return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6672 }
6673
6674 /* The value of the tag on VAL.  */
6675
6676 struct value *
6677 ada_value_tag (struct value *val)
6678 {
6679   return ada_value_struct_elt (val, "_tag", 0);
6680 }
6681
6682 /* The value of the tag on the object of type TYPE whose contents are
6683    saved at VALADDR, if it is non-null, or is at memory address
6684    ADDRESS.  */
6685
6686 static struct value *
6687 value_tag_from_contents_and_address (struct type *type,
6688                                      const gdb_byte *valaddr,
6689                                      CORE_ADDR address)
6690 {
6691   int tag_byte_offset;
6692   struct type *tag_type;
6693
6694   if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
6695                          NULL, NULL, NULL))
6696     {
6697       const gdb_byte *valaddr1 = ((valaddr == NULL)
6698                                   ? NULL
6699                                   : valaddr + tag_byte_offset);
6700       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6701
6702       return value_from_contents_and_address (tag_type, valaddr1, address1);
6703     }
6704   return NULL;
6705 }
6706
6707 static struct type *
6708 type_from_tag (struct value *tag)
6709 {
6710   const char *type_name = ada_tag_name (tag);
6711
6712   if (type_name != NULL)
6713     return ada_find_any_type (ada_encode (type_name));
6714   return NULL;
6715 }
6716
6717 /* Given a value OBJ of a tagged type, return a value of this
6718    type at the base address of the object.  The base address, as
6719    defined in Ada.Tags, it is the address of the primary tag of
6720    the object, and therefore where the field values of its full
6721    view can be fetched.  */
6722
6723 struct value *
6724 ada_tag_value_at_base_address (struct value *obj)
6725 {
6726   struct value *val;
6727   LONGEST offset_to_top = 0;
6728   struct type *ptr_type, *obj_type;
6729   struct value *tag;
6730   CORE_ADDR base_address;
6731
6732   obj_type = value_type (obj);
6733
6734   /* It is the responsability of the caller to deref pointers.  */
6735
6736   if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6737       || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6738     return obj;
6739
6740   tag = ada_value_tag (obj);
6741   if (!tag)
6742     return obj;
6743
6744   /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
6745
6746   if (is_ada95_tag (tag))
6747     return obj;
6748
6749   ptr_type = language_lookup_primitive_type
6750     (language_def (language_ada), target_gdbarch(), "storage_offset");
6751   ptr_type = lookup_pointer_type (ptr_type);
6752   val = value_cast (ptr_type, tag);
6753   if (!val)
6754     return obj;
6755
6756   /* It is perfectly possible that an exception be raised while
6757      trying to determine the base address, just like for the tag;
6758      see ada_tag_name for more details.  We do not print the error
6759      message for the same reason.  */
6760
6761   TRY
6762     {
6763       offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6764     }
6765
6766   CATCH (e, RETURN_MASK_ERROR)
6767     {
6768       return obj;
6769     }
6770   END_CATCH
6771
6772   /* If offset is null, nothing to do.  */
6773
6774   if (offset_to_top == 0)
6775     return obj;
6776
6777   /* -1 is a special case in Ada.Tags; however, what should be done
6778      is not quite clear from the documentation.  So do nothing for
6779      now.  */
6780
6781   if (offset_to_top == -1)
6782     return obj;
6783
6784   /* OFFSET_TO_TOP used to be a positive value to be subtracted
6785      from the base address.  This was however incompatible with
6786      C++ dispatch table: C++ uses a *negative* value to *add*
6787      to the base address.  Ada's convention has therefore been
6788      changed in GNAT 19.0w 20171023: since then, C++ and Ada
6789      use the same convention.  Here, we support both cases by
6790      checking the sign of OFFSET_TO_TOP.  */
6791
6792   if (offset_to_top > 0)
6793     offset_to_top = -offset_to_top;
6794
6795   base_address = value_address (obj) + offset_to_top;
6796   tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6797
6798   /* Make sure that we have a proper tag at the new address.
6799      Otherwise, offset_to_top is bogus (which can happen when
6800      the object is not initialized yet).  */
6801
6802   if (!tag)
6803     return obj;
6804
6805   obj_type = type_from_tag (tag);
6806
6807   if (!obj_type)
6808     return obj;
6809
6810   return value_from_contents_and_address (obj_type, NULL, base_address);
6811 }
6812
6813 /* Return the "ada__tags__type_specific_data" type.  */
6814
6815 static struct type *
6816 ada_get_tsd_type (struct inferior *inf)
6817 {
6818   struct ada_inferior_data *data = get_ada_inferior_data (inf);
6819
6820   if (data->tsd_type == 0)
6821     data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6822   return data->tsd_type;
6823 }
6824
6825 /* Return the TSD (type-specific data) associated to the given TAG.
6826    TAG is assumed to be the tag of a tagged-type entity.
6827
6828    May return NULL if we are unable to get the TSD.  */
6829
6830 static struct value *
6831 ada_get_tsd_from_tag (struct value *tag)
6832 {
6833   struct value *val;
6834   struct type *type;
6835
6836   /* First option: The TSD is simply stored as a field of our TAG.
6837      Only older versions of GNAT would use this format, but we have
6838      to test it first, because there are no visible markers for
6839      the current approach except the absence of that field.  */
6840
6841   val = ada_value_struct_elt (tag, "tsd", 1);
6842   if (val)
6843     return val;
6844
6845   /* Try the second representation for the dispatch table (in which
6846      there is no explicit 'tsd' field in the referent of the tag pointer,
6847      and instead the tsd pointer is stored just before the dispatch
6848      table.  */
6849
6850   type = ada_get_tsd_type (current_inferior());
6851   if (type == NULL)
6852     return NULL;
6853   type = lookup_pointer_type (lookup_pointer_type (type));
6854   val = value_cast (type, tag);
6855   if (val == NULL)
6856     return NULL;
6857   return value_ind (value_ptradd (val, -1));
6858 }
6859
6860 /* Given the TSD of a tag (type-specific data), return a string
6861    containing the name of the associated type.
6862
6863    The returned value is good until the next call.  May return NULL
6864    if we are unable to determine the tag name.  */
6865
6866 static char *
6867 ada_tag_name_from_tsd (struct value *tsd)
6868 {
6869   static char name[1024];
6870   char *p;
6871   struct value *val;
6872
6873   val = ada_value_struct_elt (tsd, "expanded_name", 1);
6874   if (val == NULL)
6875     return NULL;
6876   read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6877   for (p = name; *p != '\0'; p += 1)
6878     if (isalpha (*p))
6879       *p = tolower (*p);
6880   return name;
6881 }
6882
6883 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6884    a C string.
6885
6886    Return NULL if the TAG is not an Ada tag, or if we were unable to
6887    determine the name of that tag.  The result is good until the next
6888    call.  */
6889
6890 const char *
6891 ada_tag_name (struct value *tag)
6892 {
6893   char *name = NULL;
6894
6895   if (!ada_is_tag_type (value_type (tag)))
6896     return NULL;
6897
6898   /* It is perfectly possible that an exception be raised while trying
6899      to determine the TAG's name, even under normal circumstances:
6900      The associated variable may be uninitialized or corrupted, for
6901      instance. We do not let any exception propagate past this point.
6902      instead we return NULL.
6903
6904      We also do not print the error message either (which often is very
6905      low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6906      the caller print a more meaningful message if necessary.  */
6907   TRY
6908     {
6909       struct value *tsd = ada_get_tsd_from_tag (tag);
6910
6911       if (tsd != NULL)
6912         name = ada_tag_name_from_tsd (tsd);
6913     }
6914   CATCH (e, RETURN_MASK_ERROR)
6915     {
6916     }
6917   END_CATCH
6918
6919   return name;
6920 }
6921
6922 /* The parent type of TYPE, or NULL if none.  */
6923
6924 struct type *
6925 ada_parent_type (struct type *type)
6926 {
6927   int i;
6928
6929   type = ada_check_typedef (type);
6930
6931   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6932     return NULL;
6933
6934   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6935     if (ada_is_parent_field (type, i))
6936       {
6937         struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6938
6939         /* If the _parent field is a pointer, then dereference it.  */
6940         if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6941           parent_type = TYPE_TARGET_TYPE (parent_type);
6942         /* If there is a parallel XVS type, get the actual base type.  */
6943         parent_type = ada_get_base_type (parent_type);
6944
6945         return ada_check_typedef (parent_type);
6946       }
6947
6948   return NULL;
6949 }
6950
6951 /* True iff field number FIELD_NUM of structure type TYPE contains the
6952    parent-type (inherited) fields of a derived type.  Assumes TYPE is
6953    a structure type with at least FIELD_NUM+1 fields.  */
6954
6955 int
6956 ada_is_parent_field (struct type *type, int field_num)
6957 {
6958   const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
6959
6960   return (name != NULL
6961           && (startswith (name, "PARENT")
6962               || startswith (name, "_parent")));
6963 }
6964
6965 /* True iff field number FIELD_NUM of structure type TYPE is a
6966    transparent wrapper field (which should be silently traversed when doing
6967    field selection and flattened when printing).  Assumes TYPE is a
6968    structure type with at least FIELD_NUM+1 fields.  Such fields are always
6969    structures.  */
6970
6971 int
6972 ada_is_wrapper_field (struct type *type, int field_num)
6973 {
6974   const char *name = TYPE_FIELD_NAME (type, field_num);
6975
6976   if (name != NULL && strcmp (name, "RETVAL") == 0)
6977     {
6978       /* This happens in functions with "out" or "in out" parameters
6979          which are passed by copy.  For such functions, GNAT describes
6980          the function's return type as being a struct where the return
6981          value is in a field called RETVAL, and where the other "out"
6982          or "in out" parameters are fields of that struct.  This is not
6983          a wrapper.  */
6984       return 0;
6985     }
6986
6987   return (name != NULL
6988           && (startswith (name, "PARENT")
6989               || strcmp (name, "REP") == 0
6990               || startswith (name, "_parent")
6991               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6992 }
6993
6994 /* True iff field number FIELD_NUM of structure or union type TYPE
6995    is a variant wrapper.  Assumes TYPE is a structure type with at least
6996    FIELD_NUM+1 fields.  */
6997
6998 int
6999 ada_is_variant_part (struct type *type, int field_num)
7000 {
7001   struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
7002
7003   return (TYPE_CODE (field_type) == TYPE_CODE_UNION
7004           || (is_dynamic_field (type, field_num)
7005               && (TYPE_CODE (TYPE_TARGET_TYPE (field_type)) 
7006                   == TYPE_CODE_UNION)));
7007 }
7008
7009 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
7010    whose discriminants are contained in the record type OUTER_TYPE,
7011    returns the type of the controlling discriminant for the variant.
7012    May return NULL if the type could not be found.  */
7013
7014 struct type *
7015 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
7016 {
7017   const char *name = ada_variant_discrim_name (var_type);
7018
7019   return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
7020 }
7021
7022 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
7023    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
7024    represents a 'when others' clause; otherwise 0.  */
7025
7026 int
7027 ada_is_others_clause (struct type *type, int field_num)
7028 {
7029   const char *name = TYPE_FIELD_NAME (type, field_num);
7030
7031   return (name != NULL && name[0] == 'O');
7032 }
7033
7034 /* Assuming that TYPE0 is the type of the variant part of a record,
7035    returns the name of the discriminant controlling the variant.
7036    The value is valid until the next call to ada_variant_discrim_name.  */
7037
7038 const char *
7039 ada_variant_discrim_name (struct type *type0)
7040 {
7041   static char *result = NULL;
7042   static size_t result_len = 0;
7043   struct type *type;
7044   const char *name;
7045   const char *discrim_end;
7046   const char *discrim_start;
7047
7048   if (TYPE_CODE (type0) == TYPE_CODE_PTR)
7049     type = TYPE_TARGET_TYPE (type0);
7050   else
7051     type = type0;
7052
7053   name = ada_type_name (type);
7054
7055   if (name == NULL || name[0] == '\000')
7056     return "";
7057
7058   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7059        discrim_end -= 1)
7060     {
7061       if (startswith (discrim_end, "___XVN"))
7062         break;
7063     }
7064   if (discrim_end == name)
7065     return "";
7066
7067   for (discrim_start = discrim_end; discrim_start != name + 3;
7068        discrim_start -= 1)
7069     {
7070       if (discrim_start == name + 1)
7071         return "";
7072       if ((discrim_start > name + 3
7073            && startswith (discrim_start - 3, "___"))
7074           || discrim_start[-1] == '.')
7075         break;
7076     }
7077
7078   GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7079   strncpy (result, discrim_start, discrim_end - discrim_start);
7080   result[discrim_end - discrim_start] = '\0';
7081   return result;
7082 }
7083
7084 /* Scan STR for a subtype-encoded number, beginning at position K.
7085    Put the position of the character just past the number scanned in
7086    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
7087    Return 1 if there was a valid number at the given position, and 0
7088    otherwise.  A "subtype-encoded" number consists of the absolute value
7089    in decimal, followed by the letter 'm' to indicate a negative number.
7090    Assumes 0m does not occur.  */
7091
7092 int
7093 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
7094 {
7095   ULONGEST RU;
7096
7097   if (!isdigit (str[k]))
7098     return 0;
7099
7100   /* Do it the hard way so as not to make any assumption about
7101      the relationship of unsigned long (%lu scan format code) and
7102      LONGEST.  */
7103   RU = 0;
7104   while (isdigit (str[k]))
7105     {
7106       RU = RU * 10 + (str[k] - '0');
7107       k += 1;
7108     }
7109
7110   if (str[k] == 'm')
7111     {
7112       if (R != NULL)
7113         *R = (-(LONGEST) (RU - 1)) - 1;
7114       k += 1;
7115     }
7116   else if (R != NULL)
7117     *R = (LONGEST) RU;
7118
7119   /* NOTE on the above: Technically, C does not say what the results of
7120      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7121      number representable as a LONGEST (although either would probably work
7122      in most implementations).  When RU>0, the locution in the then branch
7123      above is always equivalent to the negative of RU.  */
7124
7125   if (new_k != NULL)
7126     *new_k = k;
7127   return 1;
7128 }
7129
7130 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7131    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7132    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
7133
7134 int
7135 ada_in_variant (LONGEST val, struct type *type, int field_num)
7136 {
7137   const char *name = TYPE_FIELD_NAME (type, field_num);
7138   int p;
7139
7140   p = 0;
7141   while (1)
7142     {
7143       switch (name[p])
7144         {
7145         case '\0':
7146           return 0;
7147         case 'S':
7148           {
7149             LONGEST W;
7150
7151             if (!ada_scan_number (name, p + 1, &W, &p))
7152               return 0;
7153             if (val == W)
7154               return 1;
7155             break;
7156           }
7157         case 'R':
7158           {
7159             LONGEST L, U;
7160
7161             if (!ada_scan_number (name, p + 1, &L, &p)
7162                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7163               return 0;
7164             if (val >= L && val <= U)
7165               return 1;
7166             break;
7167           }
7168         case 'O':
7169           return 1;
7170         default:
7171           return 0;
7172         }
7173     }
7174 }
7175
7176 /* FIXME: Lots of redundancy below.  Try to consolidate.  */
7177
7178 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7179    ARG_TYPE, extract and return the value of one of its (non-static)
7180    fields.  FIELDNO says which field.   Differs from value_primitive_field
7181    only in that it can handle packed values of arbitrary type.  */
7182
7183 static struct value *
7184 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
7185                            struct type *arg_type)
7186 {
7187   struct type *type;
7188
7189   arg_type = ada_check_typedef (arg_type);
7190   type = TYPE_FIELD_TYPE (arg_type, fieldno);
7191
7192   /* Handle packed fields.  */
7193
7194   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7195     {
7196       int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7197       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
7198
7199       return ada_value_primitive_packed_val (arg1, value_contents (arg1),
7200                                              offset + bit_pos / 8,
7201                                              bit_pos % 8, bit_size, type);
7202     }
7203   else
7204     return value_primitive_field (arg1, offset, fieldno, arg_type);
7205 }
7206
7207 /* Find field with name NAME in object of type TYPE.  If found, 
7208    set the following for each argument that is non-null:
7209     - *FIELD_TYPE_P to the field's type; 
7210     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 
7211       an object of that type;
7212     - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 
7213     - *BIT_SIZE_P to its size in bits if the field is packed, and 
7214       0 otherwise;
7215    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7216    fields up to but not including the desired field, or by the total
7217    number of fields if not found.   A NULL value of NAME never
7218    matches; the function just counts visible fields in this case.
7219    
7220    Notice that we need to handle when a tagged record hierarchy
7221    has some components with the same name, like in this scenario:
7222
7223       type Top_T is tagged record
7224          N : Integer := 1;
7225          U : Integer := 974;
7226          A : Integer := 48;
7227       end record;
7228
7229       type Middle_T is new Top.Top_T with record
7230          N : Character := 'a';
7231          C : Integer := 3;
7232       end record;
7233
7234      type Bottom_T is new Middle.Middle_T with record
7235         N : Float := 4.0;
7236         C : Character := '5';
7237         X : Integer := 6;
7238         A : Character := 'J';
7239      end record;
7240
7241    Let's say we now have a variable declared and initialized as follow:
7242
7243      TC : Top_A := new Bottom_T;
7244
7245    And then we use this variable to call this function
7246
7247      procedure Assign (Obj: in out Top_T; TV : Integer);
7248
7249    as follow:
7250
7251       Assign (Top_T (B), 12);
7252
7253    Now, we're in the debugger, and we're inside that procedure
7254    then and we want to print the value of obj.c:
7255
7256    Usually, the tagged record or one of the parent type owns the
7257    component to print and there's no issue but in this particular
7258    case, what does it mean to ask for Obj.C? Since the actual
7259    type for object is type Bottom_T, it could mean two things: type
7260    component C from the Middle_T view, but also component C from
7261    Bottom_T.  So in that "undefined" case, when the component is
7262    not found in the non-resolved type (which includes all the
7263    components of the parent type), then resolve it and see if we
7264    get better luck once expanded.
7265
7266    In the case of homonyms in the derived tagged type, we don't
7267    guaranty anything, and pick the one that's easiest for us
7268    to program.
7269
7270    Returns 1 if found, 0 otherwise.  */
7271
7272 static int
7273 find_struct_field (const char *name, struct type *type, int offset,
7274                    struct type **field_type_p,
7275                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7276                    int *index_p)
7277 {
7278   int i;
7279   int parent_offset = -1;
7280
7281   type = ada_check_typedef (type);
7282
7283   if (field_type_p != NULL)
7284     *field_type_p = NULL;
7285   if (byte_offset_p != NULL)
7286     *byte_offset_p = 0;
7287   if (bit_offset_p != NULL)
7288     *bit_offset_p = 0;
7289   if (bit_size_p != NULL)
7290     *bit_size_p = 0;
7291
7292   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7293     {
7294       int bit_pos = TYPE_FIELD_BITPOS (type, i);
7295       int fld_offset = offset + bit_pos / 8;
7296       const char *t_field_name = TYPE_FIELD_NAME (type, i);
7297
7298       if (t_field_name == NULL)
7299         continue;
7300
7301       else if (ada_is_parent_field (type, i))
7302         {
7303           /* This is a field pointing us to the parent type of a tagged
7304              type.  As hinted in this function's documentation, we give
7305              preference to fields in the current record first, so what
7306              we do here is just record the index of this field before
7307              we skip it.  If it turns out we couldn't find our field
7308              in the current record, then we'll get back to it and search
7309              inside it whether the field might exist in the parent.  */
7310
7311           parent_offset = i;
7312           continue;
7313         }
7314
7315       else if (name != NULL && field_name_match (t_field_name, name))
7316         {
7317           int bit_size = TYPE_FIELD_BITSIZE (type, i);
7318
7319           if (field_type_p != NULL)
7320             *field_type_p = TYPE_FIELD_TYPE (type, i);
7321           if (byte_offset_p != NULL)
7322             *byte_offset_p = fld_offset;
7323           if (bit_offset_p != NULL)
7324             *bit_offset_p = bit_pos % 8;
7325           if (bit_size_p != NULL)
7326             *bit_size_p = bit_size;
7327           return 1;
7328         }
7329       else if (ada_is_wrapper_field (type, i))
7330         {
7331           if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7332                                  field_type_p, byte_offset_p, bit_offset_p,
7333                                  bit_size_p, index_p))
7334             return 1;
7335         }
7336       else if (ada_is_variant_part (type, i))
7337         {
7338           /* PNH: Wait.  Do we ever execute this section, or is ARG always of 
7339              fixed type?? */
7340           int j;
7341           struct type *field_type
7342             = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
7343
7344           for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7345             {
7346               if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7347                                      fld_offset
7348                                      + TYPE_FIELD_BITPOS (field_type, j) / 8,
7349                                      field_type_p, byte_offset_p,
7350                                      bit_offset_p, bit_size_p, index_p))
7351                 return 1;
7352             }
7353         }
7354       else if (index_p != NULL)
7355         *index_p += 1;
7356     }
7357
7358   /* Field not found so far.  If this is a tagged type which
7359      has a parent, try finding that field in the parent now.  */
7360
7361   if (parent_offset != -1)
7362     {
7363       int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7364       int fld_offset = offset + bit_pos / 8;
7365
7366       if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7367                              fld_offset, field_type_p, byte_offset_p,
7368                              bit_offset_p, bit_size_p, index_p))
7369         return 1;
7370     }
7371
7372   return 0;
7373 }
7374
7375 /* Number of user-visible fields in record type TYPE.  */
7376
7377 static int
7378 num_visible_fields (struct type *type)
7379 {
7380   int n;
7381
7382   n = 0;
7383   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7384   return n;
7385 }
7386
7387 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
7388    and search in it assuming it has (class) type TYPE.
7389    If found, return value, else return NULL.
7390
7391    Searches recursively through wrapper fields (e.g., '_parent').
7392
7393    In the case of homonyms in the tagged types, please refer to the
7394    long explanation in find_struct_field's function documentation.  */
7395
7396 static struct value *
7397 ada_search_struct_field (const char *name, struct value *arg, int offset,
7398                          struct type *type)
7399 {
7400   int i;
7401   int parent_offset = -1;
7402
7403   type = ada_check_typedef (type);
7404   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7405     {
7406       const char *t_field_name = TYPE_FIELD_NAME (type, i);
7407
7408       if (t_field_name == NULL)
7409         continue;
7410
7411       else if (ada_is_parent_field (type, i))
7412         {
7413           /* This is a field pointing us to the parent type of a tagged
7414              type.  As hinted in this function's documentation, we give
7415              preference to fields in the current record first, so what
7416              we do here is just record the index of this field before
7417              we skip it.  If it turns out we couldn't find our field
7418              in the current record, then we'll get back to it and search
7419              inside it whether the field might exist in the parent.  */
7420
7421           parent_offset = i;
7422           continue;
7423         }
7424
7425       else if (field_name_match (t_field_name, name))
7426         return ada_value_primitive_field (arg, offset, i, type);
7427
7428       else if (ada_is_wrapper_field (type, i))
7429         {
7430           struct value *v =     /* Do not let indent join lines here.  */
7431             ada_search_struct_field (name, arg,
7432                                      offset + TYPE_FIELD_BITPOS (type, i) / 8,
7433                                      TYPE_FIELD_TYPE (type, i));
7434
7435           if (v != NULL)
7436             return v;
7437         }
7438
7439       else if (ada_is_variant_part (type, i))
7440         {
7441           /* PNH: Do we ever get here?  See find_struct_field.  */
7442           int j;
7443           struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7444                                                                         i));
7445           int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7446
7447           for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7448             {
7449               struct value *v = ada_search_struct_field /* Force line
7450                                                            break.  */
7451                 (name, arg,
7452                  var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7453                  TYPE_FIELD_TYPE (field_type, j));
7454
7455               if (v != NULL)
7456                 return v;
7457             }
7458         }
7459     }
7460
7461   /* Field not found so far.  If this is a tagged type which
7462      has a parent, try finding that field in the parent now.  */
7463
7464   if (parent_offset != -1)
7465     {
7466       struct value *v = ada_search_struct_field (
7467         name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7468         TYPE_FIELD_TYPE (type, parent_offset));
7469
7470       if (v != NULL)
7471         return v;
7472     }
7473
7474   return NULL;
7475 }
7476
7477 static struct value *ada_index_struct_field_1 (int *, struct value *,
7478                                                int, struct type *);
7479
7480
7481 /* Return field #INDEX in ARG, where the index is that returned by
7482  * find_struct_field through its INDEX_P argument.  Adjust the address
7483  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7484  * If found, return value, else return NULL.  */
7485
7486 static struct value *
7487 ada_index_struct_field (int index, struct value *arg, int offset,
7488                         struct type *type)
7489 {
7490   return ada_index_struct_field_1 (&index, arg, offset, type);
7491 }
7492
7493
7494 /* Auxiliary function for ada_index_struct_field.  Like
7495  * ada_index_struct_field, but takes index from *INDEX_P and modifies
7496  * *INDEX_P.  */
7497
7498 static struct value *
7499 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7500                           struct type *type)
7501 {
7502   int i;
7503   type = ada_check_typedef (type);
7504
7505   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7506     {
7507       if (TYPE_FIELD_NAME (type, i) == NULL)
7508         continue;
7509       else if (ada_is_wrapper_field (type, i))
7510         {
7511           struct value *v =     /* Do not let indent join lines here.  */
7512             ada_index_struct_field_1 (index_p, arg,
7513                                       offset + TYPE_FIELD_BITPOS (type, i) / 8,
7514                                       TYPE_FIELD_TYPE (type, i));
7515
7516           if (v != NULL)
7517             return v;
7518         }
7519
7520       else if (ada_is_variant_part (type, i))
7521         {
7522           /* PNH: Do we ever get here?  See ada_search_struct_field,
7523              find_struct_field.  */
7524           error (_("Cannot assign this kind of variant record"));
7525         }
7526       else if (*index_p == 0)
7527         return ada_value_primitive_field (arg, offset, i, type);
7528       else
7529         *index_p -= 1;
7530     }
7531   return NULL;
7532 }
7533
7534 /* Given ARG, a value of type (pointer or reference to a)*
7535    structure/union, extract the component named NAME from the ultimate
7536    target structure/union and return it as a value with its
7537    appropriate type.
7538
7539    The routine searches for NAME among all members of the structure itself
7540    and (recursively) among all members of any wrapper members
7541    (e.g., '_parent').
7542
7543    If NO_ERR, then simply return NULL in case of error, rather than 
7544    calling error.  */
7545
7546 struct value *
7547 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
7548 {
7549   struct type *t, *t1;
7550   struct value *v;
7551
7552   v = NULL;
7553   t1 = t = ada_check_typedef (value_type (arg));
7554   if (TYPE_CODE (t) == TYPE_CODE_REF)
7555     {
7556       t1 = TYPE_TARGET_TYPE (t);
7557       if (t1 == NULL)
7558         goto BadValue;
7559       t1 = ada_check_typedef (t1);
7560       if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7561         {
7562           arg = coerce_ref (arg);
7563           t = t1;
7564         }
7565     }
7566
7567   while (TYPE_CODE (t) == TYPE_CODE_PTR)
7568     {
7569       t1 = TYPE_TARGET_TYPE (t);
7570       if (t1 == NULL)
7571         goto BadValue;
7572       t1 = ada_check_typedef (t1);
7573       if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7574         {
7575           arg = value_ind (arg);
7576           t = t1;
7577         }
7578       else
7579         break;
7580     }
7581
7582   if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
7583     goto BadValue;
7584
7585   if (t1 == t)
7586     v = ada_search_struct_field (name, arg, 0, t);
7587   else
7588     {
7589       int bit_offset, bit_size, byte_offset;
7590       struct type *field_type;
7591       CORE_ADDR address;
7592
7593       if (TYPE_CODE (t) == TYPE_CODE_PTR)
7594         address = value_address (ada_value_ind (arg));
7595       else
7596         address = value_address (ada_coerce_ref (arg));
7597
7598       /* Check to see if this is a tagged type.  We also need to handle
7599          the case where the type is a reference to a tagged type, but
7600          we have to be careful to exclude pointers to tagged types.
7601          The latter should be shown as usual (as a pointer), whereas
7602          a reference should mostly be transparent to the user.  */
7603
7604       if (ada_is_tagged_type (t1, 0)
7605           || (TYPE_CODE (t1) == TYPE_CODE_REF
7606               && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
7607         {
7608           /* We first try to find the searched field in the current type.
7609              If not found then let's look in the fixed type.  */
7610
7611           if (!find_struct_field (name, t1, 0,
7612                                   &field_type, &byte_offset, &bit_offset,
7613                                   &bit_size, NULL))
7614             t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7615                                     address, NULL, 1);
7616         }
7617       else
7618         t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7619                                 address, NULL, 1);
7620
7621       if (find_struct_field (name, t1, 0,
7622                              &field_type, &byte_offset, &bit_offset,
7623                              &bit_size, NULL))
7624         {
7625           if (bit_size != 0)
7626             {
7627               if (TYPE_CODE (t) == TYPE_CODE_REF)
7628                 arg = ada_coerce_ref (arg);
7629               else
7630                 arg = ada_value_ind (arg);
7631               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7632                                                   bit_offset, bit_size,
7633                                                   field_type);
7634             }
7635           else
7636             v = value_at_lazy (field_type, address + byte_offset);
7637         }
7638     }
7639
7640   if (v != NULL || no_err)
7641     return v;
7642   else
7643     error (_("There is no member named %s."), name);
7644
7645  BadValue:
7646   if (no_err)
7647     return NULL;
7648   else
7649     error (_("Attempt to extract a component of "
7650              "a value that is not a record."));
7651 }
7652
7653 /* Return a string representation of type TYPE.  */
7654
7655 static std::string
7656 type_as_string (struct type *type)
7657 {
7658   string_file tmp_stream;
7659
7660   type_print (type, "", &tmp_stream, -1);
7661
7662   return std::move (tmp_stream.string ());
7663 }
7664
7665 /* Given a type TYPE, look up the type of the component of type named NAME.
7666    If DISPP is non-null, add its byte displacement from the beginning of a
7667    structure (pointed to by a value) of type TYPE to *DISPP (does not
7668    work for packed fields).
7669
7670    Matches any field whose name has NAME as a prefix, possibly
7671    followed by "___".
7672
7673    TYPE can be either a struct or union.  If REFOK, TYPE may also 
7674    be a (pointer or reference)+ to a struct or union, and the
7675    ultimate target type will be searched.
7676
7677    Looks recursively into variant clauses and parent types.
7678
7679    In the case of homonyms in the tagged types, please refer to the
7680    long explanation in find_struct_field's function documentation.
7681
7682    If NOERR is nonzero, return NULL if NAME is not suitably defined or
7683    TYPE is not a type of the right kind.  */
7684
7685 static struct type *
7686 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7687                             int noerr)
7688 {
7689   int i;
7690   int parent_offset = -1;
7691
7692   if (name == NULL)
7693     goto BadName;
7694
7695   if (refok && type != NULL)
7696     while (1)
7697       {
7698         type = ada_check_typedef (type);
7699         if (TYPE_CODE (type) != TYPE_CODE_PTR
7700             && TYPE_CODE (type) != TYPE_CODE_REF)
7701           break;
7702         type = TYPE_TARGET_TYPE (type);
7703       }
7704
7705   if (type == NULL
7706       || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7707           && TYPE_CODE (type) != TYPE_CODE_UNION))
7708     {
7709       if (noerr)
7710         return NULL;
7711
7712       error (_("Type %s is not a structure or union type"),
7713              type != NULL ? type_as_string (type).c_str () : _("(null)"));
7714     }
7715
7716   type = to_static_fixed_type (type);
7717
7718   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7719     {
7720       const char *t_field_name = TYPE_FIELD_NAME (type, i);
7721       struct type *t;
7722
7723       if (t_field_name == NULL)
7724         continue;
7725
7726       else if (ada_is_parent_field (type, i))
7727         {
7728           /* This is a field pointing us to the parent type of a tagged
7729              type.  As hinted in this function's documentation, we give
7730              preference to fields in the current record first, so what
7731              we do here is just record the index of this field before
7732              we skip it.  If it turns out we couldn't find our field
7733              in the current record, then we'll get back to it and search
7734              inside it whether the field might exist in the parent.  */
7735
7736           parent_offset = i;
7737           continue;
7738         }
7739
7740       else if (field_name_match (t_field_name, name))
7741         return TYPE_FIELD_TYPE (type, i);
7742
7743       else if (ada_is_wrapper_field (type, i))
7744         {
7745           t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7746                                           0, 1);
7747           if (t != NULL)
7748             return t;
7749         }
7750
7751       else if (ada_is_variant_part (type, i))
7752         {
7753           int j;
7754           struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7755                                                                         i));
7756
7757           for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7758             {
7759               /* FIXME pnh 2008/01/26: We check for a field that is
7760                  NOT wrapped in a struct, since the compiler sometimes
7761                  generates these for unchecked variant types.  Revisit
7762                  if the compiler changes this practice.  */
7763               const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
7764
7765               if (v_field_name != NULL 
7766                   && field_name_match (v_field_name, name))
7767                 t = TYPE_FIELD_TYPE (field_type, j);
7768               else
7769                 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7770                                                                  j),
7771                                                 name, 0, 1);
7772
7773               if (t != NULL)
7774                 return t;
7775             }
7776         }
7777
7778     }
7779
7780     /* Field not found so far.  If this is a tagged type which
7781        has a parent, try finding that field in the parent now.  */
7782
7783     if (parent_offset != -1)
7784       {
7785         struct type *t;
7786
7787         t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7788                                         name, 0, 1);
7789         if (t != NULL)
7790           return t;
7791       }
7792
7793 BadName:
7794   if (!noerr)
7795     {
7796       const char *name_str = name != NULL ? name : _("<null>");
7797
7798       error (_("Type %s has no component named %s"),
7799              type_as_string (type).c_str (), name_str);
7800     }
7801
7802   return NULL;
7803 }
7804
7805 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7806    within a value of type OUTER_TYPE, return true iff VAR_TYPE
7807    represents an unchecked union (that is, the variant part of a
7808    record that is named in an Unchecked_Union pragma).  */
7809
7810 static int
7811 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7812 {
7813   const char *discrim_name = ada_variant_discrim_name (var_type);
7814
7815   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7816 }
7817
7818
7819 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7820    within a value of type OUTER_TYPE that is stored in GDB at
7821    OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7822    numbering from 0) is applicable.  Returns -1 if none are.  */
7823
7824 int
7825 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
7826                            const gdb_byte *outer_valaddr)
7827 {
7828   int others_clause;
7829   int i;
7830   const char *discrim_name = ada_variant_discrim_name (var_type);
7831   struct value *outer;
7832   struct value *discrim;
7833   LONGEST discrim_val;
7834
7835   /* Using plain value_from_contents_and_address here causes problems
7836      because we will end up trying to resolve a type that is currently
7837      being constructed.  */
7838   outer = value_from_contents_and_address_unresolved (outer_type,
7839                                                       outer_valaddr, 0);
7840   discrim = ada_value_struct_elt (outer, discrim_name, 1);
7841   if (discrim == NULL)
7842     return -1;
7843   discrim_val = value_as_long (discrim);
7844
7845   others_clause = -1;
7846   for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7847     {
7848       if (ada_is_others_clause (var_type, i))
7849         others_clause = i;
7850       else if (ada_in_variant (discrim_val, var_type, i))
7851         return i;
7852     }
7853
7854   return others_clause;
7855 }
7856 \f
7857
7858
7859                                 /* Dynamic-Sized Records */
7860
7861 /* Strategy: The type ostensibly attached to a value with dynamic size
7862    (i.e., a size that is not statically recorded in the debugging
7863    data) does not accurately reflect the size or layout of the value.
7864    Our strategy is to convert these values to values with accurate,
7865    conventional types that are constructed on the fly.  */
7866
7867 /* There is a subtle and tricky problem here.  In general, we cannot
7868    determine the size of dynamic records without its data.  However,
7869    the 'struct value' data structure, which GDB uses to represent
7870    quantities in the inferior process (the target), requires the size
7871    of the type at the time of its allocation in order to reserve space
7872    for GDB's internal copy of the data.  That's why the
7873    'to_fixed_xxx_type' routines take (target) addresses as parameters,
7874    rather than struct value*s.
7875
7876    However, GDB's internal history variables ($1, $2, etc.) are
7877    struct value*s containing internal copies of the data that are not, in
7878    general, the same as the data at their corresponding addresses in
7879    the target.  Fortunately, the types we give to these values are all
7880    conventional, fixed-size types (as per the strategy described
7881    above), so that we don't usually have to perform the
7882    'to_fixed_xxx_type' conversions to look at their values.
7883    Unfortunately, there is one exception: if one of the internal
7884    history variables is an array whose elements are unconstrained
7885    records, then we will need to create distinct fixed types for each
7886    element selected.  */
7887
7888 /* The upshot of all of this is that many routines take a (type, host
7889    address, target address) triple as arguments to represent a value.
7890    The host address, if non-null, is supposed to contain an internal
7891    copy of the relevant data; otherwise, the program is to consult the
7892    target at the target address.  */
7893
7894 /* Assuming that VAL0 represents a pointer value, the result of
7895    dereferencing it.  Differs from value_ind in its treatment of
7896    dynamic-sized types.  */
7897
7898 struct value *
7899 ada_value_ind (struct value *val0)
7900 {
7901   struct value *val = value_ind (val0);
7902
7903   if (ada_is_tagged_type (value_type (val), 0))
7904     val = ada_tag_value_at_base_address (val);
7905
7906   return ada_to_fixed_value (val);
7907 }
7908
7909 /* The value resulting from dereferencing any "reference to"
7910    qualifiers on VAL0.  */
7911
7912 static struct value *
7913 ada_coerce_ref (struct value *val0)
7914 {
7915   if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
7916     {
7917       struct value *val = val0;
7918
7919       val = coerce_ref (val);
7920
7921       if (ada_is_tagged_type (value_type (val), 0))
7922         val = ada_tag_value_at_base_address (val);
7923
7924       return ada_to_fixed_value (val);
7925     }
7926   else
7927     return val0;
7928 }
7929
7930 /* Return OFF rounded upward if necessary to a multiple of
7931    ALIGNMENT (a power of 2).  */
7932
7933 static unsigned int
7934 align_value (unsigned int off, unsigned int alignment)
7935 {
7936   return (off + alignment - 1) & ~(alignment - 1);
7937 }
7938
7939 /* Return the bit alignment required for field #F of template type TYPE.  */
7940
7941 static unsigned int
7942 field_alignment (struct type *type, int f)
7943 {
7944   const char *name = TYPE_FIELD_NAME (type, f);
7945   int len;
7946   int align_offset;
7947
7948   /* The field name should never be null, unless the debugging information
7949      is somehow malformed.  In this case, we assume the field does not
7950      require any alignment.  */
7951   if (name == NULL)
7952     return 1;
7953
7954   len = strlen (name);
7955
7956   if (!isdigit (name[len - 1]))
7957     return 1;
7958
7959   if (isdigit (name[len - 2]))
7960     align_offset = len - 2;
7961   else
7962     align_offset = len - 1;
7963
7964   if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7965     return TARGET_CHAR_BIT;
7966
7967   return atoi (name + align_offset) * TARGET_CHAR_BIT;
7968 }
7969
7970 /* Find a typedef or tag symbol named NAME.  Ignores ambiguity.  */
7971
7972 static struct symbol *
7973 ada_find_any_type_symbol (const char *name)
7974 {
7975   struct symbol *sym;
7976
7977   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7978   if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7979     return sym;
7980
7981   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7982   return sym;
7983 }
7984
7985 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
7986    solely for types defined by debug info, it will not search the GDB
7987    primitive types.  */
7988
7989 static struct type *
7990 ada_find_any_type (const char *name)
7991 {
7992   struct symbol *sym = ada_find_any_type_symbol (name);
7993
7994   if (sym != NULL)
7995     return SYMBOL_TYPE (sym);
7996
7997   return NULL;
7998 }
7999
8000 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
8001    associated with NAME_SYM's name.  NAME_SYM may itself be a renaming
8002    symbol, in which case it is returned.  Otherwise, this looks for
8003    symbols whose name is that of NAME_SYM suffixed with  "___XR".
8004    Return symbol if found, and NULL otherwise.  */
8005
8006 struct symbol *
8007 ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
8008 {
8009   const char *name = SYMBOL_LINKAGE_NAME (name_sym);
8010   struct symbol *sym;
8011
8012   if (strstr (name, "___XR") != NULL)
8013      return name_sym;
8014
8015   sym = find_old_style_renaming_symbol (name, block);
8016
8017   if (sym != NULL)
8018     return sym;
8019
8020   /* Not right yet.  FIXME pnh 7/20/2007.  */
8021   sym = ada_find_any_type_symbol (name);
8022   if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
8023     return sym;
8024   else
8025     return NULL;
8026 }
8027
8028 static struct symbol *
8029 find_old_style_renaming_symbol (const char *name, const struct block *block)
8030 {
8031   const struct symbol *function_sym = block_linkage_function (block);
8032   char *rename;
8033
8034   if (function_sym != NULL)
8035     {
8036       /* If the symbol is defined inside a function, NAME is not fully
8037          qualified.  This means we need to prepend the function name
8038          as well as adding the ``___XR'' suffix to build the name of
8039          the associated renaming symbol.  */
8040       const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
8041       /* Function names sometimes contain suffixes used
8042          for instance to qualify nested subprograms.  When building
8043          the XR type name, we need to make sure that this suffix is
8044          not included.  So do not include any suffix in the function
8045          name length below.  */
8046       int function_name_len = ada_name_prefix_len (function_name);
8047       const int rename_len = function_name_len + 2      /*  "__" */
8048         + strlen (name) + 6 /* "___XR\0" */ ;
8049
8050       /* Strip the suffix if necessary.  */
8051       ada_remove_trailing_digits (function_name, &function_name_len);
8052       ada_remove_po_subprogram_suffix (function_name, &function_name_len);
8053       ada_remove_Xbn_suffix (function_name, &function_name_len);
8054
8055       /* Library-level functions are a special case, as GNAT adds
8056          a ``_ada_'' prefix to the function name to avoid namespace
8057          pollution.  However, the renaming symbols themselves do not
8058          have this prefix, so we need to skip this prefix if present.  */
8059       if (function_name_len > 5 /* "_ada_" */
8060           && strstr (function_name, "_ada_") == function_name)
8061         {
8062           function_name += 5;
8063           function_name_len -= 5;
8064         }
8065
8066       rename = (char *) alloca (rename_len * sizeof (char));
8067       strncpy (rename, function_name, function_name_len);
8068       xsnprintf (rename + function_name_len, rename_len - function_name_len,
8069                  "__%s___XR", name);
8070     }
8071   else
8072     {
8073       const int rename_len = strlen (name) + 6;
8074
8075       rename = (char *) alloca (rename_len * sizeof (char));
8076       xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
8077     }
8078
8079   return ada_find_any_type_symbol (rename);
8080 }
8081
8082 /* Because of GNAT encoding conventions, several GDB symbols may match a
8083    given type name.  If the type denoted by TYPE0 is to be preferred to
8084    that of TYPE1 for purposes of type printing, return non-zero;
8085    otherwise return 0.  */
8086
8087 int
8088 ada_prefer_type (struct type *type0, struct type *type1)
8089 {
8090   if (type1 == NULL)
8091     return 1;
8092   else if (type0 == NULL)
8093     return 0;
8094   else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
8095     return 1;
8096   else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
8097     return 0;
8098   else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
8099     return 1;
8100   else if (ada_is_constrained_packed_array_type (type0))
8101     return 1;
8102   else if (ada_is_array_descriptor_type (type0)
8103            && !ada_is_array_descriptor_type (type1))
8104     return 1;
8105   else
8106     {
8107       const char *type0_name = type_name_no_tag (type0);
8108       const char *type1_name = type_name_no_tag (type1);
8109
8110       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
8111           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
8112         return 1;
8113     }
8114   return 0;
8115 }
8116
8117 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
8118    null, its TYPE_TAG_NAME.  Null if TYPE is null.  */
8119
8120 const char *
8121 ada_type_name (struct type *type)
8122 {
8123   if (type == NULL)
8124     return NULL;
8125   else if (TYPE_NAME (type) != NULL)
8126     return TYPE_NAME (type);
8127   else
8128     return TYPE_TAG_NAME (type);
8129 }
8130
8131 /* Search the list of "descriptive" types associated to TYPE for a type
8132    whose name is NAME.  */
8133
8134 static struct type *
8135 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
8136 {
8137   struct type *result, *tmp;
8138
8139   if (ada_ignore_descriptive_types_p)
8140     return NULL;
8141
8142   /* If there no descriptive-type info, then there is no parallel type
8143      to be found.  */
8144   if (!HAVE_GNAT_AUX_INFO (type))
8145     return NULL;
8146
8147   result = TYPE_DESCRIPTIVE_TYPE (type);
8148   while (result != NULL)
8149     {
8150       const char *result_name = ada_type_name (result);
8151
8152       if (result_name == NULL)
8153         {
8154           warning (_("unexpected null name on descriptive type"));
8155           return NULL;
8156         }
8157
8158       /* If the names match, stop.  */
8159       if (strcmp (result_name, name) == 0)
8160         break;
8161
8162       /* Otherwise, look at the next item on the list, if any.  */
8163       if (HAVE_GNAT_AUX_INFO (result))
8164         tmp = TYPE_DESCRIPTIVE_TYPE (result);
8165       else
8166         tmp = NULL;
8167
8168       /* If not found either, try after having resolved the typedef.  */
8169       if (tmp != NULL)
8170         result = tmp;
8171       else
8172         {
8173           result = check_typedef (result);
8174           if (HAVE_GNAT_AUX_INFO (result))
8175             result = TYPE_DESCRIPTIVE_TYPE (result);
8176           else
8177             result = NULL;
8178         }
8179     }
8180
8181   /* If we didn't find a match, see whether this is a packed array.  With
8182      older compilers, the descriptive type information is either absent or
8183      irrelevant when it comes to packed arrays so the above lookup fails.
8184      Fall back to using a parallel lookup by name in this case.  */
8185   if (result == NULL && ada_is_constrained_packed_array_type (type))
8186     return ada_find_any_type (name);
8187
8188   return result;
8189 }
8190
8191 /* Find a parallel type to TYPE with the specified NAME, using the
8192    descriptive type taken from the debugging information, if available,
8193    and otherwise using the (slower) name-based method.  */
8194
8195 static struct type *
8196 ada_find_parallel_type_with_name (struct type *type, const char *name)
8197 {
8198   struct type *result = NULL;
8199
8200   if (HAVE_GNAT_AUX_INFO (type))
8201     result = find_parallel_type_by_descriptive_type (type, name);
8202   else
8203     result = ada_find_any_type (name);
8204
8205   return result;
8206 }
8207
8208 /* Same as above, but specify the name of the parallel type by appending
8209    SUFFIX to the name of TYPE.  */
8210
8211 struct type *
8212 ada_find_parallel_type (struct type *type, const char *suffix)
8213 {
8214   char *name;
8215   const char *type_name = ada_type_name (type);
8216   int len;
8217
8218   if (type_name == NULL)
8219     return NULL;
8220
8221   len = strlen (type_name);
8222
8223   name = (char *) alloca (len + strlen (suffix) + 1);
8224
8225   strcpy (name, type_name);
8226   strcpy (name + len, suffix);
8227
8228   return ada_find_parallel_type_with_name (type, name);
8229 }
8230
8231 /* If TYPE is a variable-size record type, return the corresponding template
8232    type describing its fields.  Otherwise, return NULL.  */
8233
8234 static struct type *
8235 dynamic_template_type (struct type *type)
8236 {
8237   type = ada_check_typedef (type);
8238
8239   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
8240       || ada_type_name (type) == NULL)
8241     return NULL;
8242   else
8243     {
8244       int len = strlen (ada_type_name (type));
8245
8246       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8247         return type;
8248       else
8249         return ada_find_parallel_type (type, "___XVE");
8250     }
8251 }
8252
8253 /* Assuming that TEMPL_TYPE is a union or struct type, returns
8254    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
8255
8256 static int
8257 is_dynamic_field (struct type *templ_type, int field_num)
8258 {
8259   const char *name = TYPE_FIELD_NAME (templ_type, field_num);
8260
8261   return name != NULL
8262     && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8263     && strstr (name, "___XVL") != NULL;
8264 }
8265
8266 /* The index of the variant field of TYPE, or -1 if TYPE does not
8267    represent a variant record type.  */
8268
8269 static int
8270 variant_field_index (struct type *type)
8271 {
8272   int f;
8273
8274   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8275     return -1;
8276
8277   for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8278     {
8279       if (ada_is_variant_part (type, f))
8280         return f;
8281     }
8282   return -1;
8283 }
8284
8285 /* A record type with no fields.  */
8286
8287 static struct type *
8288 empty_record (struct type *templ)
8289 {
8290   struct type *type = alloc_type_copy (templ);
8291
8292   TYPE_CODE (type) = TYPE_CODE_STRUCT;
8293   TYPE_NFIELDS (type) = 0;
8294   TYPE_FIELDS (type) = NULL;
8295   INIT_CPLUS_SPECIFIC (type);
8296   TYPE_NAME (type) = "<empty>";
8297   TYPE_TAG_NAME (type) = NULL;
8298   TYPE_LENGTH (type) = 0;
8299   return type;
8300 }
8301
8302 /* An ordinary record type (with fixed-length fields) that describes
8303    the value of type TYPE at VALADDR or ADDRESS (see comments at
8304    the beginning of this section) VAL according to GNAT conventions.
8305    DVAL0 should describe the (portion of a) record that contains any
8306    necessary discriminants.  It should be NULL if value_type (VAL) is
8307    an outer-level type (i.e., as opposed to a branch of a variant.)  A
8308    variant field (unless unchecked) is replaced by a particular branch
8309    of the variant.
8310
8311    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8312    length are not statically known are discarded.  As a consequence,
8313    VALADDR, ADDRESS and DVAL0 are ignored.
8314
8315    NOTE: Limitations: For now, we assume that dynamic fields and
8316    variants occupy whole numbers of bytes.  However, they need not be
8317    byte-aligned.  */
8318
8319 struct type *
8320 ada_template_to_fixed_record_type_1 (struct type *type,
8321                                      const gdb_byte *valaddr,
8322                                      CORE_ADDR address, struct value *dval0,
8323                                      int keep_dynamic_fields)
8324 {
8325   struct value *mark = value_mark ();
8326   struct value *dval;
8327   struct type *rtype;
8328   int nfields, bit_len;
8329   int variant_field;
8330   long off;
8331   int fld_bit_len;
8332   int f;
8333
8334   /* Compute the number of fields in this record type that are going
8335      to be processed: unless keep_dynamic_fields, this includes only
8336      fields whose position and length are static will be processed.  */
8337   if (keep_dynamic_fields)
8338     nfields = TYPE_NFIELDS (type);
8339   else
8340     {
8341       nfields = 0;
8342       while (nfields < TYPE_NFIELDS (type)
8343              && !ada_is_variant_part (type, nfields)
8344              && !is_dynamic_field (type, nfields))
8345         nfields++;
8346     }
8347
8348   rtype = alloc_type_copy (type);
8349   TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8350   INIT_CPLUS_SPECIFIC (rtype);
8351   TYPE_NFIELDS (rtype) = nfields;
8352   TYPE_FIELDS (rtype) = (struct field *)
8353     TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8354   memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8355   TYPE_NAME (rtype) = ada_type_name (type);
8356   TYPE_TAG_NAME (rtype) = NULL;
8357   TYPE_FIXED_INSTANCE (rtype) = 1;
8358
8359   off = 0;
8360   bit_len = 0;
8361   variant_field = -1;
8362
8363   for (f = 0; f < nfields; f += 1)
8364     {
8365       off = align_value (off, field_alignment (type, f))
8366         + TYPE_FIELD_BITPOS (type, f);
8367       SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
8368       TYPE_FIELD_BITSIZE (rtype, f) = 0;
8369
8370       if (ada_is_variant_part (type, f))
8371         {
8372           variant_field = f;
8373           fld_bit_len = 0;
8374         }
8375       else if (is_dynamic_field (type, f))
8376         {
8377           const gdb_byte *field_valaddr = valaddr;
8378           CORE_ADDR field_address = address;
8379           struct type *field_type =
8380             TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8381
8382           if (dval0 == NULL)
8383             {
8384               /* rtype's length is computed based on the run-time
8385                  value of discriminants.  If the discriminants are not
8386                  initialized, the type size may be completely bogus and
8387                  GDB may fail to allocate a value for it.  So check the
8388                  size first before creating the value.  */
8389               ada_ensure_varsize_limit (rtype);
8390               /* Using plain value_from_contents_and_address here
8391                  causes problems because we will end up trying to
8392                  resolve a type that is currently being
8393                  constructed.  */
8394               dval = value_from_contents_and_address_unresolved (rtype,
8395                                                                  valaddr,
8396                                                                  address);
8397               rtype = value_type (dval);
8398             }
8399           else
8400             dval = dval0;
8401
8402           /* If the type referenced by this field is an aligner type, we need
8403              to unwrap that aligner type, because its size might not be set.
8404              Keeping the aligner type would cause us to compute the wrong
8405              size for this field, impacting the offset of the all the fields
8406              that follow this one.  */
8407           if (ada_is_aligner_type (field_type))
8408             {
8409               long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8410
8411               field_valaddr = cond_offset_host (field_valaddr, field_offset);
8412               field_address = cond_offset_target (field_address, field_offset);
8413               field_type = ada_aligned_type (field_type);
8414             }
8415
8416           field_valaddr = cond_offset_host (field_valaddr,
8417                                             off / TARGET_CHAR_BIT);
8418           field_address = cond_offset_target (field_address,
8419                                               off / TARGET_CHAR_BIT);
8420
8421           /* Get the fixed type of the field.  Note that, in this case,
8422              we do not want to get the real type out of the tag: if
8423              the current field is the parent part of a tagged record,
8424              we will get the tag of the object.  Clearly wrong: the real
8425              type of the parent is not the real type of the child.  We
8426              would end up in an infinite loop.  */
8427           field_type = ada_get_base_type (field_type);
8428           field_type = ada_to_fixed_type (field_type, field_valaddr,
8429                                           field_address, dval, 0);
8430           /* If the field size is already larger than the maximum
8431              object size, then the record itself will necessarily
8432              be larger than the maximum object size.  We need to make
8433              this check now, because the size might be so ridiculously
8434              large (due to an uninitialized variable in the inferior)
8435              that it would cause an overflow when adding it to the
8436              record size.  */
8437           ada_ensure_varsize_limit (field_type);
8438
8439           TYPE_FIELD_TYPE (rtype, f) = field_type;
8440           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8441           /* The multiplication can potentially overflow.  But because
8442              the field length has been size-checked just above, and
8443              assuming that the maximum size is a reasonable value,
8444              an overflow should not happen in practice.  So rather than
8445              adding overflow recovery code to this already complex code,
8446              we just assume that it's not going to happen.  */
8447           fld_bit_len =
8448             TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8449         }
8450       else
8451         {
8452           /* Note: If this field's type is a typedef, it is important
8453              to preserve the typedef layer.
8454
8455              Otherwise, we might be transforming a typedef to a fat
8456              pointer (encoding a pointer to an unconstrained array),
8457              into a basic fat pointer (encoding an unconstrained
8458              array).  As both types are implemented using the same
8459              structure, the typedef is the only clue which allows us
8460              to distinguish between the two options.  Stripping it
8461              would prevent us from printing this field appropriately.  */
8462           TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
8463           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8464           if (TYPE_FIELD_BITSIZE (type, f) > 0)
8465             fld_bit_len =
8466               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8467           else
8468             {
8469               struct type *field_type = TYPE_FIELD_TYPE (type, f);
8470
8471               /* We need to be careful of typedefs when computing
8472                  the length of our field.  If this is a typedef,
8473                  get the length of the target type, not the length
8474                  of the typedef.  */
8475               if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8476                 field_type = ada_typedef_target_type (field_type);
8477
8478               fld_bit_len =
8479                 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8480             }
8481         }
8482       if (off + fld_bit_len > bit_len)
8483         bit_len = off + fld_bit_len;
8484       off += fld_bit_len;
8485       TYPE_LENGTH (rtype) =
8486         align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8487     }
8488
8489   /* We handle the variant part, if any, at the end because of certain
8490      odd cases in which it is re-ordered so as NOT to be the last field of
8491      the record.  This can happen in the presence of representation
8492      clauses.  */
8493   if (variant_field >= 0)
8494     {
8495       struct type *branch_type;
8496
8497       off = TYPE_FIELD_BITPOS (rtype, variant_field);
8498
8499       if (dval0 == NULL)
8500         {
8501           /* Using plain value_from_contents_and_address here causes
8502              problems because we will end up trying to resolve a type
8503              that is currently being constructed.  */
8504           dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8505                                                              address);
8506           rtype = value_type (dval);
8507         }
8508       else
8509         dval = dval0;
8510
8511       branch_type =
8512         to_fixed_variant_branch_type
8513         (TYPE_FIELD_TYPE (type, variant_field),
8514          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8515          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8516       if (branch_type == NULL)
8517         {
8518           for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8519             TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8520           TYPE_NFIELDS (rtype) -= 1;
8521         }
8522       else
8523         {
8524           TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8525           TYPE_FIELD_NAME (rtype, variant_field) = "S";
8526           fld_bit_len =
8527             TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8528             TARGET_CHAR_BIT;
8529           if (off + fld_bit_len > bit_len)
8530             bit_len = off + fld_bit_len;
8531           TYPE_LENGTH (rtype) =
8532             align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8533         }
8534     }
8535
8536   /* According to exp_dbug.ads, the size of TYPE for variable-size records
8537      should contain the alignment of that record, which should be a strictly
8538      positive value.  If null or negative, then something is wrong, most
8539      probably in the debug info.  In that case, we don't round up the size
8540      of the resulting type.  If this record is not part of another structure,
8541      the current RTYPE length might be good enough for our purposes.  */
8542   if (TYPE_LENGTH (type) <= 0)
8543     {
8544       if (TYPE_NAME (rtype))
8545         warning (_("Invalid type size for `%s' detected: %d."),
8546                  TYPE_NAME (rtype), TYPE_LENGTH (type));
8547       else
8548         warning (_("Invalid type size for <unnamed> detected: %d."),
8549                  TYPE_LENGTH (type));
8550     }
8551   else
8552     {
8553       TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8554                                          TYPE_LENGTH (type));
8555     }
8556
8557   value_free_to_mark (mark);
8558   if (TYPE_LENGTH (rtype) > varsize_limit)
8559     error (_("record type with dynamic size is larger than varsize-limit"));
8560   return rtype;
8561 }
8562
8563 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8564    of 1.  */
8565
8566 static struct type *
8567 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8568                                CORE_ADDR address, struct value *dval0)
8569 {
8570   return ada_template_to_fixed_record_type_1 (type, valaddr,
8571                                               address, dval0, 1);
8572 }
8573
8574 /* An ordinary record type in which ___XVL-convention fields and
8575    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8576    static approximations, containing all possible fields.  Uses
8577    no runtime values.  Useless for use in values, but that's OK,
8578    since the results are used only for type determinations.   Works on both
8579    structs and unions.  Representation note: to save space, we memorize
8580    the result of this function in the TYPE_TARGET_TYPE of the
8581    template type.  */
8582
8583 static struct type *
8584 template_to_static_fixed_type (struct type *type0)
8585 {
8586   struct type *type;
8587   int nfields;
8588   int f;
8589
8590   /* No need no do anything if the input type is already fixed.  */
8591   if (TYPE_FIXED_INSTANCE (type0))
8592     return type0;
8593
8594   /* Likewise if we already have computed the static approximation.  */
8595   if (TYPE_TARGET_TYPE (type0) != NULL)
8596     return TYPE_TARGET_TYPE (type0);
8597
8598   /* Don't clone TYPE0 until we are sure we are going to need a copy.  */
8599   type = type0;
8600   nfields = TYPE_NFIELDS (type0);
8601
8602   /* Whether or not we cloned TYPE0, cache the result so that we don't do
8603      recompute all over next time.  */
8604   TYPE_TARGET_TYPE (type0) = type;
8605
8606   for (f = 0; f < nfields; f += 1)
8607     {
8608       struct type *field_type = TYPE_FIELD_TYPE (type0, f);
8609       struct type *new_type;
8610
8611       if (is_dynamic_field (type0, f))
8612         {
8613           field_type = ada_check_typedef (field_type);
8614           new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8615         }
8616       else
8617         new_type = static_unwrap_type (field_type);
8618
8619       if (new_type != field_type)
8620         {
8621           /* Clone TYPE0 only the first time we get a new field type.  */
8622           if (type == type0)
8623             {
8624               TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8625               TYPE_CODE (type) = TYPE_CODE (type0);
8626               INIT_CPLUS_SPECIFIC (type);
8627               TYPE_NFIELDS (type) = nfields;
8628               TYPE_FIELDS (type) = (struct field *)
8629                 TYPE_ALLOC (type, nfields * sizeof (struct field));
8630               memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8631                       sizeof (struct field) * nfields);
8632               TYPE_NAME (type) = ada_type_name (type0);
8633               TYPE_TAG_NAME (type) = NULL;
8634               TYPE_FIXED_INSTANCE (type) = 1;
8635               TYPE_LENGTH (type) = 0;
8636             }
8637           TYPE_FIELD_TYPE (type, f) = new_type;
8638           TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8639         }
8640     }
8641
8642   return type;
8643 }
8644
8645 /* Given an object of type TYPE whose contents are at VALADDR and
8646    whose address in memory is ADDRESS, returns a revision of TYPE,
8647    which should be a non-dynamic-sized record, in which the variant
8648    part, if any, is replaced with the appropriate branch.  Looks
8649    for discriminant values in DVAL0, which can be NULL if the record
8650    contains the necessary discriminant values.  */
8651
8652 static struct type *
8653 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8654                                    CORE_ADDR address, struct value *dval0)
8655 {
8656   struct value *mark = value_mark ();
8657   struct value *dval;
8658   struct type *rtype;
8659   struct type *branch_type;
8660   int nfields = TYPE_NFIELDS (type);
8661   int variant_field = variant_field_index (type);
8662
8663   if (variant_field == -1)
8664     return type;
8665
8666   if (dval0 == NULL)
8667     {
8668       dval = value_from_contents_and_address (type, valaddr, address);
8669       type = value_type (dval);
8670     }
8671   else
8672     dval = dval0;
8673
8674   rtype = alloc_type_copy (type);
8675   TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8676   INIT_CPLUS_SPECIFIC (rtype);
8677   TYPE_NFIELDS (rtype) = nfields;
8678   TYPE_FIELDS (rtype) =
8679     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8680   memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
8681           sizeof (struct field) * nfields);
8682   TYPE_NAME (rtype) = ada_type_name (type);
8683   TYPE_TAG_NAME (rtype) = NULL;
8684   TYPE_FIXED_INSTANCE (rtype) = 1;
8685   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8686
8687   branch_type = to_fixed_variant_branch_type
8688     (TYPE_FIELD_TYPE (type, variant_field),
8689      cond_offset_host (valaddr,
8690                        TYPE_FIELD_BITPOS (type, variant_field)
8691                        / TARGET_CHAR_BIT),
8692      cond_offset_target (address,
8693                          TYPE_FIELD_BITPOS (type, variant_field)
8694                          / TARGET_CHAR_BIT), dval);
8695   if (branch_type == NULL)
8696     {
8697       int f;
8698
8699       for (f = variant_field + 1; f < nfields; f += 1)
8700         TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8701       TYPE_NFIELDS (rtype) -= 1;
8702     }
8703   else
8704     {
8705       TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8706       TYPE_FIELD_NAME (rtype, variant_field) = "S";
8707       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8708       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8709     }
8710   TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
8711
8712   value_free_to_mark (mark);
8713   return rtype;
8714 }
8715
8716 /* An ordinary record type (with fixed-length fields) that describes
8717    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8718    beginning of this section].   Any necessary discriminants' values
8719    should be in DVAL, a record value; it may be NULL if the object
8720    at ADDR itself contains any necessary discriminant values.
8721    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8722    values from the record are needed.  Except in the case that DVAL,
8723    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8724    unchecked) is replaced by a particular branch of the variant.
8725
8726    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8727    is questionable and may be removed.  It can arise during the
8728    processing of an unconstrained-array-of-record type where all the
8729    variant branches have exactly the same size.  This is because in
8730    such cases, the compiler does not bother to use the XVS convention
8731    when encoding the record.  I am currently dubious of this
8732    shortcut and suspect the compiler should be altered.  FIXME.  */
8733
8734 static struct type *
8735 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8736                       CORE_ADDR address, struct value *dval)
8737 {
8738   struct type *templ_type;
8739
8740   if (TYPE_FIXED_INSTANCE (type0))
8741     return type0;
8742
8743   templ_type = dynamic_template_type (type0);
8744
8745   if (templ_type != NULL)
8746     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8747   else if (variant_field_index (type0) >= 0)
8748     {
8749       if (dval == NULL && valaddr == NULL && address == 0)
8750         return type0;
8751       return to_record_with_fixed_variant_part (type0, valaddr, address,
8752                                                 dval);
8753     }
8754   else
8755     {
8756       TYPE_FIXED_INSTANCE (type0) = 1;
8757       return type0;
8758     }
8759
8760 }
8761
8762 /* An ordinary record type (with fixed-length fields) that describes
8763    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8764    union type.  Any necessary discriminants' values should be in DVAL,
8765    a record value.  That is, this routine selects the appropriate
8766    branch of the union at ADDR according to the discriminant value
8767    indicated in the union's type name.  Returns VAR_TYPE0 itself if
8768    it represents a variant subject to a pragma Unchecked_Union.  */
8769
8770 static struct type *
8771 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8772                               CORE_ADDR address, struct value *dval)
8773 {
8774   int which;
8775   struct type *templ_type;
8776   struct type *var_type;
8777
8778   if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8779     var_type = TYPE_TARGET_TYPE (var_type0);
8780   else
8781     var_type = var_type0;
8782
8783   templ_type = ada_find_parallel_type (var_type, "___XVU");
8784
8785   if (templ_type != NULL)
8786     var_type = templ_type;
8787
8788   if (is_unchecked_variant (var_type, value_type (dval)))
8789       return var_type0;
8790   which =
8791     ada_which_variant_applies (var_type,
8792                                value_type (dval), value_contents (dval));
8793
8794   if (which < 0)
8795     return empty_record (var_type);
8796   else if (is_dynamic_field (var_type, which))
8797     return to_fixed_record_type
8798       (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8799        valaddr, address, dval);
8800   else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
8801     return
8802       to_fixed_record_type
8803       (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
8804   else
8805     return TYPE_FIELD_TYPE (var_type, which);
8806 }
8807
8808 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8809    ENCODING_TYPE, a type following the GNAT conventions for discrete
8810    type encodings, only carries redundant information.  */
8811
8812 static int
8813 ada_is_redundant_range_encoding (struct type *range_type,
8814                                  struct type *encoding_type)
8815 {
8816   const char *bounds_str;
8817   int n;
8818   LONGEST lo, hi;
8819
8820   gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8821
8822   if (TYPE_CODE (get_base_type (range_type))
8823       != TYPE_CODE (get_base_type (encoding_type)))
8824     {
8825       /* The compiler probably used a simple base type to describe
8826          the range type instead of the range's actual base type,
8827          expecting us to get the real base type from the encoding
8828          anyway.  In this situation, the encoding cannot be ignored
8829          as redundant.  */
8830       return 0;
8831     }
8832
8833   if (is_dynamic_type (range_type))
8834     return 0;
8835
8836   if (TYPE_NAME (encoding_type) == NULL)
8837     return 0;
8838
8839   bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8840   if (bounds_str == NULL)
8841     return 0;
8842
8843   n = 8; /* Skip "___XDLU_".  */
8844   if (!ada_scan_number (bounds_str, n, &lo, &n))
8845     return 0;
8846   if (TYPE_LOW_BOUND (range_type) != lo)
8847     return 0;
8848
8849   n += 2; /* Skip the "__" separator between the two bounds.  */
8850   if (!ada_scan_number (bounds_str, n, &hi, &n))
8851     return 0;
8852   if (TYPE_HIGH_BOUND (range_type) != hi)
8853     return 0;
8854
8855   return 1;
8856 }
8857
8858 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8859    a type following the GNAT encoding for describing array type
8860    indices, only carries redundant information.  */
8861
8862 static int
8863 ada_is_redundant_index_type_desc (struct type *array_type,
8864                                   struct type *desc_type)
8865 {
8866   struct type *this_layer = check_typedef (array_type);
8867   int i;
8868
8869   for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8870     {
8871       if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8872                                             TYPE_FIELD_TYPE (desc_type, i)))
8873         return 0;
8874       this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8875     }
8876
8877   return 1;
8878 }
8879
8880 /* Assuming that TYPE0 is an array type describing the type of a value
8881    at ADDR, and that DVAL describes a record containing any
8882    discriminants used in TYPE0, returns a type for the value that
8883    contains no dynamic components (that is, no components whose sizes
8884    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
8885    true, gives an error message if the resulting type's size is over
8886    varsize_limit.  */
8887
8888 static struct type *
8889 to_fixed_array_type (struct type *type0, struct value *dval,
8890                      int ignore_too_big)
8891 {
8892   struct type *index_type_desc;
8893   struct type *result;
8894   int constrained_packed_array_p;
8895   static const char *xa_suffix = "___XA";
8896
8897   type0 = ada_check_typedef (type0);
8898   if (TYPE_FIXED_INSTANCE (type0))
8899     return type0;
8900
8901   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8902   if (constrained_packed_array_p)
8903     type0 = decode_constrained_packed_array_type (type0);
8904
8905   index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8906
8907   /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8908      encoding suffixed with 'P' may still be generated.  If so,
8909      it should be used to find the XA type.  */
8910
8911   if (index_type_desc == NULL)
8912     {
8913       const char *type_name = ada_type_name (type0);
8914
8915       if (type_name != NULL)
8916         {
8917           const int len = strlen (type_name);
8918           char *name = (char *) alloca (len + strlen (xa_suffix));
8919
8920           if (type_name[len - 1] == 'P')
8921             {
8922               strcpy (name, type_name);
8923               strcpy (name + len - 1, xa_suffix);
8924               index_type_desc = ada_find_parallel_type_with_name (type0, name);
8925             }
8926         }
8927     }
8928
8929   ada_fixup_array_indexes_type (index_type_desc);
8930   if (index_type_desc != NULL
8931       && ada_is_redundant_index_type_desc (type0, index_type_desc))
8932     {
8933       /* Ignore this ___XA parallel type, as it does not bring any
8934          useful information.  This allows us to avoid creating fixed
8935          versions of the array's index types, which would be identical
8936          to the original ones.  This, in turn, can also help avoid
8937          the creation of fixed versions of the array itself.  */
8938       index_type_desc = NULL;
8939     }
8940
8941   if (index_type_desc == NULL)
8942     {
8943       struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8944
8945       /* NOTE: elt_type---the fixed version of elt_type0---should never
8946          depend on the contents of the array in properly constructed
8947          debugging data.  */
8948       /* Create a fixed version of the array element type.
8949          We're not providing the address of an element here,
8950          and thus the actual object value cannot be inspected to do
8951          the conversion.  This should not be a problem, since arrays of
8952          unconstrained objects are not allowed.  In particular, all
8953          the elements of an array of a tagged type should all be of
8954          the same type specified in the debugging info.  No need to
8955          consult the object tag.  */
8956       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8957
8958       /* Make sure we always create a new array type when dealing with
8959          packed array types, since we're going to fix-up the array
8960          type length and element bitsize a little further down.  */
8961       if (elt_type0 == elt_type && !constrained_packed_array_p)
8962         result = type0;
8963       else
8964         result = create_array_type (alloc_type_copy (type0),
8965                                     elt_type, TYPE_INDEX_TYPE (type0));
8966     }
8967   else
8968     {
8969       int i;
8970       struct type *elt_type0;
8971
8972       elt_type0 = type0;
8973       for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
8974         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8975
8976       /* NOTE: result---the fixed version of elt_type0---should never
8977          depend on the contents of the array in properly constructed
8978          debugging data.  */
8979       /* Create a fixed version of the array element type.
8980          We're not providing the address of an element here,
8981          and thus the actual object value cannot be inspected to do
8982          the conversion.  This should not be a problem, since arrays of
8983          unconstrained objects are not allowed.  In particular, all
8984          the elements of an array of a tagged type should all be of
8985          the same type specified in the debugging info.  No need to
8986          consult the object tag.  */
8987       result =
8988         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8989
8990       elt_type0 = type0;
8991       for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
8992         {
8993           struct type *range_type =
8994             to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
8995
8996           result = create_array_type (alloc_type_copy (elt_type0),
8997                                       result, range_type);
8998           elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8999         }
9000       if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
9001         error (_("array type with dynamic size is larger than varsize-limit"));
9002     }
9003
9004   /* We want to preserve the type name.  This can be useful when
9005      trying to get the type name of a value that has already been
9006      printed (for instance, if the user did "print VAR; whatis $".  */
9007   TYPE_NAME (result) = TYPE_NAME (type0);
9008
9009   if (constrained_packed_array_p)
9010     {
9011       /* So far, the resulting type has been created as if the original
9012          type was a regular (non-packed) array type.  As a result, the
9013          bitsize of the array elements needs to be set again, and the array
9014          length needs to be recomputed based on that bitsize.  */
9015       int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
9016       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
9017
9018       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
9019       TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
9020       if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
9021         TYPE_LENGTH (result)++;
9022     }
9023
9024   TYPE_FIXED_INSTANCE (result) = 1;
9025   return result;
9026 }
9027
9028
9029 /* A standard type (containing no dynamically sized components)
9030    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
9031    DVAL describes a record containing any discriminants used in TYPE0,
9032    and may be NULL if there are none, or if the object of type TYPE at
9033    ADDRESS or in VALADDR contains these discriminants.
9034    
9035    If CHECK_TAG is not null, in the case of tagged types, this function
9036    attempts to locate the object's tag and use it to compute the actual
9037    type.  However, when ADDRESS is null, we cannot use it to determine the
9038    location of the tag, and therefore compute the tagged type's actual type.
9039    So we return the tagged type without consulting the tag.  */
9040    
9041 static struct type *
9042 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
9043                    CORE_ADDR address, struct value *dval, int check_tag)
9044 {
9045   type = ada_check_typedef (type);
9046   switch (TYPE_CODE (type))
9047     {
9048     default:
9049       return type;
9050     case TYPE_CODE_STRUCT:
9051       {
9052         struct type *static_type = to_static_fixed_type (type);
9053         struct type *fixed_record_type =
9054           to_fixed_record_type (type, valaddr, address, NULL);
9055
9056         /* If STATIC_TYPE is a tagged type and we know the object's address,
9057            then we can determine its tag, and compute the object's actual
9058            type from there.  Note that we have to use the fixed record
9059            type (the parent part of the record may have dynamic fields
9060            and the way the location of _tag is expressed may depend on
9061            them).  */
9062
9063         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
9064           {
9065             struct value *tag =
9066               value_tag_from_contents_and_address
9067               (fixed_record_type,
9068                valaddr,
9069                address);
9070             struct type *real_type = type_from_tag (tag);
9071             struct value *obj =
9072               value_from_contents_and_address (fixed_record_type,
9073                                                valaddr,
9074                                                address);
9075             fixed_record_type = value_type (obj);
9076             if (real_type != NULL)
9077               return to_fixed_record_type
9078                 (real_type, NULL,
9079                  value_address (ada_tag_value_at_base_address (obj)), NULL);
9080           }
9081
9082         /* Check to see if there is a parallel ___XVZ variable.
9083            If there is, then it provides the actual size of our type.  */
9084         else if (ada_type_name (fixed_record_type) != NULL)
9085           {
9086             const char *name = ada_type_name (fixed_record_type);
9087             char *xvz_name
9088               = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
9089             bool xvz_found = false;
9090             LONGEST size;
9091
9092             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
9093             TRY
9094               {
9095                 xvz_found = get_int_var_value (xvz_name, size);
9096               }
9097             CATCH (except, RETURN_MASK_ERROR)
9098               {
9099                 /* We found the variable, but somehow failed to read
9100                    its value.  Rethrow the same error, but with a little
9101                    bit more information, to help the user understand
9102                    what went wrong (Eg: the variable might have been
9103                    optimized out).  */
9104                 throw_error (except.error,
9105                              _("unable to read value of %s (%s)"),
9106                              xvz_name, except.message);
9107               }
9108             END_CATCH
9109
9110             if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
9111               {
9112                 fixed_record_type = copy_type (fixed_record_type);
9113                 TYPE_LENGTH (fixed_record_type) = size;
9114
9115                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
9116                    observed this when the debugging info is STABS, and
9117                    apparently it is something that is hard to fix.
9118
9119                    In practice, we don't need the actual type definition
9120                    at all, because the presence of the XVZ variable allows us
9121                    to assume that there must be a XVS type as well, which we
9122                    should be able to use later, when we need the actual type
9123                    definition.
9124
9125                    In the meantime, pretend that the "fixed" type we are
9126                    returning is NOT a stub, because this can cause trouble
9127                    when using this type to create new types targeting it.
9128                    Indeed, the associated creation routines often check
9129                    whether the target type is a stub and will try to replace
9130                    it, thus using a type with the wrong size.  This, in turn,
9131                    might cause the new type to have the wrong size too.
9132                    Consider the case of an array, for instance, where the size
9133                    of the array is computed from the number of elements in
9134                    our array multiplied by the size of its element.  */
9135                 TYPE_STUB (fixed_record_type) = 0;
9136               }
9137           }
9138         return fixed_record_type;
9139       }
9140     case TYPE_CODE_ARRAY:
9141       return to_fixed_array_type (type, dval, 1);
9142     case TYPE_CODE_UNION:
9143       if (dval == NULL)
9144         return type;
9145       else
9146         return to_fixed_variant_branch_type (type, valaddr, address, dval);
9147     }
9148 }
9149
9150 /* The same as ada_to_fixed_type_1, except that it preserves the type
9151    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
9152
9153    The typedef layer needs be preserved in order to differentiate between
9154    arrays and array pointers when both types are implemented using the same
9155    fat pointer.  In the array pointer case, the pointer is encoded as
9156    a typedef of the pointer type.  For instance, considering:
9157
9158           type String_Access is access String;
9159           S1 : String_Access := null;
9160
9161    To the debugger, S1 is defined as a typedef of type String.  But
9162    to the user, it is a pointer.  So if the user tries to print S1,
9163    we should not dereference the array, but print the array address
9164    instead.
9165
9166    If we didn't preserve the typedef layer, we would lose the fact that
9167    the type is to be presented as a pointer (needs de-reference before
9168    being printed).  And we would also use the source-level type name.  */
9169
9170 struct type *
9171 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
9172                    CORE_ADDR address, struct value *dval, int check_tag)
9173
9174 {
9175   struct type *fixed_type =
9176     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
9177
9178   /*  If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9179       then preserve the typedef layer.
9180
9181       Implementation note: We can only check the main-type portion of
9182       the TYPE and FIXED_TYPE, because eliminating the typedef layer
9183       from TYPE now returns a type that has the same instance flags
9184       as TYPE.  For instance, if TYPE is a "typedef const", and its
9185       target type is a "struct", then the typedef elimination will return
9186       a "const" version of the target type.  See check_typedef for more
9187       details about how the typedef layer elimination is done.
9188
9189       brobecker/2010-11-19: It seems to me that the only case where it is
9190       useful to preserve the typedef layer is when dealing with fat pointers.
9191       Perhaps, we could add a check for that and preserve the typedef layer
9192       only in that situation.  But this seems unecessary so far, probably
9193       because we call check_typedef/ada_check_typedef pretty much everywhere.
9194       */
9195   if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9196       && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
9197           == TYPE_MAIN_TYPE (fixed_type)))
9198     return type;
9199
9200   return fixed_type;
9201 }
9202
9203 /* A standard (static-sized) type corresponding as well as possible to
9204    TYPE0, but based on no runtime data.  */
9205
9206 static struct type *
9207 to_static_fixed_type (struct type *type0)
9208 {
9209   struct type *type;
9210
9211   if (type0 == NULL)
9212     return NULL;
9213
9214   if (TYPE_FIXED_INSTANCE (type0))
9215     return type0;
9216
9217   type0 = ada_check_typedef (type0);
9218
9219   switch (TYPE_CODE (type0))
9220     {
9221     default:
9222       return type0;
9223     case TYPE_CODE_STRUCT:
9224       type = dynamic_template_type (type0);
9225       if (type != NULL)
9226         return template_to_static_fixed_type (type);
9227       else
9228         return template_to_static_fixed_type (type0);
9229     case TYPE_CODE_UNION:
9230       type = ada_find_parallel_type (type0, "___XVU");
9231       if (type != NULL)
9232         return template_to_static_fixed_type (type);
9233       else
9234         return template_to_static_fixed_type (type0);
9235     }
9236 }
9237
9238 /* A static approximation of TYPE with all type wrappers removed.  */
9239
9240 static struct type *
9241 static_unwrap_type (struct type *type)
9242 {
9243   if (ada_is_aligner_type (type))
9244     {
9245       struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
9246       if (ada_type_name (type1) == NULL)
9247         TYPE_NAME (type1) = ada_type_name (type);
9248
9249       return static_unwrap_type (type1);
9250     }
9251   else
9252     {
9253       struct type *raw_real_type = ada_get_base_type (type);
9254
9255       if (raw_real_type == type)
9256         return type;
9257       else
9258         return to_static_fixed_type (raw_real_type);
9259     }
9260 }
9261
9262 /* In some cases, incomplete and private types require
9263    cross-references that are not resolved as records (for example,
9264       type Foo;
9265       type FooP is access Foo;
9266       V: FooP;
9267       type Foo is array ...;
9268    ).  In these cases, since there is no mechanism for producing
9269    cross-references to such types, we instead substitute for FooP a
9270    stub enumeration type that is nowhere resolved, and whose tag is
9271    the name of the actual type.  Call these types "non-record stubs".  */
9272
9273 /* A type equivalent to TYPE that is not a non-record stub, if one
9274    exists, otherwise TYPE.  */
9275
9276 struct type *
9277 ada_check_typedef (struct type *type)
9278 {
9279   if (type == NULL)
9280     return NULL;
9281
9282   /* If our type is a typedef type of a fat pointer, then we're done.
9283      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9284      what allows us to distinguish between fat pointers that represent
9285      array types, and fat pointers that represent array access types
9286      (in both cases, the compiler implements them as fat pointers).  */
9287   if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9288       && is_thick_pntr (ada_typedef_target_type (type)))
9289     return type;
9290
9291   type = check_typedef (type);
9292   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
9293       || !TYPE_STUB (type)
9294       || TYPE_TAG_NAME (type) == NULL)
9295     return type;
9296   else
9297     {
9298       const char *name = TYPE_TAG_NAME (type);
9299       struct type *type1 = ada_find_any_type (name);
9300
9301       if (type1 == NULL)
9302         return type;
9303
9304       /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9305          stubs pointing to arrays, as we don't create symbols for array
9306          types, only for the typedef-to-array types).  If that's the case,
9307          strip the typedef layer.  */
9308       if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9309         type1 = ada_check_typedef (type1);
9310
9311       return type1;
9312     }
9313 }
9314
9315 /* A value representing the data at VALADDR/ADDRESS as described by
9316    type TYPE0, but with a standard (static-sized) type that correctly
9317    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
9318    type, then return VAL0 [this feature is simply to avoid redundant
9319    creation of struct values].  */
9320
9321 static struct value *
9322 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9323                            struct value *val0)
9324 {
9325   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
9326
9327   if (type == type0 && val0 != NULL)
9328     return val0;
9329
9330   if (VALUE_LVAL (val0) != lval_memory)
9331     {
9332       /* Our value does not live in memory; it could be a convenience
9333          variable, for instance.  Create a not_lval value using val0's
9334          contents.  */
9335       return value_from_contents (type, value_contents (val0));
9336     }
9337
9338   return value_from_contents_and_address (type, 0, address);
9339 }
9340
9341 /* A value representing VAL, but with a standard (static-sized) type
9342    that correctly describes it.  Does not necessarily create a new
9343    value.  */
9344
9345 struct value *
9346 ada_to_fixed_value (struct value *val)
9347 {
9348   val = unwrap_value (val);
9349   val = ada_to_fixed_value_create (value_type (val),
9350                                       value_address (val),
9351                                       val);
9352   return val;
9353 }
9354 \f
9355
9356 /* Attributes */
9357
9358 /* Table mapping attribute numbers to names.
9359    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
9360
9361 static const char *attribute_names[] = {
9362   "<?>",
9363
9364   "first",
9365   "last",
9366   "length",
9367   "image",
9368   "max",
9369   "min",
9370   "modulus",
9371   "pos",
9372   "size",
9373   "tag",
9374   "val",
9375   0
9376 };
9377
9378 const char *
9379 ada_attribute_name (enum exp_opcode n)
9380 {
9381   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9382     return attribute_names[n - OP_ATR_FIRST + 1];
9383   else
9384     return attribute_names[0];
9385 }
9386
9387 /* Evaluate the 'POS attribute applied to ARG.  */
9388
9389 static LONGEST
9390 pos_atr (struct value *arg)
9391 {
9392   struct value *val = coerce_ref (arg);
9393   struct type *type = value_type (val);
9394   LONGEST result;
9395
9396   if (!discrete_type_p (type))
9397     error (_("'POS only defined on discrete types"));
9398
9399   if (!discrete_position (type, value_as_long (val), &result))
9400     error (_("enumeration value is invalid: can't find 'POS"));
9401
9402   return result;
9403 }
9404
9405 static struct value *
9406 value_pos_atr (struct type *type, struct value *arg)
9407 {
9408   return value_from_longest (type, pos_atr (arg));
9409 }
9410
9411 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
9412
9413 static struct value *
9414 value_val_atr (struct type *type, struct value *arg)
9415 {
9416   if (!discrete_type_p (type))
9417     error (_("'VAL only defined on discrete types"));
9418   if (!integer_type_p (value_type (arg)))
9419     error (_("'VAL requires integral argument"));
9420
9421   if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9422     {
9423       long pos = value_as_long (arg);
9424
9425       if (pos < 0 || pos >= TYPE_NFIELDS (type))
9426         error (_("argument to 'VAL out of range"));
9427       return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
9428     }
9429   else
9430     return value_from_longest (type, value_as_long (arg));
9431 }
9432 \f
9433
9434                                 /* Evaluation */
9435
9436 /* True if TYPE appears to be an Ada character type.
9437    [At the moment, this is true only for Character and Wide_Character;
9438    It is a heuristic test that could stand improvement].  */
9439
9440 int
9441 ada_is_character_type (struct type *type)
9442 {
9443   const char *name;
9444
9445   /* If the type code says it's a character, then assume it really is,
9446      and don't check any further.  */
9447   if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9448     return 1;
9449   
9450   /* Otherwise, assume it's a character type iff it is a discrete type
9451      with a known character type name.  */
9452   name = ada_type_name (type);
9453   return (name != NULL
9454           && (TYPE_CODE (type) == TYPE_CODE_INT
9455               || TYPE_CODE (type) == TYPE_CODE_RANGE)
9456           && (strcmp (name, "character") == 0
9457               || strcmp (name, "wide_character") == 0
9458               || strcmp (name, "wide_wide_character") == 0
9459               || strcmp (name, "unsigned char") == 0));
9460 }
9461
9462 /* True if TYPE appears to be an Ada string type.  */
9463
9464 int
9465 ada_is_string_type (struct type *type)
9466 {
9467   type = ada_check_typedef (type);
9468   if (type != NULL
9469       && TYPE_CODE (type) != TYPE_CODE_PTR
9470       && (ada_is_simple_array_type (type)
9471           || ada_is_array_descriptor_type (type))
9472       && ada_array_arity (type) == 1)
9473     {
9474       struct type *elttype = ada_array_element_type (type, 1);
9475
9476       return ada_is_character_type (elttype);
9477     }
9478   else
9479     return 0;
9480 }
9481
9482 /* The compiler sometimes provides a parallel XVS type for a given
9483    PAD type.  Normally, it is safe to follow the PAD type directly,
9484    but older versions of the compiler have a bug that causes the offset
9485    of its "F" field to be wrong.  Following that field in that case
9486    would lead to incorrect results, but this can be worked around
9487    by ignoring the PAD type and using the associated XVS type instead.
9488
9489    Set to True if the debugger should trust the contents of PAD types.
9490    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
9491 static int trust_pad_over_xvs = 1;
9492
9493 /* True if TYPE is a struct type introduced by the compiler to force the
9494    alignment of a value.  Such types have a single field with a
9495    distinctive name.  */
9496
9497 int
9498 ada_is_aligner_type (struct type *type)
9499 {
9500   type = ada_check_typedef (type);
9501
9502   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9503     return 0;
9504
9505   return (TYPE_CODE (type) == TYPE_CODE_STRUCT
9506           && TYPE_NFIELDS (type) == 1
9507           && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
9508 }
9509
9510 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9511    the parallel type.  */
9512
9513 struct type *
9514 ada_get_base_type (struct type *raw_type)
9515 {
9516   struct type *real_type_namer;
9517   struct type *raw_real_type;
9518
9519   if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9520     return raw_type;
9521
9522   if (ada_is_aligner_type (raw_type))
9523     /* The encoding specifies that we should always use the aligner type.
9524        So, even if this aligner type has an associated XVS type, we should
9525        simply ignore it.
9526
9527        According to the compiler gurus, an XVS type parallel to an aligner
9528        type may exist because of a stabs limitation.  In stabs, aligner
9529        types are empty because the field has a variable-sized type, and
9530        thus cannot actually be used as an aligner type.  As a result,
9531        we need the associated parallel XVS type to decode the type.
9532        Since the policy in the compiler is to not change the internal
9533        representation based on the debugging info format, we sometimes
9534        end up having a redundant XVS type parallel to the aligner type.  */
9535     return raw_type;
9536
9537   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9538   if (real_type_namer == NULL
9539       || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9540       || TYPE_NFIELDS (real_type_namer) != 1)
9541     return raw_type;
9542
9543   if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9544     {
9545       /* This is an older encoding form where the base type needs to be
9546          looked up by name.  We prefer the newer enconding because it is
9547          more efficient.  */
9548       raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9549       if (raw_real_type == NULL)
9550         return raw_type;
9551       else
9552         return raw_real_type;
9553     }
9554
9555   /* The field in our XVS type is a reference to the base type.  */
9556   return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
9557 }
9558
9559 /* The type of value designated by TYPE, with all aligners removed.  */
9560
9561 struct type *
9562 ada_aligned_type (struct type *type)
9563 {
9564   if (ada_is_aligner_type (type))
9565     return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9566   else
9567     return ada_get_base_type (type);
9568 }
9569
9570
9571 /* The address of the aligned value in an object at address VALADDR
9572    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
9573
9574 const gdb_byte *
9575 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9576 {
9577   if (ada_is_aligner_type (type))
9578     return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
9579                                    valaddr +
9580                                    TYPE_FIELD_BITPOS (type,
9581                                                       0) / TARGET_CHAR_BIT);
9582   else
9583     return valaddr;
9584 }
9585
9586
9587
9588 /* The printed representation of an enumeration literal with encoded
9589    name NAME.  The value is good to the next call of ada_enum_name.  */
9590 const char *
9591 ada_enum_name (const char *name)
9592 {
9593   static char *result;
9594   static size_t result_len = 0;
9595   const char *tmp;
9596
9597   /* First, unqualify the enumeration name:
9598      1. Search for the last '.' character.  If we find one, then skip
9599      all the preceding characters, the unqualified name starts
9600      right after that dot.
9601      2. Otherwise, we may be debugging on a target where the compiler
9602      translates dots into "__".  Search forward for double underscores,
9603      but stop searching when we hit an overloading suffix, which is
9604      of the form "__" followed by digits.  */
9605
9606   tmp = strrchr (name, '.');
9607   if (tmp != NULL)
9608     name = tmp + 1;
9609   else
9610     {
9611       while ((tmp = strstr (name, "__")) != NULL)
9612         {
9613           if (isdigit (tmp[2]))
9614             break;
9615           else
9616             name = tmp + 2;
9617         }
9618     }
9619
9620   if (name[0] == 'Q')
9621     {
9622       int v;
9623
9624       if (name[1] == 'U' || name[1] == 'W')
9625         {
9626           if (sscanf (name + 2, "%x", &v) != 1)
9627             return name;
9628         }
9629       else
9630         return name;
9631
9632       GROW_VECT (result, result_len, 16);
9633       if (isascii (v) && isprint (v))
9634         xsnprintf (result, result_len, "'%c'", v);
9635       else if (name[1] == 'U')
9636         xsnprintf (result, result_len, "[\"%02x\"]", v);
9637       else
9638         xsnprintf (result, result_len, "[\"%04x\"]", v);
9639
9640       return result;
9641     }
9642   else
9643     {
9644       tmp = strstr (name, "__");
9645       if (tmp == NULL)
9646         tmp = strstr (name, "$");
9647       if (tmp != NULL)
9648         {
9649           GROW_VECT (result, result_len, tmp - name + 1);
9650           strncpy (result, name, tmp - name);
9651           result[tmp - name] = '\0';
9652           return result;
9653         }
9654
9655       return name;
9656     }
9657 }
9658
9659 /* Evaluate the subexpression of EXP starting at *POS as for
9660    evaluate_type, updating *POS to point just past the evaluated
9661    expression.  */
9662
9663 static struct value *
9664 evaluate_subexp_type (struct expression *exp, int *pos)
9665 {
9666   return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9667 }
9668
9669 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9670    value it wraps.  */
9671
9672 static struct value *
9673 unwrap_value (struct value *val)
9674 {
9675   struct type *type = ada_check_typedef (value_type (val));
9676
9677   if (ada_is_aligner_type (type))
9678     {
9679       struct value *v = ada_value_struct_elt (val, "F", 0);
9680       struct type *val_type = ada_check_typedef (value_type (v));
9681
9682       if (ada_type_name (val_type) == NULL)
9683         TYPE_NAME (val_type) = ada_type_name (type);
9684
9685       return unwrap_value (v);
9686     }
9687   else
9688     {
9689       struct type *raw_real_type =
9690         ada_check_typedef (ada_get_base_type (type));
9691
9692       /* If there is no parallel XVS or XVE type, then the value is
9693          already unwrapped.  Return it without further modification.  */
9694       if ((type == raw_real_type)
9695           && ada_find_parallel_type (type, "___XVE") == NULL)
9696         return val;
9697
9698       return
9699         coerce_unspec_val_to_type
9700         (val, ada_to_fixed_type (raw_real_type, 0,
9701                                  value_address (val),
9702                                  NULL, 1));
9703     }
9704 }
9705
9706 static struct value *
9707 cast_from_fixed (struct type *type, struct value *arg)
9708 {
9709   struct value *scale = ada_scaling_factor (value_type (arg));
9710   arg = value_cast (value_type (scale), arg);
9711
9712   arg = value_binop (arg, scale, BINOP_MUL);
9713   return value_cast (type, arg);
9714 }
9715
9716 static struct value *
9717 cast_to_fixed (struct type *type, struct value *arg)
9718 {
9719   if (type == value_type (arg))
9720     return arg;
9721
9722   struct value *scale = ada_scaling_factor (type);
9723   if (ada_is_fixed_point_type (value_type (arg)))
9724     arg = cast_from_fixed (value_type (scale), arg);
9725   else
9726     arg = value_cast (value_type (scale), arg);
9727
9728   arg = value_binop (arg, scale, BINOP_DIV);
9729   return value_cast (type, arg);
9730 }
9731
9732 /* Given two array types T1 and T2, return nonzero iff both arrays
9733    contain the same number of elements.  */
9734
9735 static int
9736 ada_same_array_size_p (struct type *t1, struct type *t2)
9737 {
9738   LONGEST lo1, hi1, lo2, hi2;
9739
9740   /* Get the array bounds in order to verify that the size of
9741      the two arrays match.  */
9742   if (!get_array_bounds (t1, &lo1, &hi1)
9743       || !get_array_bounds (t2, &lo2, &hi2))
9744     error (_("unable to determine array bounds"));
9745
9746   /* To make things easier for size comparison, normalize a bit
9747      the case of empty arrays by making sure that the difference
9748      between upper bound and lower bound is always -1.  */
9749   if (lo1 > hi1)
9750     hi1 = lo1 - 1;
9751   if (lo2 > hi2)
9752     hi2 = lo2 - 1;
9753
9754   return (hi1 - lo1 == hi2 - lo2);
9755 }
9756
9757 /* Assuming that VAL is an array of integrals, and TYPE represents
9758    an array with the same number of elements, but with wider integral
9759    elements, return an array "casted" to TYPE.  In practice, this
9760    means that the returned array is built by casting each element
9761    of the original array into TYPE's (wider) element type.  */
9762
9763 static struct value *
9764 ada_promote_array_of_integrals (struct type *type, struct value *val)
9765 {
9766   struct type *elt_type = TYPE_TARGET_TYPE (type);
9767   LONGEST lo, hi;
9768   struct value *res;
9769   LONGEST i;
9770
9771   /* Verify that both val and type are arrays of scalars, and
9772      that the size of val's elements is smaller than the size
9773      of type's element.  */
9774   gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9775   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9776   gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9777   gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9778   gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9779               > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9780
9781   if (!get_array_bounds (type, &lo, &hi))
9782     error (_("unable to determine array bounds"));
9783
9784   res = allocate_value (type);
9785
9786   /* Promote each array element.  */
9787   for (i = 0; i < hi - lo + 1; i++)
9788     {
9789       struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9790
9791       memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9792               value_contents_all (elt), TYPE_LENGTH (elt_type));
9793     }
9794
9795   return res;
9796 }
9797
9798 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9799    return the converted value.  */
9800
9801 static struct value *
9802 coerce_for_assign (struct type *type, struct value *val)
9803 {
9804   struct type *type2 = value_type (val);
9805
9806   if (type == type2)
9807     return val;
9808
9809   type2 = ada_check_typedef (type2);
9810   type = ada_check_typedef (type);
9811
9812   if (TYPE_CODE (type2) == TYPE_CODE_PTR
9813       && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9814     {
9815       val = ada_value_ind (val);
9816       type2 = value_type (val);
9817     }
9818
9819   if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
9820       && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9821     {
9822       if (!ada_same_array_size_p (type, type2))
9823         error (_("cannot assign arrays of different length"));
9824
9825       if (is_integral_type (TYPE_TARGET_TYPE (type))
9826           && is_integral_type (TYPE_TARGET_TYPE (type2))
9827           && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9828                < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9829         {
9830           /* Allow implicit promotion of the array elements to
9831              a wider type.  */
9832           return ada_promote_array_of_integrals (type, val);
9833         }
9834
9835       if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9836           != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9837         error (_("Incompatible types in assignment"));
9838       deprecated_set_value_type (val, type);
9839     }
9840   return val;
9841 }
9842
9843 static struct value *
9844 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9845 {
9846   struct value *val;
9847   struct type *type1, *type2;
9848   LONGEST v, v1, v2;
9849
9850   arg1 = coerce_ref (arg1);
9851   arg2 = coerce_ref (arg2);
9852   type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9853   type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9854
9855   if (TYPE_CODE (type1) != TYPE_CODE_INT
9856       || TYPE_CODE (type2) != TYPE_CODE_INT)
9857     return value_binop (arg1, arg2, op);
9858
9859   switch (op)
9860     {
9861     case BINOP_MOD:
9862     case BINOP_DIV:
9863     case BINOP_REM:
9864       break;
9865     default:
9866       return value_binop (arg1, arg2, op);
9867     }
9868
9869   v2 = value_as_long (arg2);
9870   if (v2 == 0)
9871     error (_("second operand of %s must not be zero."), op_string (op));
9872
9873   if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9874     return value_binop (arg1, arg2, op);
9875
9876   v1 = value_as_long (arg1);
9877   switch (op)
9878     {
9879     case BINOP_DIV:
9880       v = v1 / v2;
9881       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9882         v += v > 0 ? -1 : 1;
9883       break;
9884     case BINOP_REM:
9885       v = v1 % v2;
9886       if (v * v1 < 0)
9887         v -= v2;
9888       break;
9889     default:
9890       /* Should not reach this point.  */
9891       v = 0;
9892     }
9893
9894   val = allocate_value (type1);
9895   store_unsigned_integer (value_contents_raw (val),
9896                           TYPE_LENGTH (value_type (val)),
9897                           gdbarch_byte_order (get_type_arch (type1)), v);
9898   return val;
9899 }
9900
9901 static int
9902 ada_value_equal (struct value *arg1, struct value *arg2)
9903 {
9904   if (ada_is_direct_array_type (value_type (arg1))
9905       || ada_is_direct_array_type (value_type (arg2)))
9906     {
9907       struct type *arg1_type, *arg2_type;
9908
9909       /* Automatically dereference any array reference before
9910          we attempt to perform the comparison.  */
9911       arg1 = ada_coerce_ref (arg1);
9912       arg2 = ada_coerce_ref (arg2);
9913
9914       arg1 = ada_coerce_to_simple_array (arg1);
9915       arg2 = ada_coerce_to_simple_array (arg2);
9916
9917       arg1_type = ada_check_typedef (value_type (arg1));
9918       arg2_type = ada_check_typedef (value_type (arg2));
9919
9920       if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9921           || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
9922         error (_("Attempt to compare array with non-array"));
9923       /* FIXME: The following works only for types whose
9924          representations use all bits (no padding or undefined bits)
9925          and do not have user-defined equality.  */
9926       return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9927               && memcmp (value_contents (arg1), value_contents (arg2),
9928                          TYPE_LENGTH (arg1_type)) == 0);
9929     }
9930   return value_equal (arg1, arg2);
9931 }
9932
9933 /* Total number of component associations in the aggregate starting at
9934    index PC in EXP.  Assumes that index PC is the start of an
9935    OP_AGGREGATE.  */
9936
9937 static int
9938 num_component_specs (struct expression *exp, int pc)
9939 {
9940   int n, m, i;
9941
9942   m = exp->elts[pc + 1].longconst;
9943   pc += 3;
9944   n = 0;
9945   for (i = 0; i < m; i += 1)
9946     {
9947       switch (exp->elts[pc].opcode) 
9948         {
9949         default:
9950           n += 1;
9951           break;
9952         case OP_CHOICES:
9953           n += exp->elts[pc + 1].longconst;
9954           break;
9955         }
9956       ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9957     }
9958   return n;
9959 }
9960
9961 /* Assign the result of evaluating EXP starting at *POS to the INDEXth 
9962    component of LHS (a simple array or a record), updating *POS past
9963    the expression, assuming that LHS is contained in CONTAINER.  Does
9964    not modify the inferior's memory, nor does it modify LHS (unless
9965    LHS == CONTAINER).  */
9966
9967 static void
9968 assign_component (struct value *container, struct value *lhs, LONGEST index,
9969                   struct expression *exp, int *pos)
9970 {
9971   struct value *mark = value_mark ();
9972   struct value *elt;
9973   struct type *lhs_type = check_typedef (value_type (lhs));
9974
9975   if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
9976     {
9977       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9978       struct value *index_val = value_from_longest (index_type, index);
9979
9980       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9981     }
9982   else
9983     {
9984       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9985       elt = ada_to_fixed_value (elt);
9986     }
9987
9988   if (exp->elts[*pos].opcode == OP_AGGREGATE)
9989     assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9990   else
9991     value_assign_to_component (container, elt, 
9992                                ada_evaluate_subexp (NULL, exp, pos, 
9993                                                     EVAL_NORMAL));
9994
9995   value_free_to_mark (mark);
9996 }
9997
9998 /* Assuming that LHS represents an lvalue having a record or array
9999    type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
10000    of that aggregate's value to LHS, advancing *POS past the
10001    aggregate.  NOSIDE is as for evaluate_subexp.  CONTAINER is an
10002    lvalue containing LHS (possibly LHS itself).  Does not modify
10003    the inferior's memory, nor does it modify the contents of 
10004    LHS (unless == CONTAINER).  Returns the modified CONTAINER.  */
10005
10006 static struct value *
10007 assign_aggregate (struct value *container, 
10008                   struct value *lhs, struct expression *exp, 
10009                   int *pos, enum noside noside)
10010 {
10011   struct type *lhs_type;
10012   int n = exp->elts[*pos+1].longconst;
10013   LONGEST low_index, high_index;
10014   int num_specs;
10015   LONGEST *indices;
10016   int max_indices, num_indices;
10017   int i;
10018
10019   *pos += 3;
10020   if (noside != EVAL_NORMAL)
10021     {
10022       for (i = 0; i < n; i += 1)
10023         ada_evaluate_subexp (NULL, exp, pos, noside);
10024       return container;
10025     }
10026
10027   container = ada_coerce_ref (container);
10028   if (ada_is_direct_array_type (value_type (container)))
10029     container = ada_coerce_to_simple_array (container);
10030   lhs = ada_coerce_ref (lhs);
10031   if (!deprecated_value_modifiable (lhs))
10032     error (_("Left operand of assignment is not a modifiable lvalue."));
10033
10034   lhs_type = check_typedef (value_type (lhs));
10035   if (ada_is_direct_array_type (lhs_type))
10036     {
10037       lhs = ada_coerce_to_simple_array (lhs);
10038       lhs_type = check_typedef (value_type (lhs));
10039       low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
10040       high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
10041     }
10042   else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
10043     {
10044       low_index = 0;
10045       high_index = num_visible_fields (lhs_type) - 1;
10046     }
10047   else
10048     error (_("Left-hand side must be array or record."));
10049
10050   num_specs = num_component_specs (exp, *pos - 3);
10051   max_indices = 4 * num_specs + 4;
10052   indices = XALLOCAVEC (LONGEST, max_indices);
10053   indices[0] = indices[1] = low_index - 1;
10054   indices[2] = indices[3] = high_index + 1;
10055   num_indices = 4;
10056
10057   for (i = 0; i < n; i += 1)
10058     {
10059       switch (exp->elts[*pos].opcode)
10060         {
10061           case OP_CHOICES:
10062             aggregate_assign_from_choices (container, lhs, exp, pos, indices, 
10063                                            &num_indices, max_indices,
10064                                            low_index, high_index);
10065             break;
10066           case OP_POSITIONAL:
10067             aggregate_assign_positional (container, lhs, exp, pos, indices,
10068                                          &num_indices, max_indices,
10069                                          low_index, high_index);
10070             break;
10071           case OP_OTHERS:
10072             if (i != n-1)
10073               error (_("Misplaced 'others' clause"));
10074             aggregate_assign_others (container, lhs, exp, pos, indices, 
10075                                      num_indices, low_index, high_index);
10076             break;
10077           default:
10078             error (_("Internal error: bad aggregate clause"));
10079         }
10080     }
10081
10082   return container;
10083 }
10084               
10085 /* Assign into the component of LHS indexed by the OP_POSITIONAL
10086    construct at *POS, updating *POS past the construct, given that
10087    the positions are relative to lower bound LOW, where HIGH is the 
10088    upper bound.  Record the position in INDICES[0 .. MAX_INDICES-1]
10089    updating *NUM_INDICES as needed.  CONTAINER is as for
10090    assign_aggregate.  */
10091 static void
10092 aggregate_assign_positional (struct value *container,
10093                              struct value *lhs, struct expression *exp,
10094                              int *pos, LONGEST *indices, int *num_indices,
10095                              int max_indices, LONGEST low, LONGEST high) 
10096 {
10097   LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
10098   
10099   if (ind - 1 == high)
10100     warning (_("Extra components in aggregate ignored."));
10101   if (ind <= high)
10102     {
10103       add_component_interval (ind, ind, indices, num_indices, max_indices);
10104       *pos += 3;
10105       assign_component (container, lhs, ind, exp, pos);
10106     }
10107   else
10108     ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10109 }
10110
10111 /* Assign into the components of LHS indexed by the OP_CHOICES
10112    construct at *POS, updating *POS past the construct, given that
10113    the allowable indices are LOW..HIGH.  Record the indices assigned
10114    to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
10115    needed.  CONTAINER is as for assign_aggregate.  */
10116 static void
10117 aggregate_assign_from_choices (struct value *container,
10118                                struct value *lhs, struct expression *exp,
10119                                int *pos, LONGEST *indices, int *num_indices,
10120                                int max_indices, LONGEST low, LONGEST high) 
10121 {
10122   int j;
10123   int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
10124   int choice_pos, expr_pc;
10125   int is_array = ada_is_direct_array_type (value_type (lhs));
10126
10127   choice_pos = *pos += 3;
10128
10129   for (j = 0; j < n_choices; j += 1)
10130     ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10131   expr_pc = *pos;
10132   ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10133   
10134   for (j = 0; j < n_choices; j += 1)
10135     {
10136       LONGEST lower, upper;
10137       enum exp_opcode op = exp->elts[choice_pos].opcode;
10138
10139       if (op == OP_DISCRETE_RANGE)
10140         {
10141           choice_pos += 1;
10142           lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10143                                                       EVAL_NORMAL));
10144           upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos, 
10145                                                       EVAL_NORMAL));
10146         }
10147       else if (is_array)
10148         {
10149           lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos, 
10150                                                       EVAL_NORMAL));
10151           upper = lower;
10152         }
10153       else
10154         {
10155           int ind;
10156           const char *name;
10157
10158           switch (op)
10159             {
10160             case OP_NAME:
10161               name = &exp->elts[choice_pos + 2].string;
10162               break;
10163             case OP_VAR_VALUE:
10164               name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
10165               break;
10166             default:
10167               error (_("Invalid record component association."));
10168             }
10169           ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
10170           ind = 0;
10171           if (! find_struct_field (name, value_type (lhs), 0, 
10172                                    NULL, NULL, NULL, NULL, &ind))
10173             error (_("Unknown component name: %s."), name);
10174           lower = upper = ind;
10175         }
10176
10177       if (lower <= upper && (lower < low || upper > high))
10178         error (_("Index in component association out of bounds."));
10179
10180       add_component_interval (lower, upper, indices, num_indices,
10181                               max_indices);
10182       while (lower <= upper)
10183         {
10184           int pos1;
10185
10186           pos1 = expr_pc;
10187           assign_component (container, lhs, lower, exp, &pos1);
10188           lower += 1;
10189         }
10190     }
10191 }
10192
10193 /* Assign the value of the expression in the OP_OTHERS construct in
10194    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10195    have not been previously assigned.  The index intervals already assigned
10196    are in INDICES[0 .. NUM_INDICES-1].  Updates *POS to after the 
10197    OP_OTHERS clause.  CONTAINER is as for assign_aggregate.  */
10198 static void
10199 aggregate_assign_others (struct value *container,
10200                          struct value *lhs, struct expression *exp,
10201                          int *pos, LONGEST *indices, int num_indices,
10202                          LONGEST low, LONGEST high) 
10203 {
10204   int i;
10205   int expr_pc = *pos + 1;
10206   
10207   for (i = 0; i < num_indices - 2; i += 2)
10208     {
10209       LONGEST ind;
10210
10211       for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10212         {
10213           int localpos;
10214
10215           localpos = expr_pc;
10216           assign_component (container, lhs, ind, exp, &localpos);
10217         }
10218     }
10219   ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10220 }
10221
10222 /* Add the interval [LOW .. HIGH] to the sorted set of intervals 
10223    [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10224    modifying *SIZE as needed.  It is an error if *SIZE exceeds
10225    MAX_SIZE.  The resulting intervals do not overlap.  */
10226 static void
10227 add_component_interval (LONGEST low, LONGEST high, 
10228                         LONGEST* indices, int *size, int max_size)
10229 {
10230   int i, j;
10231
10232   for (i = 0; i < *size; i += 2) {
10233     if (high >= indices[i] && low <= indices[i + 1])
10234       {
10235         int kh;
10236
10237         for (kh = i + 2; kh < *size; kh += 2)
10238           if (high < indices[kh])
10239             break;
10240         if (low < indices[i])
10241           indices[i] = low;
10242         indices[i + 1] = indices[kh - 1];
10243         if (high > indices[i + 1])
10244           indices[i + 1] = high;
10245         memcpy (indices + i + 2, indices + kh, *size - kh);
10246         *size -= kh - i - 2;
10247         return;
10248       }
10249     else if (high < indices[i])
10250       break;
10251   }
10252         
10253   if (*size == max_size)
10254     error (_("Internal error: miscounted aggregate components."));
10255   *size += 2;
10256   for (j = *size-1; j >= i+2; j -= 1)
10257     indices[j] = indices[j - 2];
10258   indices[i] = low;
10259   indices[i + 1] = high;
10260 }
10261
10262 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10263    is different.  */
10264
10265 static struct value *
10266 ada_value_cast (struct type *type, struct value *arg2)
10267 {
10268   if (type == ada_check_typedef (value_type (arg2)))
10269     return arg2;
10270
10271   if (ada_is_fixed_point_type (type))
10272     return (cast_to_fixed (type, arg2));
10273
10274   if (ada_is_fixed_point_type (value_type (arg2)))
10275     return cast_from_fixed (type, arg2);
10276
10277   return value_cast (type, arg2);
10278 }
10279
10280 /*  Evaluating Ada expressions, and printing their result.
10281     ------------------------------------------------------
10282
10283     1. Introduction:
10284     ----------------
10285
10286     We usually evaluate an Ada expression in order to print its value.
10287     We also evaluate an expression in order to print its type, which
10288     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10289     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
10290     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10291     the evaluation compared to the EVAL_NORMAL, but is otherwise very
10292     similar.
10293
10294     Evaluating expressions is a little more complicated for Ada entities
10295     than it is for entities in languages such as C.  The main reason for
10296     this is that Ada provides types whose definition might be dynamic.
10297     One example of such types is variant records.  Or another example
10298     would be an array whose bounds can only be known at run time.
10299
10300     The following description is a general guide as to what should be
10301     done (and what should NOT be done) in order to evaluate an expression
10302     involving such types, and when.  This does not cover how the semantic
10303     information is encoded by GNAT as this is covered separatly.  For the
10304     document used as the reference for the GNAT encoding, see exp_dbug.ads
10305     in the GNAT sources.
10306
10307     Ideally, we should embed each part of this description next to its
10308     associated code.  Unfortunately, the amount of code is so vast right
10309     now that it's hard to see whether the code handling a particular
10310     situation might be duplicated or not.  One day, when the code is
10311     cleaned up, this guide might become redundant with the comments
10312     inserted in the code, and we might want to remove it.
10313
10314     2. ``Fixing'' an Entity, the Simple Case:
10315     -----------------------------------------
10316
10317     When evaluating Ada expressions, the tricky issue is that they may
10318     reference entities whose type contents and size are not statically
10319     known.  Consider for instance a variant record:
10320
10321        type Rec (Empty : Boolean := True) is record
10322           case Empty is
10323              when True => null;
10324              when False => Value : Integer;
10325           end case;
10326        end record;
10327        Yes : Rec := (Empty => False, Value => 1);
10328        No  : Rec := (empty => True);
10329
10330     The size and contents of that record depends on the value of the
10331     descriminant (Rec.Empty).  At this point, neither the debugging
10332     information nor the associated type structure in GDB are able to
10333     express such dynamic types.  So what the debugger does is to create
10334     "fixed" versions of the type that applies to the specific object.
10335     We also informally refer to this opperation as "fixing" an object,
10336     which means creating its associated fixed type.
10337
10338     Example: when printing the value of variable "Yes" above, its fixed
10339     type would look like this:
10340
10341        type Rec is record
10342           Empty : Boolean;
10343           Value : Integer;
10344        end record;
10345
10346     On the other hand, if we printed the value of "No", its fixed type
10347     would become:
10348
10349        type Rec is record
10350           Empty : Boolean;
10351        end record;
10352
10353     Things become a little more complicated when trying to fix an entity
10354     with a dynamic type that directly contains another dynamic type,
10355     such as an array of variant records, for instance.  There are
10356     two possible cases: Arrays, and records.
10357
10358     3. ``Fixing'' Arrays:
10359     ---------------------
10360
10361     The type structure in GDB describes an array in terms of its bounds,
10362     and the type of its elements.  By design, all elements in the array
10363     have the same type and we cannot represent an array of variant elements
10364     using the current type structure in GDB.  When fixing an array,
10365     we cannot fix the array element, as we would potentially need one
10366     fixed type per element of the array.  As a result, the best we can do
10367     when fixing an array is to produce an array whose bounds and size
10368     are correct (allowing us to read it from memory), but without having
10369     touched its element type.  Fixing each element will be done later,
10370     when (if) necessary.
10371
10372     Arrays are a little simpler to handle than records, because the same
10373     amount of memory is allocated for each element of the array, even if
10374     the amount of space actually used by each element differs from element
10375     to element.  Consider for instance the following array of type Rec:
10376
10377        type Rec_Array is array (1 .. 2) of Rec;
10378
10379     The actual amount of memory occupied by each element might be different
10380     from element to element, depending on the value of their discriminant.
10381     But the amount of space reserved for each element in the array remains
10382     fixed regardless.  So we simply need to compute that size using
10383     the debugging information available, from which we can then determine
10384     the array size (we multiply the number of elements of the array by
10385     the size of each element).
10386
10387     The simplest case is when we have an array of a constrained element
10388     type. For instance, consider the following type declarations:
10389
10390         type Bounded_String (Max_Size : Integer) is
10391            Length : Integer;
10392            Buffer : String (1 .. Max_Size);
10393         end record;
10394         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10395
10396     In this case, the compiler describes the array as an array of
10397     variable-size elements (identified by its XVS suffix) for which
10398     the size can be read in the parallel XVZ variable.
10399
10400     In the case of an array of an unconstrained element type, the compiler
10401     wraps the array element inside a private PAD type.  This type should not
10402     be shown to the user, and must be "unwrap"'ed before printing.  Note
10403     that we also use the adjective "aligner" in our code to designate
10404     these wrapper types.
10405
10406     In some cases, the size allocated for each element is statically
10407     known.  In that case, the PAD type already has the correct size,
10408     and the array element should remain unfixed.
10409
10410     But there are cases when this size is not statically known.
10411     For instance, assuming that "Five" is an integer variable:
10412
10413         type Dynamic is array (1 .. Five) of Integer;
10414         type Wrapper (Has_Length : Boolean := False) is record
10415            Data : Dynamic;
10416            case Has_Length is
10417               when True => Length : Integer;
10418               when False => null;
10419            end case;
10420         end record;
10421         type Wrapper_Array is array (1 .. 2) of Wrapper;
10422
10423         Hello : Wrapper_Array := (others => (Has_Length => True,
10424                                              Data => (others => 17),
10425                                              Length => 1));
10426
10427
10428     The debugging info would describe variable Hello as being an
10429     array of a PAD type.  The size of that PAD type is not statically
10430     known, but can be determined using a parallel XVZ variable.
10431     In that case, a copy of the PAD type with the correct size should
10432     be used for the fixed array.
10433
10434     3. ``Fixing'' record type objects:
10435     ----------------------------------
10436
10437     Things are slightly different from arrays in the case of dynamic
10438     record types.  In this case, in order to compute the associated
10439     fixed type, we need to determine the size and offset of each of
10440     its components.  This, in turn, requires us to compute the fixed
10441     type of each of these components.
10442
10443     Consider for instance the example:
10444
10445         type Bounded_String (Max_Size : Natural) is record
10446            Str : String (1 .. Max_Size);
10447            Length : Natural;
10448         end record;
10449         My_String : Bounded_String (Max_Size => 10);
10450
10451     In that case, the position of field "Length" depends on the size
10452     of field Str, which itself depends on the value of the Max_Size
10453     discriminant.  In order to fix the type of variable My_String,
10454     we need to fix the type of field Str.  Therefore, fixing a variant
10455     record requires us to fix each of its components.
10456
10457     However, if a component does not have a dynamic size, the component
10458     should not be fixed.  In particular, fields that use a PAD type
10459     should not fixed.  Here is an example where this might happen
10460     (assuming type Rec above):
10461
10462        type Container (Big : Boolean) is record
10463           First : Rec;
10464           After : Integer;
10465           case Big is
10466              when True => Another : Integer;
10467              when False => null;
10468           end case;
10469        end record;
10470        My_Container : Container := (Big => False,
10471                                     First => (Empty => True),
10472                                     After => 42);
10473
10474     In that example, the compiler creates a PAD type for component First,
10475     whose size is constant, and then positions the component After just
10476     right after it.  The offset of component After is therefore constant
10477     in this case.
10478
10479     The debugger computes the position of each field based on an algorithm
10480     that uses, among other things, the actual position and size of the field
10481     preceding it.  Let's now imagine that the user is trying to print
10482     the value of My_Container.  If the type fixing was recursive, we would
10483     end up computing the offset of field After based on the size of the
10484     fixed version of field First.  And since in our example First has
10485     only one actual field, the size of the fixed type is actually smaller
10486     than the amount of space allocated to that field, and thus we would
10487     compute the wrong offset of field After.
10488
10489     To make things more complicated, we need to watch out for dynamic
10490     components of variant records (identified by the ___XVL suffix in
10491     the component name).  Even if the target type is a PAD type, the size
10492     of that type might not be statically known.  So the PAD type needs
10493     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
10494     we might end up with the wrong size for our component.  This can be
10495     observed with the following type declarations:
10496
10497         type Octal is new Integer range 0 .. 7;
10498         type Octal_Array is array (Positive range <>) of Octal;
10499         pragma Pack (Octal_Array);
10500
10501         type Octal_Buffer (Size : Positive) is record
10502            Buffer : Octal_Array (1 .. Size);
10503            Length : Integer;
10504         end record;
10505
10506     In that case, Buffer is a PAD type whose size is unset and needs
10507     to be computed by fixing the unwrapped type.
10508
10509     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10510     ----------------------------------------------------------
10511
10512     Lastly, when should the sub-elements of an entity that remained unfixed
10513     thus far, be actually fixed?
10514
10515     The answer is: Only when referencing that element.  For instance
10516     when selecting one component of a record, this specific component
10517     should be fixed at that point in time.  Or when printing the value
10518     of a record, each component should be fixed before its value gets
10519     printed.  Similarly for arrays, the element of the array should be
10520     fixed when printing each element of the array, or when extracting
10521     one element out of that array.  On the other hand, fixing should
10522     not be performed on the elements when taking a slice of an array!
10523
10524     Note that one of the side effects of miscomputing the offset and
10525     size of each field is that we end up also miscomputing the size
10526     of the containing type.  This can have adverse results when computing
10527     the value of an entity.  GDB fetches the value of an entity based
10528     on the size of its type, and thus a wrong size causes GDB to fetch
10529     the wrong amount of memory.  In the case where the computed size is
10530     too small, GDB fetches too little data to print the value of our
10531     entity.  Results in this case are unpredictable, as we usually read
10532     past the buffer containing the data =:-o.  */
10533
10534 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10535    for that subexpression cast to TO_TYPE.  Advance *POS over the
10536    subexpression.  */
10537
10538 static value *
10539 ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10540                               enum noside noside, struct type *to_type)
10541 {
10542   int pc = *pos;
10543
10544   if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10545       || exp->elts[pc].opcode == OP_VAR_VALUE)
10546     {
10547       (*pos) += 4;
10548
10549       value *val;
10550       if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10551         {
10552           if (noside == EVAL_AVOID_SIDE_EFFECTS)
10553             return value_zero (to_type, not_lval);
10554
10555           val = evaluate_var_msym_value (noside,
10556                                          exp->elts[pc + 1].objfile,
10557                                          exp->elts[pc + 2].msymbol);
10558         }
10559       else
10560         val = evaluate_var_value (noside,
10561                                   exp->elts[pc + 1].block,
10562                                   exp->elts[pc + 2].symbol);
10563
10564       if (noside == EVAL_SKIP)
10565         return eval_skip_value (exp);
10566
10567       val = ada_value_cast (to_type, val);
10568
10569       /* Follow the Ada language semantics that do not allow taking
10570          an address of the result of a cast (view conversion in Ada).  */
10571       if (VALUE_LVAL (val) == lval_memory)
10572         {
10573           if (value_lazy (val))
10574             value_fetch_lazy (val);
10575           VALUE_LVAL (val) = not_lval;
10576         }
10577       return val;
10578     }
10579
10580   value *val = evaluate_subexp (to_type, exp, pos, noside);
10581   if (noside == EVAL_SKIP)
10582     return eval_skip_value (exp);
10583   return ada_value_cast (to_type, val);
10584 }
10585
10586 /* Implement the evaluate_exp routine in the exp_descriptor structure
10587    for the Ada language.  */
10588
10589 static struct value *
10590 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
10591                      int *pos, enum noside noside)
10592 {
10593   enum exp_opcode op;
10594   int tem;
10595   int pc;
10596   int preeval_pos;
10597   struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10598   struct type *type;
10599   int nargs, oplen;
10600   struct value **argvec;
10601
10602   pc = *pos;
10603   *pos += 1;
10604   op = exp->elts[pc].opcode;
10605
10606   switch (op)
10607     {
10608     default:
10609       *pos -= 1;
10610       arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10611
10612       if (noside == EVAL_NORMAL)
10613         arg1 = unwrap_value (arg1);
10614
10615       /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10616          then we need to perform the conversion manually, because
10617          evaluate_subexp_standard doesn't do it.  This conversion is
10618          necessary in Ada because the different kinds of float/fixed
10619          types in Ada have different representations.
10620
10621          Similarly, we need to perform the conversion from OP_LONG
10622          ourselves.  */
10623       if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
10624         arg1 = ada_value_cast (expect_type, arg1);
10625
10626       return arg1;
10627
10628     case OP_STRING:
10629       {
10630         struct value *result;
10631
10632         *pos -= 1;
10633         result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10634         /* The result type will have code OP_STRING, bashed there from 
10635            OP_ARRAY.  Bash it back.  */
10636         if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10637           TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
10638         return result;
10639       }
10640
10641     case UNOP_CAST:
10642       (*pos) += 2;
10643       type = exp->elts[pc + 1].type;
10644       return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
10645
10646     case UNOP_QUAL:
10647       (*pos) += 2;
10648       type = exp->elts[pc + 1].type;
10649       return ada_evaluate_subexp (type, exp, pos, noside);
10650
10651     case BINOP_ASSIGN:
10652       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10653       if (exp->elts[*pos].opcode == OP_AGGREGATE)
10654         {
10655           arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10656           if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10657             return arg1;
10658           return ada_value_assign (arg1, arg1);
10659         }
10660       /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10661          except if the lhs of our assignment is a convenience variable.
10662          In the case of assigning to a convenience variable, the lhs
10663          should be exactly the result of the evaluation of the rhs.  */
10664       type = value_type (arg1);
10665       if (VALUE_LVAL (arg1) == lval_internalvar)
10666          type = NULL;
10667       arg2 = evaluate_subexp (type, exp, pos, noside);
10668       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10669         return arg1;
10670       if (ada_is_fixed_point_type (value_type (arg1)))
10671         arg2 = cast_to_fixed (value_type (arg1), arg2);
10672       else if (ada_is_fixed_point_type (value_type (arg2)))
10673         error
10674           (_("Fixed-point values must be assigned to fixed-point variables"));
10675       else
10676         arg2 = coerce_for_assign (value_type (arg1), arg2);
10677       return ada_value_assign (arg1, arg2);
10678
10679     case BINOP_ADD:
10680       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10681       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10682       if (noside == EVAL_SKIP)
10683         goto nosideret;
10684       if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10685         return (value_from_longest
10686                  (value_type (arg1),
10687                   value_as_long (arg1) + value_as_long (arg2)));
10688       if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10689         return (value_from_longest
10690                  (value_type (arg2),
10691                   value_as_long (arg1) + value_as_long (arg2)));
10692       if ((ada_is_fixed_point_type (value_type (arg1))
10693            || ada_is_fixed_point_type (value_type (arg2)))
10694           && value_type (arg1) != value_type (arg2))
10695         error (_("Operands of fixed-point addition must have the same type"));
10696       /* Do the addition, and cast the result to the type of the first
10697          argument.  We cannot cast the result to a reference type, so if
10698          ARG1 is a reference type, find its underlying type.  */
10699       type = value_type (arg1);
10700       while (TYPE_CODE (type) == TYPE_CODE_REF)
10701         type = TYPE_TARGET_TYPE (type);
10702       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10703       return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
10704
10705     case BINOP_SUB:
10706       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10707       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10708       if (noside == EVAL_SKIP)
10709         goto nosideret;
10710       if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10711         return (value_from_longest
10712                  (value_type (arg1),
10713                   value_as_long (arg1) - value_as_long (arg2)));
10714       if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10715         return (value_from_longest
10716                  (value_type (arg2),
10717                   value_as_long (arg1) - value_as_long (arg2)));
10718       if ((ada_is_fixed_point_type (value_type (arg1))
10719            || ada_is_fixed_point_type (value_type (arg2)))
10720           && value_type (arg1) != value_type (arg2))
10721         error (_("Operands of fixed-point subtraction "
10722                  "must have the same type"));
10723       /* Do the substraction, and cast the result to the type of the first
10724          argument.  We cannot cast the result to a reference type, so if
10725          ARG1 is a reference type, find its underlying type.  */
10726       type = value_type (arg1);
10727       while (TYPE_CODE (type) == TYPE_CODE_REF)
10728         type = TYPE_TARGET_TYPE (type);
10729       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10730       return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
10731
10732     case BINOP_MUL:
10733     case BINOP_DIV:
10734     case BINOP_REM:
10735     case BINOP_MOD:
10736       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10737       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10738       if (noside == EVAL_SKIP)
10739         goto nosideret;
10740       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10741         {
10742           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10743           return value_zero (value_type (arg1), not_lval);
10744         }
10745       else
10746         {
10747           type = builtin_type (exp->gdbarch)->builtin_double;
10748           if (ada_is_fixed_point_type (value_type (arg1)))
10749             arg1 = cast_from_fixed (type, arg1);
10750           if (ada_is_fixed_point_type (value_type (arg2)))
10751             arg2 = cast_from_fixed (type, arg2);
10752           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10753           return ada_value_binop (arg1, arg2, op);
10754         }
10755
10756     case BINOP_EQUAL:
10757     case BINOP_NOTEQUAL:
10758       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10759       arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
10760       if (noside == EVAL_SKIP)
10761         goto nosideret;
10762       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10763         tem = 0;
10764       else
10765         {
10766           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10767           tem = ada_value_equal (arg1, arg2);
10768         }
10769       if (op == BINOP_NOTEQUAL)
10770         tem = !tem;
10771       type = language_bool_type (exp->language_defn, exp->gdbarch);
10772       return value_from_longest (type, (LONGEST) tem);
10773
10774     case UNOP_NEG:
10775       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10776       if (noside == EVAL_SKIP)
10777         goto nosideret;
10778       else if (ada_is_fixed_point_type (value_type (arg1)))
10779         return value_cast (value_type (arg1), value_neg (arg1));
10780       else
10781         {
10782           unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10783           return value_neg (arg1);
10784         }
10785
10786     case BINOP_LOGICAL_AND:
10787     case BINOP_LOGICAL_OR:
10788     case UNOP_LOGICAL_NOT:
10789       {
10790         struct value *val;
10791
10792         *pos -= 1;
10793         val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10794         type = language_bool_type (exp->language_defn, exp->gdbarch);
10795         return value_cast (type, val);
10796       }
10797
10798     case BINOP_BITWISE_AND:
10799     case BINOP_BITWISE_IOR:
10800     case BINOP_BITWISE_XOR:
10801       {
10802         struct value *val;
10803
10804         arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10805         *pos = pc;
10806         val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10807
10808         return value_cast (value_type (arg1), val);
10809       }
10810
10811     case OP_VAR_VALUE:
10812       *pos -= 1;
10813
10814       if (noside == EVAL_SKIP)
10815         {
10816           *pos += 4;
10817           goto nosideret;
10818         }
10819
10820       if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
10821         /* Only encountered when an unresolved symbol occurs in a
10822            context other than a function call, in which case, it is
10823            invalid.  */
10824         error (_("Unexpected unresolved symbol, %s, during evaluation"),
10825                SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
10826
10827       if (noside == EVAL_AVOID_SIDE_EFFECTS)
10828         {
10829           type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
10830           /* Check to see if this is a tagged type.  We also need to handle
10831              the case where the type is a reference to a tagged type, but
10832              we have to be careful to exclude pointers to tagged types.
10833              The latter should be shown as usual (as a pointer), whereas
10834              a reference should mostly be transparent to the user.  */
10835           if (ada_is_tagged_type (type, 0)
10836               || (TYPE_CODE (type) == TYPE_CODE_REF
10837                   && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10838             {
10839               /* Tagged types are a little special in the fact that the real
10840                  type is dynamic and can only be determined by inspecting the
10841                  object's tag.  This means that we need to get the object's
10842                  value first (EVAL_NORMAL) and then extract the actual object
10843                  type from its tag.
10844
10845                  Note that we cannot skip the final step where we extract
10846                  the object type from its tag, because the EVAL_NORMAL phase
10847                  results in dynamic components being resolved into fixed ones.
10848                  This can cause problems when trying to print the type
10849                  description of tagged types whose parent has a dynamic size:
10850                  We use the type name of the "_parent" component in order
10851                  to print the name of the ancestor type in the type description.
10852                  If that component had a dynamic size, the resolution into
10853                  a fixed type would result in the loss of that type name,
10854                  thus preventing us from printing the name of the ancestor
10855                  type in the type description.  */
10856               arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10857
10858               if (TYPE_CODE (type) != TYPE_CODE_REF)
10859                 {
10860                   struct type *actual_type;
10861
10862                   actual_type = type_from_tag (ada_value_tag (arg1));
10863                   if (actual_type == NULL)
10864                     /* If, for some reason, we were unable to determine
10865                        the actual type from the tag, then use the static
10866                        approximation that we just computed as a fallback.
10867                        This can happen if the debugging information is
10868                        incomplete, for instance.  */
10869                     actual_type = type;
10870                   return value_zero (actual_type, not_lval);
10871                 }
10872               else
10873                 {
10874                   /* In the case of a ref, ada_coerce_ref takes care
10875                      of determining the actual type.  But the evaluation
10876                      should return a ref as it should be valid to ask
10877                      for its address; so rebuild a ref after coerce.  */
10878                   arg1 = ada_coerce_ref (arg1);
10879                   return value_ref (arg1, TYPE_CODE_REF);
10880                 }
10881             }
10882
10883           /* Records and unions for which GNAT encodings have been
10884              generated need to be statically fixed as well.
10885              Otherwise, non-static fixing produces a type where
10886              all dynamic properties are removed, which prevents "ptype"
10887              from being able to completely describe the type.
10888              For instance, a case statement in a variant record would be
10889              replaced by the relevant components based on the actual
10890              value of the discriminants.  */
10891           if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10892                && dynamic_template_type (type) != NULL)
10893               || (TYPE_CODE (type) == TYPE_CODE_UNION
10894                   && ada_find_parallel_type (type, "___XVU") != NULL))
10895             {
10896               *pos += 4;
10897               return value_zero (to_static_fixed_type (type), not_lval);
10898             }
10899         }
10900
10901       arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10902       return ada_to_fixed_value (arg1);
10903
10904     case OP_FUNCALL:
10905       (*pos) += 2;
10906
10907       /* Allocate arg vector, including space for the function to be
10908          called in argvec[0] and a terminating NULL.  */
10909       nargs = longest_to_int (exp->elts[pc + 1].longconst);
10910       argvec = XALLOCAVEC (struct value *, nargs + 2);
10911
10912       if (exp->elts[*pos].opcode == OP_VAR_VALUE
10913           && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
10914         error (_("Unexpected unresolved symbol, %s, during evaluation"),
10915                SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10916       else
10917         {
10918           for (tem = 0; tem <= nargs; tem += 1)
10919             argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10920           argvec[tem] = 0;
10921
10922           if (noside == EVAL_SKIP)
10923             goto nosideret;
10924         }
10925
10926       if (ada_is_constrained_packed_array_type
10927           (desc_base_type (value_type (argvec[0]))))
10928         argvec[0] = ada_coerce_to_simple_array (argvec[0]);
10929       else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10930                && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10931         /* This is a packed array that has already been fixed, and
10932            therefore already coerced to a simple array.  Nothing further
10933            to do.  */
10934         ;
10935       else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10936         {
10937           /* Make sure we dereference references so that all the code below
10938              feels like it's really handling the referenced value.  Wrapping
10939              types (for alignment) may be there, so make sure we strip them as
10940              well.  */
10941           argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10942         }
10943       else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10944                && VALUE_LVAL (argvec[0]) == lval_memory)
10945         argvec[0] = value_addr (argvec[0]);
10946
10947       type = ada_check_typedef (value_type (argvec[0]));
10948
10949       /* Ada allows us to implicitly dereference arrays when subscripting
10950          them.  So, if this is an array typedef (encoding use for array
10951          access types encoded as fat pointers), strip it now.  */
10952       if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10953         type = ada_typedef_target_type (type);
10954
10955       if (TYPE_CODE (type) == TYPE_CODE_PTR)
10956         {
10957           switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
10958             {
10959             case TYPE_CODE_FUNC:
10960               type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10961               break;
10962             case TYPE_CODE_ARRAY:
10963               break;
10964             case TYPE_CODE_STRUCT:
10965               if (noside != EVAL_AVOID_SIDE_EFFECTS)
10966                 argvec[0] = ada_value_ind (argvec[0]);
10967               type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10968               break;
10969             default:
10970               error (_("cannot subscript or call something of type `%s'"),
10971                      ada_type_name (value_type (argvec[0])));
10972               break;
10973             }
10974         }
10975
10976       switch (TYPE_CODE (type))
10977         {
10978         case TYPE_CODE_FUNC:
10979           if (noside == EVAL_AVOID_SIDE_EFFECTS)
10980             {
10981               if (TYPE_TARGET_TYPE (type) == NULL)
10982                 error_call_unknown_return_type (NULL);
10983               return allocate_value (TYPE_TARGET_TYPE (type));
10984             }
10985           return call_function_by_hand (argvec[0], NULL, nargs, argvec + 1);
10986         case TYPE_CODE_INTERNAL_FUNCTION:
10987           if (noside == EVAL_AVOID_SIDE_EFFECTS)
10988             /* We don't know anything about what the internal
10989                function might return, but we have to return
10990                something.  */
10991             return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10992                                not_lval);
10993           else
10994             return call_internal_function (exp->gdbarch, exp->language_defn,
10995                                            argvec[0], nargs, argvec + 1);
10996
10997         case TYPE_CODE_STRUCT:
10998           {
10999             int arity;
11000
11001             arity = ada_array_arity (type);
11002             type = ada_array_element_type (type, nargs);
11003             if (type == NULL)
11004               error (_("cannot subscript or call a record"));
11005             if (arity != nargs)
11006               error (_("wrong number of subscripts; expecting %d"), arity);
11007             if (noside == EVAL_AVOID_SIDE_EFFECTS)
11008               return value_zero (ada_aligned_type (type), lval_memory);
11009             return
11010               unwrap_value (ada_value_subscript
11011                             (argvec[0], nargs, argvec + 1));
11012           }
11013         case TYPE_CODE_ARRAY:
11014           if (noside == EVAL_AVOID_SIDE_EFFECTS)
11015             {
11016               type = ada_array_element_type (type, nargs);
11017               if (type == NULL)
11018                 error (_("element type of array unknown"));
11019               else
11020                 return value_zero (ada_aligned_type (type), lval_memory);
11021             }
11022           return
11023             unwrap_value (ada_value_subscript
11024                           (ada_coerce_to_simple_array (argvec[0]),
11025                            nargs, argvec + 1));
11026         case TYPE_CODE_PTR:     /* Pointer to array */
11027           if (noside == EVAL_AVOID_SIDE_EFFECTS)
11028             {
11029               type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
11030               type = ada_array_element_type (type, nargs);
11031               if (type == NULL)
11032                 error (_("element type of array unknown"));
11033               else
11034                 return value_zero (ada_aligned_type (type), lval_memory);
11035             }
11036           return
11037             unwrap_value (ada_value_ptr_subscript (argvec[0],
11038                                                    nargs, argvec + 1));
11039
11040         default:
11041           error (_("Attempt to index or call something other than an "
11042                    "array or function"));
11043         }
11044
11045     case TERNOP_SLICE:
11046       {
11047         struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11048         struct value *low_bound_val =
11049           evaluate_subexp (NULL_TYPE, exp, pos, noside);
11050         struct value *high_bound_val =
11051           evaluate_subexp (NULL_TYPE, exp, pos, noside);
11052         LONGEST low_bound;
11053         LONGEST high_bound;
11054
11055         low_bound_val = coerce_ref (low_bound_val);
11056         high_bound_val = coerce_ref (high_bound_val);
11057         low_bound = value_as_long (low_bound_val);
11058         high_bound = value_as_long (high_bound_val);
11059
11060         if (noside == EVAL_SKIP)
11061           goto nosideret;
11062
11063         /* If this is a reference to an aligner type, then remove all
11064            the aligners.  */
11065         if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11066             && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
11067           TYPE_TARGET_TYPE (value_type (array)) =
11068             ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
11069
11070         if (ada_is_constrained_packed_array_type (value_type (array)))
11071           error (_("cannot slice a packed array"));
11072
11073         /* If this is a reference to an array or an array lvalue,
11074            convert to a pointer.  */
11075         if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11076             || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
11077                 && VALUE_LVAL (array) == lval_memory))
11078           array = value_addr (array);
11079
11080         if (noside == EVAL_AVOID_SIDE_EFFECTS
11081             && ada_is_array_descriptor_type (ada_check_typedef
11082                                              (value_type (array))))
11083           return empty_array (ada_type_of_array (array, 0), low_bound);
11084
11085         array = ada_coerce_to_simple_array_ptr (array);
11086
11087         /* If we have more than one level of pointer indirection,
11088            dereference the value until we get only one level.  */
11089         while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
11090                && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
11091                      == TYPE_CODE_PTR))
11092           array = value_ind (array);
11093
11094         /* Make sure we really do have an array type before going further,
11095            to avoid a SEGV when trying to get the index type or the target
11096            type later down the road if the debug info generated by
11097            the compiler is incorrect or incomplete.  */
11098         if (!ada_is_simple_array_type (value_type (array)))
11099           error (_("cannot take slice of non-array"));
11100
11101         if (TYPE_CODE (ada_check_typedef (value_type (array)))
11102             == TYPE_CODE_PTR)
11103           {
11104             struct type *type0 = ada_check_typedef (value_type (array));
11105
11106             if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
11107               return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
11108             else
11109               {
11110                 struct type *arr_type0 =
11111                   to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
11112
11113                 return ada_value_slice_from_ptr (array, arr_type0,
11114                                                  longest_to_int (low_bound),
11115                                                  longest_to_int (high_bound));
11116               }
11117           }
11118         else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11119           return array;
11120         else if (high_bound < low_bound)
11121           return empty_array (value_type (array), low_bound);
11122         else
11123           return ada_value_slice (array, longest_to_int (low_bound),
11124                                   longest_to_int (high_bound));
11125       }
11126
11127     case UNOP_IN_RANGE:
11128       (*pos) += 2;
11129       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11130       type = check_typedef (exp->elts[pc + 1].type);
11131
11132       if (noside == EVAL_SKIP)
11133         goto nosideret;
11134
11135       switch (TYPE_CODE (type))
11136         {
11137         default:
11138           lim_warning (_("Membership test incompletely implemented; "
11139                          "always returns true"));
11140           type = language_bool_type (exp->language_defn, exp->gdbarch);
11141           return value_from_longest (type, (LONGEST) 1);
11142
11143         case TYPE_CODE_RANGE:
11144           arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
11145           arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
11146           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11147           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11148           type = language_bool_type (exp->language_defn, exp->gdbarch);
11149           return
11150             value_from_longest (type,
11151                                 (value_less (arg1, arg3)
11152                                  || value_equal (arg1, arg3))
11153                                 && (value_less (arg2, arg1)
11154                                     || value_equal (arg2, arg1)));
11155         }
11156
11157     case BINOP_IN_BOUNDS:
11158       (*pos) += 2;
11159       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11160       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11161
11162       if (noside == EVAL_SKIP)
11163         goto nosideret;
11164
11165       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11166         {
11167           type = language_bool_type (exp->language_defn, exp->gdbarch);
11168           return value_zero (type, not_lval);
11169         }
11170
11171       tem = longest_to_int (exp->elts[pc + 1].longconst);
11172
11173       type = ada_index_type (value_type (arg2), tem, "range");
11174       if (!type)
11175         type = value_type (arg1);
11176
11177       arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
11178       arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
11179
11180       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11181       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11182       type = language_bool_type (exp->language_defn, exp->gdbarch);
11183       return
11184         value_from_longest (type,
11185                             (value_less (arg1, arg3)
11186                              || value_equal (arg1, arg3))
11187                             && (value_less (arg2, arg1)
11188                                 || value_equal (arg2, arg1)));
11189
11190     case TERNOP_IN_RANGE:
11191       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11192       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11193       arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11194
11195       if (noside == EVAL_SKIP)
11196         goto nosideret;
11197
11198       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11199       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11200       type = language_bool_type (exp->language_defn, exp->gdbarch);
11201       return
11202         value_from_longest (type,
11203                             (value_less (arg1, arg3)
11204                              || value_equal (arg1, arg3))
11205                             && (value_less (arg2, arg1)
11206                                 || value_equal (arg2, arg1)));
11207
11208     case OP_ATR_FIRST:
11209     case OP_ATR_LAST:
11210     case OP_ATR_LENGTH:
11211       {
11212         struct type *type_arg;
11213
11214         if (exp->elts[*pos].opcode == OP_TYPE)
11215           {
11216             evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11217             arg1 = NULL;
11218             type_arg = check_typedef (exp->elts[pc + 2].type);
11219           }
11220         else
11221           {
11222             arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11223             type_arg = NULL;
11224           }
11225
11226         if (exp->elts[*pos].opcode != OP_LONG)
11227           error (_("Invalid operand to '%s"), ada_attribute_name (op));
11228         tem = longest_to_int (exp->elts[*pos + 2].longconst);
11229         *pos += 4;
11230
11231         if (noside == EVAL_SKIP)
11232           goto nosideret;
11233
11234         if (type_arg == NULL)
11235           {
11236             arg1 = ada_coerce_ref (arg1);
11237
11238             if (ada_is_constrained_packed_array_type (value_type (arg1)))
11239               arg1 = ada_coerce_to_simple_array (arg1);
11240
11241             if (op == OP_ATR_LENGTH)
11242               type = builtin_type (exp->gdbarch)->builtin_int;
11243             else
11244               {
11245                 type = ada_index_type (value_type (arg1), tem,
11246                                        ada_attribute_name (op));
11247                 if (type == NULL)
11248                   type = builtin_type (exp->gdbarch)->builtin_int;
11249               }
11250
11251             if (noside == EVAL_AVOID_SIDE_EFFECTS)
11252               return allocate_value (type);
11253
11254             switch (op)
11255               {
11256               default:          /* Should never happen.  */
11257                 error (_("unexpected attribute encountered"));
11258               case OP_ATR_FIRST:
11259                 return value_from_longest
11260                         (type, ada_array_bound (arg1, tem, 0));
11261               case OP_ATR_LAST:
11262                 return value_from_longest
11263                         (type, ada_array_bound (arg1, tem, 1));
11264               case OP_ATR_LENGTH:
11265                 return value_from_longest
11266                         (type, ada_array_length (arg1, tem));
11267               }
11268           }
11269         else if (discrete_type_p (type_arg))
11270           {
11271             struct type *range_type;
11272             const char *name = ada_type_name (type_arg);
11273
11274             range_type = NULL;
11275             if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
11276               range_type = to_fixed_range_type (type_arg, NULL);
11277             if (range_type == NULL)
11278               range_type = type_arg;
11279             switch (op)
11280               {
11281               default:
11282                 error (_("unexpected attribute encountered"));
11283               case OP_ATR_FIRST:
11284                 return value_from_longest 
11285                   (range_type, ada_discrete_type_low_bound (range_type));
11286               case OP_ATR_LAST:
11287                 return value_from_longest
11288                   (range_type, ada_discrete_type_high_bound (range_type));
11289               case OP_ATR_LENGTH:
11290                 error (_("the 'length attribute applies only to array types"));
11291               }
11292           }
11293         else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
11294           error (_("unimplemented type attribute"));
11295         else
11296           {
11297             LONGEST low, high;
11298
11299             if (ada_is_constrained_packed_array_type (type_arg))
11300               type_arg = decode_constrained_packed_array_type (type_arg);
11301
11302             if (op == OP_ATR_LENGTH)
11303               type = builtin_type (exp->gdbarch)->builtin_int;
11304             else
11305               {
11306                 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11307                 if (type == NULL)
11308                   type = builtin_type (exp->gdbarch)->builtin_int;
11309               }
11310
11311             if (noside == EVAL_AVOID_SIDE_EFFECTS)
11312               return allocate_value (type);
11313
11314             switch (op)
11315               {
11316               default:
11317                 error (_("unexpected attribute encountered"));
11318               case OP_ATR_FIRST:
11319                 low = ada_array_bound_from_type (type_arg, tem, 0);
11320                 return value_from_longest (type, low);
11321               case OP_ATR_LAST:
11322                 high = ada_array_bound_from_type (type_arg, tem, 1);
11323                 return value_from_longest (type, high);
11324               case OP_ATR_LENGTH:
11325                 low = ada_array_bound_from_type (type_arg, tem, 0);
11326                 high = ada_array_bound_from_type (type_arg, tem, 1);
11327                 return value_from_longest (type, high - low + 1);
11328               }
11329           }
11330       }
11331
11332     case OP_ATR_TAG:
11333       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11334       if (noside == EVAL_SKIP)
11335         goto nosideret;
11336
11337       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11338         return value_zero (ada_tag_type (arg1), not_lval);
11339
11340       return ada_value_tag (arg1);
11341
11342     case OP_ATR_MIN:
11343     case OP_ATR_MAX:
11344       evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11345       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11346       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11347       if (noside == EVAL_SKIP)
11348         goto nosideret;
11349       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11350         return value_zero (value_type (arg1), not_lval);
11351       else
11352         {
11353           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11354           return value_binop (arg1, arg2,
11355                               op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11356         }
11357
11358     case OP_ATR_MODULUS:
11359       {
11360         struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
11361
11362         evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11363         if (noside == EVAL_SKIP)
11364           goto nosideret;
11365
11366         if (!ada_is_modular_type (type_arg))
11367           error (_("'modulus must be applied to modular type"));
11368
11369         return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11370                                    ada_modulus (type_arg));
11371       }
11372
11373
11374     case OP_ATR_POS:
11375       evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11376       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11377       if (noside == EVAL_SKIP)
11378         goto nosideret;
11379       type = builtin_type (exp->gdbarch)->builtin_int;
11380       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11381         return value_zero (type, not_lval);
11382       else
11383         return value_pos_atr (type, arg1);
11384
11385     case OP_ATR_SIZE:
11386       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11387       type = value_type (arg1);
11388
11389       /* If the argument is a reference, then dereference its type, since
11390          the user is really asking for the size of the actual object,
11391          not the size of the pointer.  */
11392       if (TYPE_CODE (type) == TYPE_CODE_REF)
11393         type = TYPE_TARGET_TYPE (type);
11394
11395       if (noside == EVAL_SKIP)
11396         goto nosideret;
11397       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11398         return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
11399       else
11400         return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
11401                                    TARGET_CHAR_BIT * TYPE_LENGTH (type));
11402
11403     case OP_ATR_VAL:
11404       evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11405       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11406       type = exp->elts[pc + 2].type;
11407       if (noside == EVAL_SKIP)
11408         goto nosideret;
11409       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11410         return value_zero (type, not_lval);
11411       else
11412         return value_val_atr (type, arg1);
11413
11414     case BINOP_EXP:
11415       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11416       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11417       if (noside == EVAL_SKIP)
11418         goto nosideret;
11419       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11420         return value_zero (value_type (arg1), not_lval);
11421       else
11422         {
11423           /* For integer exponentiation operations,
11424              only promote the first argument.  */
11425           if (is_integral_type (value_type (arg2)))
11426             unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11427           else
11428             binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11429
11430           return value_binop (arg1, arg2, op);
11431         }
11432
11433     case UNOP_PLUS:
11434       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11435       if (noside == EVAL_SKIP)
11436         goto nosideret;
11437       else
11438         return arg1;
11439
11440     case UNOP_ABS:
11441       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11442       if (noside == EVAL_SKIP)
11443         goto nosideret;
11444       unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11445       if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
11446         return value_neg (arg1);
11447       else
11448         return arg1;
11449
11450     case UNOP_IND:
11451       preeval_pos = *pos;
11452       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11453       if (noside == EVAL_SKIP)
11454         goto nosideret;
11455       type = ada_check_typedef (value_type (arg1));
11456       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11457         {
11458           if (ada_is_array_descriptor_type (type))
11459             /* GDB allows dereferencing GNAT array descriptors.  */
11460             {
11461               struct type *arrType = ada_type_of_array (arg1, 0);
11462
11463               if (arrType == NULL)
11464                 error (_("Attempt to dereference null array pointer."));
11465               return value_at_lazy (arrType, 0);
11466             }
11467           else if (TYPE_CODE (type) == TYPE_CODE_PTR
11468                    || TYPE_CODE (type) == TYPE_CODE_REF
11469                    /* In C you can dereference an array to get the 1st elt.  */
11470                    || TYPE_CODE (type) == TYPE_CODE_ARRAY)
11471             {
11472             /* As mentioned in the OP_VAR_VALUE case, tagged types can
11473                only be determined by inspecting the object's tag.
11474                This means that we need to evaluate completely the
11475                expression in order to get its type.  */
11476
11477               if ((TYPE_CODE (type) == TYPE_CODE_REF
11478                    || TYPE_CODE (type) == TYPE_CODE_PTR)
11479                   && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11480                 {
11481                   arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11482                                           EVAL_NORMAL);
11483                   type = value_type (ada_value_ind (arg1));
11484                 }
11485               else
11486                 {
11487                   type = to_static_fixed_type
11488                     (ada_aligned_type
11489                      (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11490                 }
11491               ada_ensure_varsize_limit (type);
11492               return value_zero (type, lval_memory);
11493             }
11494           else if (TYPE_CODE (type) == TYPE_CODE_INT)
11495             {
11496               /* GDB allows dereferencing an int.  */
11497               if (expect_type == NULL)
11498                 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11499                                    lval_memory);
11500               else
11501                 {
11502                   expect_type = 
11503                     to_static_fixed_type (ada_aligned_type (expect_type));
11504                   return value_zero (expect_type, lval_memory);
11505                 }
11506             }
11507           else
11508             error (_("Attempt to take contents of a non-pointer value."));
11509         }
11510       arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for??  */
11511       type = ada_check_typedef (value_type (arg1));
11512
11513       if (TYPE_CODE (type) == TYPE_CODE_INT)
11514           /* GDB allows dereferencing an int.  If we were given
11515              the expect_type, then use that as the target type.
11516              Otherwise, assume that the target type is an int.  */
11517         {
11518           if (expect_type != NULL)
11519             return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11520                                               arg1));
11521           else
11522             return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11523                                   (CORE_ADDR) value_as_address (arg1));
11524         }
11525
11526       if (ada_is_array_descriptor_type (type))
11527         /* GDB allows dereferencing GNAT array descriptors.  */
11528         return ada_coerce_to_simple_array (arg1);
11529       else
11530         return ada_value_ind (arg1);
11531
11532     case STRUCTOP_STRUCT:
11533       tem = longest_to_int (exp->elts[pc + 1].longconst);
11534       (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
11535       preeval_pos = *pos;
11536       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11537       if (noside == EVAL_SKIP)
11538         goto nosideret;
11539       if (noside == EVAL_AVOID_SIDE_EFFECTS)
11540         {
11541           struct type *type1 = value_type (arg1);
11542
11543           if (ada_is_tagged_type (type1, 1))
11544             {
11545               type = ada_lookup_struct_elt_type (type1,
11546                                                  &exp->elts[pc + 2].string,
11547                                                  1, 1);
11548
11549               /* If the field is not found, check if it exists in the
11550                  extension of this object's type. This means that we
11551                  need to evaluate completely the expression.  */
11552
11553               if (type == NULL)
11554                 {
11555                   arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11556                                           EVAL_NORMAL);
11557                   arg1 = ada_value_struct_elt (arg1,
11558                                                &exp->elts[pc + 2].string,
11559                                                0);
11560                   arg1 = unwrap_value (arg1);
11561                   type = value_type (ada_to_fixed_value (arg1));
11562                 }
11563             }
11564           else
11565             type =
11566               ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
11567                                           0);
11568
11569           return value_zero (ada_aligned_type (type), lval_memory);
11570         }
11571       else
11572         {
11573           arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11574           arg1 = unwrap_value (arg1);
11575           return ada_to_fixed_value (arg1);
11576         }
11577
11578     case OP_TYPE:
11579       /* The value is not supposed to be used.  This is here to make it
11580          easier to accommodate expressions that contain types.  */
11581       (*pos) += 2;
11582       if (noside == EVAL_SKIP)
11583         goto nosideret;
11584       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11585         return allocate_value (exp->elts[pc + 1].type);
11586       else
11587         error (_("Attempt to use a type name as an expression"));
11588
11589     case OP_AGGREGATE:
11590     case OP_CHOICES:
11591     case OP_OTHERS:
11592     case OP_DISCRETE_RANGE:
11593     case OP_POSITIONAL:
11594     case OP_NAME:
11595       if (noside == EVAL_NORMAL)
11596         switch (op) 
11597           {
11598           case OP_NAME:
11599             error (_("Undefined name, ambiguous name, or renaming used in "
11600                      "component association: %s."), &exp->elts[pc+2].string);
11601           case OP_AGGREGATE:
11602             error (_("Aggregates only allowed on the right of an assignment"));
11603           default:
11604             internal_error (__FILE__, __LINE__,
11605                             _("aggregate apparently mangled"));
11606           }
11607
11608       ada_forward_operator_length (exp, pc, &oplen, &nargs);
11609       *pos += oplen - 1;
11610       for (tem = 0; tem < nargs; tem += 1) 
11611         ada_evaluate_subexp (NULL, exp, pos, noside);
11612       goto nosideret;
11613     }
11614
11615 nosideret:
11616   return eval_skip_value (exp);
11617 }
11618 \f
11619
11620                                 /* Fixed point */
11621
11622 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11623    type name that encodes the 'small and 'delta information.
11624    Otherwise, return NULL.  */
11625
11626 static const char *
11627 fixed_type_info (struct type *type)
11628 {
11629   const char *name = ada_type_name (type);
11630   enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11631
11632   if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11633     {
11634       const char *tail = strstr (name, "___XF_");
11635
11636       if (tail == NULL)
11637         return NULL;
11638       else
11639         return tail + 5;
11640     }
11641   else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11642     return fixed_type_info (TYPE_TARGET_TYPE (type));
11643   else
11644     return NULL;
11645 }
11646
11647 /* Returns non-zero iff TYPE represents an Ada fixed-point type.  */
11648
11649 int
11650 ada_is_fixed_point_type (struct type *type)
11651 {
11652   return fixed_type_info (type) != NULL;
11653 }
11654
11655 /* Return non-zero iff TYPE represents a System.Address type.  */
11656
11657 int
11658 ada_is_system_address_type (struct type *type)
11659 {
11660   return (TYPE_NAME (type)
11661           && strcmp (TYPE_NAME (type), "system__address") == 0);
11662 }
11663
11664 /* Assuming that TYPE is the representation of an Ada fixed-point
11665    type, return the target floating-point type to be used to represent
11666    of this type during internal computation.  */
11667
11668 static struct type *
11669 ada_scaling_type (struct type *type)
11670 {
11671   return builtin_type (get_type_arch (type))->builtin_long_double;
11672 }
11673
11674 /* Assuming that TYPE is the representation of an Ada fixed-point
11675    type, return its delta, or NULL if the type is malformed and the
11676    delta cannot be determined.  */
11677
11678 struct value *
11679 ada_delta (struct type *type)
11680 {
11681   const char *encoding = fixed_type_info (type);
11682   struct type *scale_type = ada_scaling_type (type);
11683
11684   long long num, den;
11685
11686   if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11687     return nullptr;
11688   else
11689     return value_binop (value_from_longest (scale_type, num),
11690                         value_from_longest (scale_type, den), BINOP_DIV);
11691 }
11692
11693 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11694    factor ('SMALL value) associated with the type.  */
11695
11696 struct value *
11697 ada_scaling_factor (struct type *type)
11698 {
11699   const char *encoding = fixed_type_info (type);
11700   struct type *scale_type = ada_scaling_type (type);
11701
11702   long long num0, den0, num1, den1;
11703   int n;
11704
11705   n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
11706               &num0, &den0, &num1, &den1);
11707
11708   if (n < 2)
11709     return value_from_longest (scale_type, 1);
11710   else if (n == 4)
11711     return value_binop (value_from_longest (scale_type, num1),
11712                         value_from_longest (scale_type, den1), BINOP_DIV);
11713   else
11714     return value_binop (value_from_longest (scale_type, num0),
11715                         value_from_longest (scale_type, den0), BINOP_DIV);
11716 }
11717
11718 \f
11719
11720                                 /* Range types */
11721
11722 /* Scan STR beginning at position K for a discriminant name, and
11723    return the value of that discriminant field of DVAL in *PX.  If
11724    PNEW_K is not null, put the position of the character beyond the
11725    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
11726    not alter *PX and *PNEW_K if unsuccessful.  */
11727
11728 static int
11729 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11730                     int *pnew_k)
11731 {
11732   static char *bound_buffer = NULL;
11733   static size_t bound_buffer_len = 0;
11734   const char *pstart, *pend, *bound;
11735   struct value *bound_val;
11736
11737   if (dval == NULL || str == NULL || str[k] == '\0')
11738     return 0;
11739
11740   pstart = str + k;
11741   pend = strstr (pstart, "__");
11742   if (pend == NULL)
11743     {
11744       bound = pstart;
11745       k += strlen (bound);
11746     }
11747   else
11748     {
11749       int len = pend - pstart;
11750
11751       /* Strip __ and beyond.  */
11752       GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11753       strncpy (bound_buffer, pstart, len);
11754       bound_buffer[len] = '\0';
11755
11756       bound = bound_buffer;
11757       k = pend - str;
11758     }
11759
11760   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11761   if (bound_val == NULL)
11762     return 0;
11763
11764   *px = value_as_long (bound_val);
11765   if (pnew_k != NULL)
11766     *pnew_k = k;
11767   return 1;
11768 }
11769
11770 /* Value of variable named NAME in the current environment.  If
11771    no such variable found, then if ERR_MSG is null, returns 0, and
11772    otherwise causes an error with message ERR_MSG.  */
11773
11774 static struct value *
11775 get_var_value (const char *name, const char *err_msg)
11776 {
11777   lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
11778
11779   struct block_symbol *syms;
11780   int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11781                                              get_selected_block (0),
11782                                              VAR_DOMAIN, &syms, 1);
11783   struct cleanup *old_chain = make_cleanup (xfree, syms);
11784
11785   if (nsyms != 1)
11786     {
11787       do_cleanups (old_chain);
11788       if (err_msg == NULL)
11789         return 0;
11790       else
11791         error (("%s"), err_msg);
11792     }
11793
11794   struct value *result = value_of_variable (syms[0].symbol, syms[0].block);
11795   do_cleanups (old_chain);
11796   return result;
11797 }
11798
11799 /* Value of integer variable named NAME in the current environment.
11800    If no such variable is found, returns false.  Otherwise, sets VALUE
11801    to the variable's value and returns true.  */
11802
11803 bool
11804 get_int_var_value (const char *name, LONGEST &value)
11805 {
11806   struct value *var_val = get_var_value (name, 0);
11807
11808   if (var_val == 0)
11809     return false;
11810
11811   value = value_as_long (var_val);
11812   return true;
11813 }
11814
11815
11816 /* Return a range type whose base type is that of the range type named
11817    NAME in the current environment, and whose bounds are calculated
11818    from NAME according to the GNAT range encoding conventions.
11819    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
11820    corresponding range type from debug information; fall back to using it
11821    if symbol lookup fails.  If a new type must be created, allocate it
11822    like ORIG_TYPE was.  The bounds information, in general, is encoded
11823    in NAME, the base type given in the named range type.  */
11824
11825 static struct type *
11826 to_fixed_range_type (struct type *raw_type, struct value *dval)
11827 {
11828   const char *name;
11829   struct type *base_type;
11830   const char *subtype_info;
11831
11832   gdb_assert (raw_type != NULL);
11833   gdb_assert (TYPE_NAME (raw_type) != NULL);
11834
11835   if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
11836     base_type = TYPE_TARGET_TYPE (raw_type);
11837   else
11838     base_type = raw_type;
11839
11840   name = TYPE_NAME (raw_type);
11841   subtype_info = strstr (name, "___XD");
11842   if (subtype_info == NULL)
11843     {
11844       LONGEST L = ada_discrete_type_low_bound (raw_type);
11845       LONGEST U = ada_discrete_type_high_bound (raw_type);
11846
11847       if (L < INT_MIN || U > INT_MAX)
11848         return raw_type;
11849       else
11850         return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11851                                          L, U);
11852     }
11853   else
11854     {
11855       static char *name_buf = NULL;
11856       static size_t name_len = 0;
11857       int prefix_len = subtype_info - name;
11858       LONGEST L, U;
11859       struct type *type;
11860       const char *bounds_str;
11861       int n;
11862
11863       GROW_VECT (name_buf, name_len, prefix_len + 5);
11864       strncpy (name_buf, name, prefix_len);
11865       name_buf[prefix_len] = '\0';
11866
11867       subtype_info += 5;
11868       bounds_str = strchr (subtype_info, '_');
11869       n = 1;
11870
11871       if (*subtype_info == 'L')
11872         {
11873           if (!ada_scan_number (bounds_str, n, &L, &n)
11874               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11875             return raw_type;
11876           if (bounds_str[n] == '_')
11877             n += 2;
11878           else if (bounds_str[n] == '.')     /* FIXME? SGI Workshop kludge.  */
11879             n += 1;
11880           subtype_info += 1;
11881         }
11882       else
11883         {
11884           strcpy (name_buf + prefix_len, "___L");
11885           if (!get_int_var_value (name_buf, L))
11886             {
11887               lim_warning (_("Unknown lower bound, using 1."));
11888               L = 1;
11889             }
11890         }
11891
11892       if (*subtype_info == 'U')
11893         {
11894           if (!ada_scan_number (bounds_str, n, &U, &n)
11895               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11896             return raw_type;
11897         }
11898       else
11899         {
11900           strcpy (name_buf + prefix_len, "___U");
11901           if (!get_int_var_value (name_buf, U))
11902             {
11903               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11904               U = L;
11905             }
11906         }
11907
11908       type = create_static_range_type (alloc_type_copy (raw_type),
11909                                        base_type, L, U);
11910       /* create_static_range_type alters the resulting type's length
11911          to match the size of the base_type, which is not what we want.
11912          Set it back to the original range type's length.  */
11913       TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11914       TYPE_NAME (type) = name;
11915       return type;
11916     }
11917 }
11918
11919 /* True iff NAME is the name of a range type.  */
11920
11921 int
11922 ada_is_range_type_name (const char *name)
11923 {
11924   return (name != NULL && strstr (name, "___XD"));
11925 }
11926 \f
11927
11928                                 /* Modular types */
11929
11930 /* True iff TYPE is an Ada modular type.  */
11931
11932 int
11933 ada_is_modular_type (struct type *type)
11934 {
11935   struct type *subranged_type = get_base_type (type);
11936
11937   return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
11938           && TYPE_CODE (subranged_type) == TYPE_CODE_INT
11939           && TYPE_UNSIGNED (subranged_type));
11940 }
11941
11942 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
11943
11944 ULONGEST
11945 ada_modulus (struct type *type)
11946 {
11947   return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
11948 }
11949 \f
11950
11951 /* Ada exception catchpoint support:
11952    ---------------------------------
11953
11954    We support 3 kinds of exception catchpoints:
11955      . catchpoints on Ada exceptions
11956      . catchpoints on unhandled Ada exceptions
11957      . catchpoints on failed assertions
11958
11959    Exceptions raised during failed assertions, or unhandled exceptions
11960    could perfectly be caught with the general catchpoint on Ada exceptions.
11961    However, we can easily differentiate these two special cases, and having
11962    the option to distinguish these two cases from the rest can be useful
11963    to zero-in on certain situations.
11964
11965    Exception catchpoints are a specialized form of breakpoint,
11966    since they rely on inserting breakpoints inside known routines
11967    of the GNAT runtime.  The implementation therefore uses a standard
11968    breakpoint structure of the BP_BREAKPOINT type, but with its own set
11969    of breakpoint_ops.
11970
11971    Support in the runtime for exception catchpoints have been changed
11972    a few times already, and these changes affect the implementation
11973    of these catchpoints.  In order to be able to support several
11974    variants of the runtime, we use a sniffer that will determine
11975    the runtime variant used by the program being debugged.  */
11976
11977 /* Ada's standard exceptions.
11978
11979    The Ada 83 standard also defined Numeric_Error.  But there so many
11980    situations where it was unclear from the Ada 83 Reference Manual
11981    (RM) whether Constraint_Error or Numeric_Error should be raised,
11982    that the ARG (Ada Rapporteur Group) eventually issued a Binding
11983    Interpretation saying that anytime the RM says that Numeric_Error
11984    should be raised, the implementation may raise Constraint_Error.
11985    Ada 95 went one step further and pretty much removed Numeric_Error
11986    from the list of standard exceptions (it made it a renaming of
11987    Constraint_Error, to help preserve compatibility when compiling
11988    an Ada83 compiler). As such, we do not include Numeric_Error from
11989    this list of standard exceptions.  */
11990
11991 static const char *standard_exc[] = {
11992   "constraint_error",
11993   "program_error",
11994   "storage_error",
11995   "tasking_error"
11996 };
11997
11998 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11999
12000 /* A structure that describes how to support exception catchpoints
12001    for a given executable.  */
12002
12003 struct exception_support_info
12004 {
12005    /* The name of the symbol to break on in order to insert
12006       a catchpoint on exceptions.  */
12007    const char *catch_exception_sym;
12008
12009    /* The name of the symbol to break on in order to insert
12010       a catchpoint on unhandled exceptions.  */
12011    const char *catch_exception_unhandled_sym;
12012
12013    /* The name of the symbol to break on in order to insert
12014       a catchpoint on failed assertions.  */
12015    const char *catch_assert_sym;
12016
12017    /* The name of the symbol to break on in order to insert
12018       a catchpoint on exception handling.  */
12019    const char *catch_handlers_sym;
12020
12021    /* Assuming that the inferior just triggered an unhandled exception
12022       catchpoint, this function is responsible for returning the address
12023       in inferior memory where the name of that exception is stored.
12024       Return zero if the address could not be computed.  */
12025    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
12026 };
12027
12028 static CORE_ADDR ada_unhandled_exception_name_addr (void);
12029 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
12030
12031 /* The following exception support info structure describes how to
12032    implement exception catchpoints with the latest version of the
12033    Ada runtime (as of 2007-03-06).  */
12034
12035 static const struct exception_support_info default_exception_support_info =
12036 {
12037   "__gnat_debug_raise_exception", /* catch_exception_sym */
12038   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12039   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
12040   "__gnat_begin_handler", /* catch_handlers_sym */
12041   ada_unhandled_exception_name_addr
12042 };
12043
12044 /* The following exception support info structure describes how to
12045    implement exception catchpoints with a slightly older version
12046    of the Ada runtime.  */
12047
12048 static const struct exception_support_info exception_support_info_fallback =
12049 {
12050   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
12051   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12052   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
12053   "__gnat_begin_handler", /* catch_handlers_sym */
12054   ada_unhandled_exception_name_addr_from_raise
12055 };
12056
12057 /* Return nonzero if we can detect the exception support routines
12058    described in EINFO.
12059
12060    This function errors out if an abnormal situation is detected
12061    (for instance, if we find the exception support routines, but
12062    that support is found to be incomplete).  */
12063
12064 static int
12065 ada_has_this_exception_support (const struct exception_support_info *einfo)
12066 {
12067   struct symbol *sym;
12068
12069   /* The symbol we're looking up is provided by a unit in the GNAT runtime
12070      that should be compiled with debugging information.  As a result, we
12071      expect to find that symbol in the symtabs.  */
12072
12073   sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
12074   if (sym == NULL)
12075     {
12076       /* Perhaps we did not find our symbol because the Ada runtime was
12077          compiled without debugging info, or simply stripped of it.
12078          It happens on some GNU/Linux distributions for instance, where
12079          users have to install a separate debug package in order to get
12080          the runtime's debugging info.  In that situation, let the user
12081          know why we cannot insert an Ada exception catchpoint.
12082
12083          Note: Just for the purpose of inserting our Ada exception
12084          catchpoint, we could rely purely on the associated minimal symbol.
12085          But we would be operating in degraded mode anyway, since we are
12086          still lacking the debugging info needed later on to extract
12087          the name of the exception being raised (this name is printed in
12088          the catchpoint message, and is also used when trying to catch
12089          a specific exception).  We do not handle this case for now.  */
12090       struct bound_minimal_symbol msym
12091         = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
12092
12093       if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
12094         error (_("Your Ada runtime appears to be missing some debugging "
12095                  "information.\nCannot insert Ada exception catchpoint "
12096                  "in this configuration."));
12097
12098       return 0;
12099     }
12100
12101   /* Make sure that the symbol we found corresponds to a function.  */
12102
12103   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12104     error (_("Symbol \"%s\" is not a function (class = %d)"),
12105            SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
12106
12107   return 1;
12108 }
12109
12110 /* Inspect the Ada runtime and determine which exception info structure
12111    should be used to provide support for exception catchpoints.
12112
12113    This function will always set the per-inferior exception_info,
12114    or raise an error.  */
12115
12116 static void
12117 ada_exception_support_info_sniffer (void)
12118 {
12119   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12120
12121   /* If the exception info is already known, then no need to recompute it.  */
12122   if (data->exception_info != NULL)
12123     return;
12124
12125   /* Check the latest (default) exception support info.  */
12126   if (ada_has_this_exception_support (&default_exception_support_info))
12127     {
12128       data->exception_info = &default_exception_support_info;
12129       return;
12130     }
12131
12132   /* Try our fallback exception suport info.  */
12133   if (ada_has_this_exception_support (&exception_support_info_fallback))
12134     {
12135       data->exception_info = &exception_support_info_fallback;
12136       return;
12137     }
12138
12139   /* Sometimes, it is normal for us to not be able to find the routine
12140      we are looking for.  This happens when the program is linked with
12141      the shared version of the GNAT runtime, and the program has not been
12142      started yet.  Inform the user of these two possible causes if
12143      applicable.  */
12144
12145   if (ada_update_initial_language (language_unknown) != language_ada)
12146     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
12147
12148   /* If the symbol does not exist, then check that the program is
12149      already started, to make sure that shared libraries have been
12150      loaded.  If it is not started, this may mean that the symbol is
12151      in a shared library.  */
12152
12153   if (ptid_get_pid (inferior_ptid) == 0)
12154     error (_("Unable to insert catchpoint. Try to start the program first."));
12155
12156   /* At this point, we know that we are debugging an Ada program and
12157      that the inferior has been started, but we still are not able to
12158      find the run-time symbols.  That can mean that we are in
12159      configurable run time mode, or that a-except as been optimized
12160      out by the linker...  In any case, at this point it is not worth
12161      supporting this feature.  */
12162
12163   error (_("Cannot insert Ada exception catchpoints in this configuration."));
12164 }
12165
12166 /* True iff FRAME is very likely to be that of a function that is
12167    part of the runtime system.  This is all very heuristic, but is
12168    intended to be used as advice as to what frames are uninteresting
12169    to most users.  */
12170
12171 static int
12172 is_known_support_routine (struct frame_info *frame)
12173 {
12174   enum language func_lang;
12175   int i;
12176   const char *fullname;
12177
12178   /* If this code does not have any debugging information (no symtab),
12179      This cannot be any user code.  */
12180
12181   symtab_and_line sal = find_frame_sal (frame);
12182   if (sal.symtab == NULL)
12183     return 1;
12184
12185   /* If there is a symtab, but the associated source file cannot be
12186      located, then assume this is not user code:  Selecting a frame
12187      for which we cannot display the code would not be very helpful
12188      for the user.  This should also take care of case such as VxWorks
12189      where the kernel has some debugging info provided for a few units.  */
12190
12191   fullname = symtab_to_fullname (sal.symtab);
12192   if (access (fullname, R_OK) != 0)
12193     return 1;
12194
12195   /* Check the unit filename againt the Ada runtime file naming.
12196      We also check the name of the objfile against the name of some
12197      known system libraries that sometimes come with debugging info
12198      too.  */
12199
12200   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12201     {
12202       re_comp (known_runtime_file_name_patterns[i]);
12203       if (re_exec (lbasename (sal.symtab->filename)))
12204         return 1;
12205       if (SYMTAB_OBJFILE (sal.symtab) != NULL
12206           && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
12207         return 1;
12208     }
12209
12210   /* Check whether the function is a GNAT-generated entity.  */
12211
12212   gdb::unique_xmalloc_ptr<char> func_name
12213     = find_frame_funname (frame, &func_lang, NULL);
12214   if (func_name == NULL)
12215     return 1;
12216
12217   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12218     {
12219       re_comp (known_auxiliary_function_name_patterns[i]);
12220       if (re_exec (func_name.get ()))
12221         return 1;
12222     }
12223
12224   return 0;
12225 }
12226
12227 /* Find the first frame that contains debugging information and that is not
12228    part of the Ada run-time, starting from FI and moving upward.  */
12229
12230 void
12231 ada_find_printable_frame (struct frame_info *fi)
12232 {
12233   for (; fi != NULL; fi = get_prev_frame (fi))
12234     {
12235       if (!is_known_support_routine (fi))
12236         {
12237           select_frame (fi);
12238           break;
12239         }
12240     }
12241
12242 }
12243
12244 /* Assuming that the inferior just triggered an unhandled exception
12245    catchpoint, return the address in inferior memory where the name
12246    of the exception is stored.
12247    
12248    Return zero if the address could not be computed.  */
12249
12250 static CORE_ADDR
12251 ada_unhandled_exception_name_addr (void)
12252 {
12253   return parse_and_eval_address ("e.full_name");
12254 }
12255
12256 /* Same as ada_unhandled_exception_name_addr, except that this function
12257    should be used when the inferior uses an older version of the runtime,
12258    where the exception name needs to be extracted from a specific frame
12259    several frames up in the callstack.  */
12260
12261 static CORE_ADDR
12262 ada_unhandled_exception_name_addr_from_raise (void)
12263 {
12264   int frame_level;
12265   struct frame_info *fi;
12266   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12267
12268   /* To determine the name of this exception, we need to select
12269      the frame corresponding to RAISE_SYM_NAME.  This frame is
12270      at least 3 levels up, so we simply skip the first 3 frames
12271      without checking the name of their associated function.  */
12272   fi = get_current_frame ();
12273   for (frame_level = 0; frame_level < 3; frame_level += 1)
12274     if (fi != NULL)
12275       fi = get_prev_frame (fi); 
12276
12277   while (fi != NULL)
12278     {
12279       enum language func_lang;
12280
12281       gdb::unique_xmalloc_ptr<char> func_name
12282         = find_frame_funname (fi, &func_lang, NULL);
12283       if (func_name != NULL)
12284         {
12285           if (strcmp (func_name.get (),
12286                       data->exception_info->catch_exception_sym) == 0)
12287             break; /* We found the frame we were looking for...  */
12288           fi = get_prev_frame (fi);
12289         }
12290     }
12291
12292   if (fi == NULL)
12293     return 0;
12294
12295   select_frame (fi);
12296   return parse_and_eval_address ("id.full_name");
12297 }
12298
12299 /* Assuming the inferior just triggered an Ada exception catchpoint
12300    (of any type), return the address in inferior memory where the name
12301    of the exception is stored, if applicable.
12302
12303    Assumes the selected frame is the current frame.
12304
12305    Return zero if the address could not be computed, or if not relevant.  */
12306
12307 static CORE_ADDR
12308 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
12309                            struct breakpoint *b)
12310 {
12311   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12312
12313   switch (ex)
12314     {
12315       case ada_catch_exception:
12316         return (parse_and_eval_address ("e.full_name"));
12317         break;
12318
12319       case ada_catch_exception_unhandled:
12320         return data->exception_info->unhandled_exception_name_addr ();
12321         break;
12322
12323       case ada_catch_handlers:
12324         return 0;  /* The runtimes does not provide access to the exception
12325                       name.  */
12326         break;
12327
12328       case ada_catch_assert:
12329         return 0;  /* Exception name is not relevant in this case.  */
12330         break;
12331
12332       default:
12333         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12334         break;
12335     }
12336
12337   return 0; /* Should never be reached.  */
12338 }
12339
12340 /* Assuming the inferior is stopped at an exception catchpoint,
12341    return the message which was associated to the exception, if
12342    available.  Return NULL if the message could not be retrieved.
12343
12344    Note: The exception message can be associated to an exception
12345    either through the use of the Raise_Exception function, or
12346    more simply (Ada 2005 and later), via:
12347
12348        raise Exception_Name with "exception message";
12349
12350    */
12351
12352 static gdb::unique_xmalloc_ptr<char>
12353 ada_exception_message_1 (void)
12354 {
12355   struct value *e_msg_val;
12356   int e_msg_len;
12357
12358   /* For runtimes that support this feature, the exception message
12359      is passed as an unbounded string argument called "message".  */
12360   e_msg_val = parse_and_eval ("message");
12361   if (e_msg_val == NULL)
12362     return NULL; /* Exception message not supported.  */
12363
12364   e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12365   gdb_assert (e_msg_val != NULL);
12366   e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12367
12368   /* If the message string is empty, then treat it as if there was
12369      no exception message.  */
12370   if (e_msg_len <= 0)
12371     return NULL;
12372
12373   gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12374   read_memory_string (value_address (e_msg_val), e_msg.get (), e_msg_len + 1);
12375   e_msg.get ()[e_msg_len] = '\0';
12376
12377   return e_msg;
12378 }
12379
12380 /* Same as ada_exception_message_1, except that all exceptions are
12381    contained here (returning NULL instead).  */
12382
12383 static gdb::unique_xmalloc_ptr<char>
12384 ada_exception_message (void)
12385 {
12386   gdb::unique_xmalloc_ptr<char> e_msg;
12387
12388   TRY
12389     {
12390       e_msg = ada_exception_message_1 ();
12391     }
12392   CATCH (e, RETURN_MASK_ERROR)
12393     {
12394       e_msg.reset (nullptr);
12395     }
12396   END_CATCH
12397
12398   return e_msg;
12399 }
12400
12401 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12402    any error that ada_exception_name_addr_1 might cause to be thrown.
12403    When an error is intercepted, a warning with the error message is printed,
12404    and zero is returned.  */
12405
12406 static CORE_ADDR
12407 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
12408                          struct breakpoint *b)
12409 {
12410   CORE_ADDR result = 0;
12411
12412   TRY
12413     {
12414       result = ada_exception_name_addr_1 (ex, b);
12415     }
12416
12417   CATCH (e, RETURN_MASK_ERROR)
12418     {
12419       warning (_("failed to get exception name: %s"), e.message);
12420       return 0;
12421     }
12422   END_CATCH
12423
12424   return result;
12425 }
12426
12427 static std::string ada_exception_catchpoint_cond_string
12428   (const char *excep_string,
12429    enum ada_exception_catchpoint_kind ex);
12430
12431 /* Ada catchpoints.
12432
12433    In the case of catchpoints on Ada exceptions, the catchpoint will
12434    stop the target on every exception the program throws.  When a user
12435    specifies the name of a specific exception, we translate this
12436    request into a condition expression (in text form), and then parse
12437    it into an expression stored in each of the catchpoint's locations.
12438    We then use this condition to check whether the exception that was
12439    raised is the one the user is interested in.  If not, then the
12440    target is resumed again.  We store the name of the requested
12441    exception, in order to be able to re-set the condition expression
12442    when symbols change.  */
12443
12444 /* An instance of this type is used to represent an Ada catchpoint
12445    breakpoint location.  */
12446
12447 class ada_catchpoint_location : public bp_location
12448 {
12449 public:
12450   ada_catchpoint_location (const bp_location_ops *ops, breakpoint *owner)
12451     : bp_location (ops, owner)
12452   {}
12453
12454   /* The condition that checks whether the exception that was raised
12455      is the specific exception the user specified on catchpoint
12456      creation.  */
12457   expression_up excep_cond_expr;
12458 };
12459
12460 /* Implement the DTOR method in the bp_location_ops structure for all
12461    Ada exception catchpoint kinds.  */
12462
12463 static void
12464 ada_catchpoint_location_dtor (struct bp_location *bl)
12465 {
12466   struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12467
12468   al->excep_cond_expr.reset ();
12469 }
12470
12471 /* The vtable to be used in Ada catchpoint locations.  */
12472
12473 static const struct bp_location_ops ada_catchpoint_location_ops =
12474 {
12475   ada_catchpoint_location_dtor
12476 };
12477
12478 /* An instance of this type is used to represent an Ada catchpoint.  */
12479
12480 struct ada_catchpoint : public breakpoint
12481 {
12482   ~ada_catchpoint () override;
12483
12484   /* The name of the specific exception the user specified.  */
12485   char *excep_string;
12486 };
12487
12488 /* Parse the exception condition string in the context of each of the
12489    catchpoint's locations, and store them for later evaluation.  */
12490
12491 static void
12492 create_excep_cond_exprs (struct ada_catchpoint *c,
12493                          enum ada_exception_catchpoint_kind ex)
12494 {
12495   struct bp_location *bl;
12496
12497   /* Nothing to do if there's no specific exception to catch.  */
12498   if (c->excep_string == NULL)
12499     return;
12500
12501   /* Same if there are no locations... */
12502   if (c->loc == NULL)
12503     return;
12504
12505   /* Compute the condition expression in text form, from the specific
12506      expection we want to catch.  */
12507   std::string cond_string
12508     = ada_exception_catchpoint_cond_string (c->excep_string, ex);
12509
12510   /* Iterate over all the catchpoint's locations, and parse an
12511      expression for each.  */
12512   for (bl = c->loc; bl != NULL; bl = bl->next)
12513     {
12514       struct ada_catchpoint_location *ada_loc
12515         = (struct ada_catchpoint_location *) bl;
12516       expression_up exp;
12517
12518       if (!bl->shlib_disabled)
12519         {
12520           const char *s;
12521
12522           s = cond_string.c_str ();
12523           TRY
12524             {
12525               exp = parse_exp_1 (&s, bl->address,
12526                                  block_for_pc (bl->address),
12527                                  0);
12528             }
12529           CATCH (e, RETURN_MASK_ERROR)
12530             {
12531               warning (_("failed to reevaluate internal exception condition "
12532                          "for catchpoint %d: %s"),
12533                        c->number, e.message);
12534             }
12535           END_CATCH
12536         }
12537
12538       ada_loc->excep_cond_expr = std::move (exp);
12539     }
12540 }
12541
12542 /* ada_catchpoint destructor.  */
12543
12544 ada_catchpoint::~ada_catchpoint ()
12545 {
12546   xfree (this->excep_string);
12547 }
12548
12549 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12550    structure for all exception catchpoint kinds.  */
12551
12552 static struct bp_location *
12553 allocate_location_exception (enum ada_exception_catchpoint_kind ex,
12554                              struct breakpoint *self)
12555 {
12556   return new ada_catchpoint_location (&ada_catchpoint_location_ops, self);
12557 }
12558
12559 /* Implement the RE_SET method in the breakpoint_ops structure for all
12560    exception catchpoint kinds.  */
12561
12562 static void
12563 re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
12564 {
12565   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12566
12567   /* Call the base class's method.  This updates the catchpoint's
12568      locations.  */
12569   bkpt_breakpoint_ops.re_set (b);
12570
12571   /* Reparse the exception conditional expressions.  One for each
12572      location.  */
12573   create_excep_cond_exprs (c, ex);
12574 }
12575
12576 /* Returns true if we should stop for this breakpoint hit.  If the
12577    user specified a specific exception, we only want to cause a stop
12578    if the program thrown that exception.  */
12579
12580 static int
12581 should_stop_exception (const struct bp_location *bl)
12582 {
12583   struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12584   const struct ada_catchpoint_location *ada_loc
12585     = (const struct ada_catchpoint_location *) bl;
12586   int stop;
12587
12588   /* With no specific exception, should always stop.  */
12589   if (c->excep_string == NULL)
12590     return 1;
12591
12592   if (ada_loc->excep_cond_expr == NULL)
12593     {
12594       /* We will have a NULL expression if back when we were creating
12595          the expressions, this location's had failed to parse.  */
12596       return 1;
12597     }
12598
12599   stop = 1;
12600   TRY
12601     {
12602       struct value *mark;
12603
12604       mark = value_mark ();
12605       stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12606       value_free_to_mark (mark);
12607     }
12608   CATCH (ex, RETURN_MASK_ALL)
12609     {
12610       exception_fprintf (gdb_stderr, ex,
12611                          _("Error in testing exception condition:\n"));
12612     }
12613   END_CATCH
12614
12615   return stop;
12616 }
12617
12618 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12619    for all exception catchpoint kinds.  */
12620
12621 static void
12622 check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
12623 {
12624   bs->stop = should_stop_exception (bs->bp_location_at);
12625 }
12626
12627 /* Implement the PRINT_IT method in the breakpoint_ops structure
12628    for all exception catchpoint kinds.  */
12629
12630 static enum print_stop_action
12631 print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
12632 {
12633   struct ui_out *uiout = current_uiout;
12634   struct breakpoint *b = bs->breakpoint_at;
12635
12636   annotate_catchpoint (b->number);
12637
12638   if (uiout->is_mi_like_p ())
12639     {
12640       uiout->field_string ("reason",
12641                            async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12642       uiout->field_string ("disp", bpdisp_text (b->disposition));
12643     }
12644
12645   uiout->text (b->disposition == disp_del
12646                ? "\nTemporary catchpoint " : "\nCatchpoint ");
12647   uiout->field_int ("bkptno", b->number);
12648   uiout->text (", ");
12649
12650   /* ada_exception_name_addr relies on the selected frame being the
12651      current frame.  Need to do this here because this function may be
12652      called more than once when printing a stop, and below, we'll
12653      select the first frame past the Ada run-time (see
12654      ada_find_printable_frame).  */
12655   select_frame (get_current_frame ());
12656
12657   switch (ex)
12658     {
12659       case ada_catch_exception:
12660       case ada_catch_exception_unhandled:
12661       case ada_catch_handlers:
12662         {
12663           const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12664           char exception_name[256];
12665
12666           if (addr != 0)
12667             {
12668               read_memory (addr, (gdb_byte *) exception_name,
12669                            sizeof (exception_name) - 1);
12670               exception_name [sizeof (exception_name) - 1] = '\0';
12671             }
12672           else
12673             {
12674               /* For some reason, we were unable to read the exception
12675                  name.  This could happen if the Runtime was compiled
12676                  without debugging info, for instance.  In that case,
12677                  just replace the exception name by the generic string
12678                  "exception" - it will read as "an exception" in the
12679                  notification we are about to print.  */
12680               memcpy (exception_name, "exception", sizeof ("exception"));
12681             }
12682           /* In the case of unhandled exception breakpoints, we print
12683              the exception name as "unhandled EXCEPTION_NAME", to make
12684              it clearer to the user which kind of catchpoint just got
12685              hit.  We used ui_out_text to make sure that this extra
12686              info does not pollute the exception name in the MI case.  */
12687           if (ex == ada_catch_exception_unhandled)
12688             uiout->text ("unhandled ");
12689           uiout->field_string ("exception-name", exception_name);
12690         }
12691         break;
12692       case ada_catch_assert:
12693         /* In this case, the name of the exception is not really
12694            important.  Just print "failed assertion" to make it clearer
12695            that his program just hit an assertion-failure catchpoint.
12696            We used ui_out_text because this info does not belong in
12697            the MI output.  */
12698         uiout->text ("failed assertion");
12699         break;
12700     }
12701
12702   gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
12703   if (exception_message != NULL)
12704     {
12705       uiout->text (" (");
12706       uiout->field_string ("exception-message", exception_message.get ());
12707       uiout->text (")");
12708     }
12709
12710   uiout->text (" at ");
12711   ada_find_printable_frame (get_current_frame ());
12712
12713   return PRINT_SRC_AND_LOC;
12714 }
12715
12716 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12717    for all exception catchpoint kinds.  */
12718
12719 static void
12720 print_one_exception (enum ada_exception_catchpoint_kind ex,
12721                      struct breakpoint *b, struct bp_location **last_loc)
12722
12723   struct ui_out *uiout = current_uiout;
12724   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12725   struct value_print_options opts;
12726
12727   get_user_print_options (&opts);
12728   if (opts.addressprint)
12729     {
12730       annotate_field (4);
12731       uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
12732     }
12733
12734   annotate_field (5);
12735   *last_loc = b->loc;
12736   switch (ex)
12737     {
12738       case ada_catch_exception:
12739         if (c->excep_string != NULL)
12740           {
12741             char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12742
12743             uiout->field_string ("what", msg);
12744             xfree (msg);
12745           }
12746         else
12747           uiout->field_string ("what", "all Ada exceptions");
12748         
12749         break;
12750
12751       case ada_catch_exception_unhandled:
12752         uiout->field_string ("what", "unhandled Ada exceptions");
12753         break;
12754       
12755       case ada_catch_handlers:
12756         if (c->excep_string != NULL)
12757           {
12758             uiout->field_fmt ("what",
12759                               _("`%s' Ada exception handlers"),
12760                               c->excep_string);
12761           }
12762         else
12763           uiout->field_string ("what", "all Ada exceptions handlers");
12764         break;
12765
12766       case ada_catch_assert:
12767         uiout->field_string ("what", "failed Ada assertions");
12768         break;
12769
12770       default:
12771         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12772         break;
12773     }
12774 }
12775
12776 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12777    for all exception catchpoint kinds.  */
12778
12779 static void
12780 print_mention_exception (enum ada_exception_catchpoint_kind ex,
12781                          struct breakpoint *b)
12782 {
12783   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12784   struct ui_out *uiout = current_uiout;
12785
12786   uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
12787                                                  : _("Catchpoint "));
12788   uiout->field_int ("bkptno", b->number);
12789   uiout->text (": ");
12790
12791   switch (ex)
12792     {
12793       case ada_catch_exception:
12794         if (c->excep_string != NULL)
12795           {
12796             std::string info = string_printf (_("`%s' Ada exception"),
12797                                               c->excep_string);
12798             uiout->text (info.c_str ());
12799           }
12800         else
12801           uiout->text (_("all Ada exceptions"));
12802         break;
12803
12804       case ada_catch_exception_unhandled:
12805         uiout->text (_("unhandled Ada exceptions"));
12806         break;
12807
12808       case ada_catch_handlers:
12809         if (c->excep_string != NULL)
12810           {
12811             std::string info
12812               = string_printf (_("`%s' Ada exception handlers"),
12813                                c->excep_string);
12814             uiout->text (info.c_str ());
12815           }
12816         else
12817           uiout->text (_("all Ada exceptions handlers"));
12818         break;
12819
12820       case ada_catch_assert:
12821         uiout->text (_("failed Ada assertions"));
12822         break;
12823
12824       default:
12825         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12826         break;
12827     }
12828 }
12829
12830 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12831    for all exception catchpoint kinds.  */
12832
12833 static void
12834 print_recreate_exception (enum ada_exception_catchpoint_kind ex,
12835                           struct breakpoint *b, struct ui_file *fp)
12836 {
12837   struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12838
12839   switch (ex)
12840     {
12841       case ada_catch_exception:
12842         fprintf_filtered (fp, "catch exception");
12843         if (c->excep_string != NULL)
12844           fprintf_filtered (fp, " %s", c->excep_string);
12845         break;
12846
12847       case ada_catch_exception_unhandled:
12848         fprintf_filtered (fp, "catch exception unhandled");
12849         break;
12850
12851       case ada_catch_handlers:
12852         fprintf_filtered (fp, "catch handlers");
12853         break;
12854
12855       case ada_catch_assert:
12856         fprintf_filtered (fp, "catch assert");
12857         break;
12858
12859       default:
12860         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12861     }
12862   print_recreate_thread (b, fp);
12863 }
12864
12865 /* Virtual table for "catch exception" breakpoints.  */
12866
12867 static struct bp_location *
12868 allocate_location_catch_exception (struct breakpoint *self)
12869 {
12870   return allocate_location_exception (ada_catch_exception, self);
12871 }
12872
12873 static void
12874 re_set_catch_exception (struct breakpoint *b)
12875 {
12876   re_set_exception (ada_catch_exception, b);
12877 }
12878
12879 static void
12880 check_status_catch_exception (bpstat bs)
12881 {
12882   check_status_exception (ada_catch_exception, bs);
12883 }
12884
12885 static enum print_stop_action
12886 print_it_catch_exception (bpstat bs)
12887 {
12888   return print_it_exception (ada_catch_exception, bs);
12889 }
12890
12891 static void
12892 print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
12893 {
12894   print_one_exception (ada_catch_exception, b, last_loc);
12895 }
12896
12897 static void
12898 print_mention_catch_exception (struct breakpoint *b)
12899 {
12900   print_mention_exception (ada_catch_exception, b);
12901 }
12902
12903 static void
12904 print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12905 {
12906   print_recreate_exception (ada_catch_exception, b, fp);
12907 }
12908
12909 static struct breakpoint_ops catch_exception_breakpoint_ops;
12910
12911 /* Virtual table for "catch exception unhandled" breakpoints.  */
12912
12913 static struct bp_location *
12914 allocate_location_catch_exception_unhandled (struct breakpoint *self)
12915 {
12916   return allocate_location_exception (ada_catch_exception_unhandled, self);
12917 }
12918
12919 static void
12920 re_set_catch_exception_unhandled (struct breakpoint *b)
12921 {
12922   re_set_exception (ada_catch_exception_unhandled, b);
12923 }
12924
12925 static void
12926 check_status_catch_exception_unhandled (bpstat bs)
12927 {
12928   check_status_exception (ada_catch_exception_unhandled, bs);
12929 }
12930
12931 static enum print_stop_action
12932 print_it_catch_exception_unhandled (bpstat bs)
12933 {
12934   return print_it_exception (ada_catch_exception_unhandled, bs);
12935 }
12936
12937 static void
12938 print_one_catch_exception_unhandled (struct breakpoint *b,
12939                                      struct bp_location **last_loc)
12940 {
12941   print_one_exception (ada_catch_exception_unhandled, b, last_loc);
12942 }
12943
12944 static void
12945 print_mention_catch_exception_unhandled (struct breakpoint *b)
12946 {
12947   print_mention_exception (ada_catch_exception_unhandled, b);
12948 }
12949
12950 static void
12951 print_recreate_catch_exception_unhandled (struct breakpoint *b,
12952                                           struct ui_file *fp)
12953 {
12954   print_recreate_exception (ada_catch_exception_unhandled, b, fp);
12955 }
12956
12957 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
12958
12959 /* Virtual table for "catch assert" breakpoints.  */
12960
12961 static struct bp_location *
12962 allocate_location_catch_assert (struct breakpoint *self)
12963 {
12964   return allocate_location_exception (ada_catch_assert, self);
12965 }
12966
12967 static void
12968 re_set_catch_assert (struct breakpoint *b)
12969 {
12970   re_set_exception (ada_catch_assert, b);
12971 }
12972
12973 static void
12974 check_status_catch_assert (bpstat bs)
12975 {
12976   check_status_exception (ada_catch_assert, bs);
12977 }
12978
12979 static enum print_stop_action
12980 print_it_catch_assert (bpstat bs)
12981 {
12982   return print_it_exception (ada_catch_assert, bs);
12983 }
12984
12985 static void
12986 print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
12987 {
12988   print_one_exception (ada_catch_assert, b, last_loc);
12989 }
12990
12991 static void
12992 print_mention_catch_assert (struct breakpoint *b)
12993 {
12994   print_mention_exception (ada_catch_assert, b);
12995 }
12996
12997 static void
12998 print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12999 {
13000   print_recreate_exception (ada_catch_assert, b, fp);
13001 }
13002
13003 static struct breakpoint_ops catch_assert_breakpoint_ops;
13004
13005 /* Virtual table for "catch handlers" breakpoints.  */
13006
13007 static struct bp_location *
13008 allocate_location_catch_handlers (struct breakpoint *self)
13009 {
13010   return allocate_location_exception (ada_catch_handlers, self);
13011 }
13012
13013 static void
13014 re_set_catch_handlers (struct breakpoint *b)
13015 {
13016   re_set_exception (ada_catch_handlers, b);
13017 }
13018
13019 static void
13020 check_status_catch_handlers (bpstat bs)
13021 {
13022   check_status_exception (ada_catch_handlers, bs);
13023 }
13024
13025 static enum print_stop_action
13026 print_it_catch_handlers (bpstat bs)
13027 {
13028   return print_it_exception (ada_catch_handlers, bs);
13029 }
13030
13031 static void
13032 print_one_catch_handlers (struct breakpoint *b,
13033                           struct bp_location **last_loc)
13034 {
13035   print_one_exception (ada_catch_handlers, b, last_loc);
13036 }
13037
13038 static void
13039 print_mention_catch_handlers (struct breakpoint *b)
13040 {
13041   print_mention_exception (ada_catch_handlers, b);
13042 }
13043
13044 static void
13045 print_recreate_catch_handlers (struct breakpoint *b,
13046                                struct ui_file *fp)
13047 {
13048   print_recreate_exception (ada_catch_handlers, b, fp);
13049 }
13050
13051 static struct breakpoint_ops catch_handlers_breakpoint_ops;
13052
13053 /* Return a newly allocated copy of the first space-separated token
13054    in ARGSP, and then adjust ARGSP to point immediately after that
13055    token.
13056
13057    Return NULL if ARGPS does not contain any more tokens.  */
13058
13059 static char *
13060 ada_get_next_arg (const char **argsp)
13061 {
13062   const char *args = *argsp;
13063   const char *end;
13064   char *result;
13065
13066   args = skip_spaces (args);
13067   if (args[0] == '\0')
13068     return NULL; /* No more arguments.  */
13069   
13070   /* Find the end of the current argument.  */
13071
13072   end = skip_to_space (args);
13073
13074   /* Adjust ARGSP to point to the start of the next argument.  */
13075
13076   *argsp = end;
13077
13078   /* Make a copy of the current argument and return it.  */
13079
13080   result = (char *) xmalloc (end - args + 1);
13081   strncpy (result, args, end - args);
13082   result[end - args] = '\0';
13083   
13084   return result;
13085 }
13086
13087 /* Split the arguments specified in a "catch exception" command.  
13088    Set EX to the appropriate catchpoint type.
13089    Set EXCEP_STRING to the name of the specific exception if
13090    specified by the user.
13091    IS_CATCH_HANDLERS_CMD: True if the arguments are for a
13092    "catch handlers" command.  False otherwise.
13093    If a condition is found at the end of the arguments, the condition
13094    expression is stored in COND_STRING (memory must be deallocated
13095    after use).  Otherwise COND_STRING is set to NULL.  */
13096
13097 static void
13098 catch_ada_exception_command_split (const char *args,
13099                                    bool is_catch_handlers_cmd,
13100                                    enum ada_exception_catchpoint_kind *ex,
13101                                    char **excep_string,
13102                                    std::string &cond_string)
13103 {
13104   struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
13105   char *exception_name;
13106   char *cond = NULL;
13107
13108   exception_name = ada_get_next_arg (&args);
13109   if (exception_name != NULL && strcmp (exception_name, "if") == 0)
13110     {
13111       /* This is not an exception name; this is the start of a condition
13112          expression for a catchpoint on all exceptions.  So, "un-get"
13113          this token, and set exception_name to NULL.  */
13114       xfree (exception_name);
13115       exception_name = NULL;
13116       args -= 2;
13117     }
13118   make_cleanup (xfree, exception_name);
13119
13120   /* Check to see if we have a condition.  */
13121
13122   args = skip_spaces (args);
13123   if (startswith (args, "if")
13124       && (isspace (args[2]) || args[2] == '\0'))
13125     {
13126       args += 2;
13127       args = skip_spaces (args);
13128
13129       if (args[0] == '\0')
13130         error (_("Condition missing after `if' keyword"));
13131       cond = xstrdup (args);
13132       make_cleanup (xfree, cond);
13133
13134       args += strlen (args);
13135     }
13136
13137   /* Check that we do not have any more arguments.  Anything else
13138      is unexpected.  */
13139
13140   if (args[0] != '\0')
13141     error (_("Junk at end of expression"));
13142
13143   discard_cleanups (old_chain);
13144
13145   if (is_catch_handlers_cmd)
13146     {
13147       /* Catch handling of exceptions.  */
13148       *ex = ada_catch_handlers;
13149       *excep_string = exception_name;
13150     }
13151   else if (exception_name == NULL)
13152     {
13153       /* Catch all exceptions.  */
13154       *ex = ada_catch_exception;
13155       *excep_string = NULL;
13156     }
13157   else if (strcmp (exception_name, "unhandled") == 0)
13158     {
13159       /* Catch unhandled exceptions.  */
13160       *ex = ada_catch_exception_unhandled;
13161       *excep_string = NULL;
13162     }
13163   else
13164     {
13165       /* Catch a specific exception.  */
13166       *ex = ada_catch_exception;
13167       *excep_string = exception_name;
13168     }
13169   if (cond != NULL)
13170     cond_string.assign (cond);
13171 }
13172
13173 /* Return the name of the symbol on which we should break in order to
13174    implement a catchpoint of the EX kind.  */
13175
13176 static const char *
13177 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
13178 {
13179   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
13180
13181   gdb_assert (data->exception_info != NULL);
13182
13183   switch (ex)
13184     {
13185       case ada_catch_exception:
13186         return (data->exception_info->catch_exception_sym);
13187         break;
13188       case ada_catch_exception_unhandled:
13189         return (data->exception_info->catch_exception_unhandled_sym);
13190         break;
13191       case ada_catch_assert:
13192         return (data->exception_info->catch_assert_sym);
13193         break;
13194       case ada_catch_handlers:
13195         return (data->exception_info->catch_handlers_sym);
13196         break;
13197       default:
13198         internal_error (__FILE__, __LINE__,
13199                         _("unexpected catchpoint kind (%d)"), ex);
13200     }
13201 }
13202
13203 /* Return the breakpoint ops "virtual table" used for catchpoints
13204    of the EX kind.  */
13205
13206 static const struct breakpoint_ops *
13207 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
13208 {
13209   switch (ex)
13210     {
13211       case ada_catch_exception:
13212         return (&catch_exception_breakpoint_ops);
13213         break;
13214       case ada_catch_exception_unhandled:
13215         return (&catch_exception_unhandled_breakpoint_ops);
13216         break;
13217       case ada_catch_assert:
13218         return (&catch_assert_breakpoint_ops);
13219         break;
13220       case ada_catch_handlers:
13221         return (&catch_handlers_breakpoint_ops);
13222         break;
13223       default:
13224         internal_error (__FILE__, __LINE__,
13225                         _("unexpected catchpoint kind (%d)"), ex);
13226     }
13227 }
13228
13229 /* Return the condition that will be used to match the current exception
13230    being raised with the exception that the user wants to catch.  This
13231    assumes that this condition is used when the inferior just triggered
13232    an exception catchpoint.
13233    EX: the type of catchpoints used for catching Ada exceptions.  */
13234
13235 static std::string
13236 ada_exception_catchpoint_cond_string (const char *excep_string,
13237                                       enum ada_exception_catchpoint_kind ex)
13238 {
13239   int i;
13240   bool is_standard_exc = false;
13241   std::string result;
13242
13243   if (ex == ada_catch_handlers)
13244     {
13245       /* For exception handlers catchpoints, the condition string does
13246          not use the same parameter as for the other exceptions.  */
13247       result = ("long_integer (GNAT_GCC_exception_Access"
13248                 "(gcc_exception).all.occurrence.id)");
13249     }
13250   else
13251     result = "long_integer (e)";
13252
13253   /* The standard exceptions are a special case.  They are defined in
13254      runtime units that have been compiled without debugging info; if
13255      EXCEP_STRING is the not-fully-qualified name of a standard
13256      exception (e.g. "constraint_error") then, during the evaluation
13257      of the condition expression, the symbol lookup on this name would
13258      *not* return this standard exception.  The catchpoint condition
13259      may then be set only on user-defined exceptions which have the
13260      same not-fully-qualified name (e.g. my_package.constraint_error).
13261
13262      To avoid this unexcepted behavior, these standard exceptions are
13263      systematically prefixed by "standard".  This means that "catch
13264      exception constraint_error" is rewritten into "catch exception
13265      standard.constraint_error".
13266
13267      If an exception named contraint_error is defined in another package of
13268      the inferior program, then the only way to specify this exception as a
13269      breakpoint condition is to use its fully-qualified named:
13270      e.g. my_package.constraint_error.  */
13271
13272   for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
13273     {
13274       if (strcmp (standard_exc [i], excep_string) == 0)
13275         {
13276           is_standard_exc = true;
13277           break;
13278         }
13279     }
13280
13281   result += " = ";
13282
13283   if (is_standard_exc)
13284     string_appendf (result, "long_integer (&standard.%s)", excep_string);
13285   else
13286     string_appendf (result, "long_integer (&%s)", excep_string);
13287
13288   return result;
13289 }
13290
13291 /* Return the symtab_and_line that should be used to insert an exception
13292    catchpoint of the TYPE kind.
13293
13294    EXCEP_STRING should contain the name of a specific exception that
13295    the catchpoint should catch, or NULL otherwise.
13296
13297    ADDR_STRING returns the name of the function where the real
13298    breakpoint that implements the catchpoints is set, depending on the
13299    type of catchpoint we need to create.  */
13300
13301 static struct symtab_and_line
13302 ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
13303                    const char **addr_string, const struct breakpoint_ops **ops)
13304 {
13305   const char *sym_name;
13306   struct symbol *sym;
13307
13308   /* First, find out which exception support info to use.  */
13309   ada_exception_support_info_sniffer ();
13310
13311   /* Then lookup the function on which we will break in order to catch
13312      the Ada exceptions requested by the user.  */
13313   sym_name = ada_exception_sym_name (ex);
13314   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
13315
13316   /* We can assume that SYM is not NULL at this stage.  If the symbol
13317      did not exist, ada_exception_support_info_sniffer would have
13318      raised an exception.
13319
13320      Also, ada_exception_support_info_sniffer should have already
13321      verified that SYM is a function symbol.  */
13322   gdb_assert (sym != NULL);
13323   gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
13324
13325   /* Set ADDR_STRING.  */
13326   *addr_string = xstrdup (sym_name);
13327
13328   /* Set OPS.  */
13329   *ops = ada_exception_breakpoint_ops (ex);
13330
13331   return find_function_start_sal (sym, 1);
13332 }
13333
13334 /* Create an Ada exception catchpoint.
13335
13336    EX_KIND is the kind of exception catchpoint to be created.
13337
13338    If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
13339    for all exceptions.  Otherwise, EXCEPT_STRING indicates the name
13340    of the exception to which this catchpoint applies.  When not NULL,
13341    the string must be allocated on the heap, and its deallocation
13342    is no longer the responsibility of the caller.
13343
13344    COND_STRING, if not NULL, is the catchpoint condition.  This string
13345    must be allocated on the heap, and its deallocation is no longer
13346    the responsibility of the caller.
13347
13348    TEMPFLAG, if nonzero, means that the underlying breakpoint
13349    should be temporary.
13350
13351    FROM_TTY is the usual argument passed to all commands implementations.  */
13352
13353 void
13354 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
13355                                  enum ada_exception_catchpoint_kind ex_kind,
13356                                  char *excep_string,
13357                                  const std::string &cond_string,
13358                                  int tempflag,
13359                                  int disabled,
13360                                  int from_tty)
13361 {
13362   const char *addr_string = NULL;
13363   const struct breakpoint_ops *ops = NULL;
13364   struct symtab_and_line sal
13365     = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
13366
13367   std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
13368   init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string,
13369                                  ops, tempflag, disabled, from_tty);
13370   c->excep_string = excep_string;
13371   create_excep_cond_exprs (c.get (), ex_kind);
13372   if (!cond_string.empty ())
13373     set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty);
13374   install_breakpoint (0, std::move (c), 1);
13375 }
13376
13377 /* Implement the "catch exception" command.  */
13378
13379 static void
13380 catch_ada_exception_command (const char *arg_entry, int from_tty,
13381                              struct cmd_list_element *command)
13382 {
13383   const char *arg = arg_entry;
13384   struct gdbarch *gdbarch = get_current_arch ();
13385   int tempflag;
13386   enum ada_exception_catchpoint_kind ex_kind;
13387   char *excep_string = NULL;
13388   std::string cond_string;
13389
13390   tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13391
13392   if (!arg)
13393     arg = "";
13394   catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
13395                                      cond_string);
13396   create_ada_exception_catchpoint (gdbarch, ex_kind,
13397                                    excep_string, cond_string,
13398                                    tempflag, 1 /* enabled */,
13399                                    from_tty);
13400 }
13401
13402 /* Implement the "catch handlers" command.  */
13403
13404 static void
13405 catch_ada_handlers_command (const char *arg_entry, int from_tty,
13406                             struct cmd_list_element *command)
13407 {
13408   const char *arg = arg_entry;
13409   struct gdbarch *gdbarch = get_current_arch ();
13410   int tempflag;
13411   enum ada_exception_catchpoint_kind ex_kind;
13412   char *excep_string = NULL;
13413   std::string cond_string;
13414
13415   tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13416
13417   if (!arg)
13418     arg = "";
13419   catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
13420                                      cond_string);
13421   create_ada_exception_catchpoint (gdbarch, ex_kind,
13422                                    excep_string, cond_string,
13423                                    tempflag, 1 /* enabled */,
13424                                    from_tty);
13425 }
13426
13427 /* Split the arguments specified in a "catch assert" command.
13428
13429    ARGS contains the command's arguments (or the empty string if
13430    no arguments were passed).
13431
13432    If ARGS contains a condition, set COND_STRING to that condition
13433    (the memory needs to be deallocated after use).  */
13434
13435 static void
13436 catch_ada_assert_command_split (const char *args, std::string &cond_string)
13437 {
13438   args = skip_spaces (args);
13439
13440   /* Check whether a condition was provided.  */
13441   if (startswith (args, "if")
13442       && (isspace (args[2]) || args[2] == '\0'))
13443     {
13444       args += 2;
13445       args = skip_spaces (args);
13446       if (args[0] == '\0')
13447         error (_("condition missing after `if' keyword"));
13448       cond_string.assign (args);
13449     }
13450
13451   /* Otherwise, there should be no other argument at the end of
13452      the command.  */
13453   else if (args[0] != '\0')
13454     error (_("Junk at end of arguments."));
13455 }
13456
13457 /* Implement the "catch assert" command.  */
13458
13459 static void
13460 catch_assert_command (const char *arg_entry, int from_tty,
13461                       struct cmd_list_element *command)
13462 {
13463   const char *arg = arg_entry;
13464   struct gdbarch *gdbarch = get_current_arch ();
13465   int tempflag;
13466   std::string cond_string;
13467
13468   tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13469
13470   if (!arg)
13471     arg = "";
13472   catch_ada_assert_command_split (arg, cond_string);
13473   create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
13474                                    NULL, cond_string,
13475                                    tempflag, 1 /* enabled */,
13476                                    from_tty);
13477 }
13478
13479 /* Return non-zero if the symbol SYM is an Ada exception object.  */
13480
13481 static int
13482 ada_is_exception_sym (struct symbol *sym)
13483 {
13484   const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
13485
13486   return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13487           && SYMBOL_CLASS (sym) != LOC_BLOCK
13488           && SYMBOL_CLASS (sym) != LOC_CONST
13489           && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13490           && type_name != NULL && strcmp (type_name, "exception") == 0);
13491 }
13492
13493 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13494    Ada exception object.  This matches all exceptions except the ones
13495    defined by the Ada language.  */
13496
13497 static int
13498 ada_is_non_standard_exception_sym (struct symbol *sym)
13499 {
13500   int i;
13501
13502   if (!ada_is_exception_sym (sym))
13503     return 0;
13504
13505   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13506     if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13507       return 0;  /* A standard exception.  */
13508
13509   /* Numeric_Error is also a standard exception, so exclude it.
13510      See the STANDARD_EXC description for more details as to why
13511      this exception is not listed in that array.  */
13512   if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13513     return 0;
13514
13515   return 1;
13516 }
13517
13518 /* A helper function for std::sort, comparing two struct ada_exc_info
13519    objects.
13520
13521    The comparison is determined first by exception name, and then
13522    by exception address.  */
13523
13524 bool
13525 ada_exc_info::operator< (const ada_exc_info &other) const
13526 {
13527   int result;
13528
13529   result = strcmp (name, other.name);
13530   if (result < 0)
13531     return true;
13532   if (result == 0 && addr < other.addr)
13533     return true;
13534   return false;
13535 }
13536
13537 bool
13538 ada_exc_info::operator== (const ada_exc_info &other) const
13539 {
13540   return addr == other.addr && strcmp (name, other.name) == 0;
13541 }
13542
13543 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13544    routine, but keeping the first SKIP elements untouched.
13545
13546    All duplicates are also removed.  */
13547
13548 static void
13549 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
13550                                       int skip)
13551 {
13552   std::sort (exceptions->begin () + skip, exceptions->end ());
13553   exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13554                      exceptions->end ());
13555 }
13556
13557 /* Add all exceptions defined by the Ada standard whose name match
13558    a regular expression.
13559
13560    If PREG is not NULL, then this regexp_t object is used to
13561    perform the symbol name matching.  Otherwise, no name-based
13562    filtering is performed.
13563
13564    EXCEPTIONS is a vector of exceptions to which matching exceptions
13565    gets pushed.  */
13566
13567 static void
13568 ada_add_standard_exceptions (compiled_regex *preg,
13569                              std::vector<ada_exc_info> *exceptions)
13570 {
13571   int i;
13572
13573   for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13574     {
13575       if (preg == NULL
13576           || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
13577         {
13578           struct bound_minimal_symbol msymbol
13579             = ada_lookup_simple_minsym (standard_exc[i]);
13580
13581           if (msymbol.minsym != NULL)
13582             {
13583               struct ada_exc_info info
13584                 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
13585
13586               exceptions->push_back (info);
13587             }
13588         }
13589     }
13590 }
13591
13592 /* Add all Ada exceptions defined locally and accessible from the given
13593    FRAME.
13594
13595    If PREG is not NULL, then this regexp_t object is used to
13596    perform the symbol name matching.  Otherwise, no name-based
13597    filtering is performed.
13598
13599    EXCEPTIONS is a vector of exceptions to which matching exceptions
13600    gets pushed.  */
13601
13602 static void
13603 ada_add_exceptions_from_frame (compiled_regex *preg,
13604                                struct frame_info *frame,
13605                                std::vector<ada_exc_info> *exceptions)
13606 {
13607   const struct block *block = get_frame_block (frame, 0);
13608
13609   while (block != 0)
13610     {
13611       struct block_iterator iter;
13612       struct symbol *sym;
13613
13614       ALL_BLOCK_SYMBOLS (block, iter, sym)
13615         {
13616           switch (SYMBOL_CLASS (sym))
13617             {
13618             case LOC_TYPEDEF:
13619             case LOC_BLOCK:
13620             case LOC_CONST:
13621               break;
13622             default:
13623               if (ada_is_exception_sym (sym))
13624                 {
13625                   struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13626                                               SYMBOL_VALUE_ADDRESS (sym)};
13627
13628                   exceptions->push_back (info);
13629                 }
13630             }
13631         }
13632       if (BLOCK_FUNCTION (block) != NULL)
13633         break;
13634       block = BLOCK_SUPERBLOCK (block);
13635     }
13636 }
13637
13638 /* Return true if NAME matches PREG or if PREG is NULL.  */
13639
13640 static bool
13641 name_matches_regex (const char *name, compiled_regex *preg)
13642 {
13643   return (preg == NULL
13644           || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
13645 }
13646
13647 /* Add all exceptions defined globally whose name name match
13648    a regular expression, excluding standard exceptions.
13649
13650    The reason we exclude standard exceptions is that they need
13651    to be handled separately: Standard exceptions are defined inside
13652    a runtime unit which is normally not compiled with debugging info,
13653    and thus usually do not show up in our symbol search.  However,
13654    if the unit was in fact built with debugging info, we need to
13655    exclude them because they would duplicate the entry we found
13656    during the special loop that specifically searches for those
13657    standard exceptions.
13658
13659    If PREG is not NULL, then this regexp_t object is used to
13660    perform the symbol name matching.  Otherwise, no name-based
13661    filtering is performed.
13662
13663    EXCEPTIONS is a vector of exceptions to which matching exceptions
13664    gets pushed.  */
13665
13666 static void
13667 ada_add_global_exceptions (compiled_regex *preg,
13668                            std::vector<ada_exc_info> *exceptions)
13669 {
13670   struct objfile *objfile;
13671   struct compunit_symtab *s;
13672
13673   /* In Ada, the symbol "search name" is a linkage name, whereas the
13674      regular expression used to do the matching refers to the natural
13675      name.  So match against the decoded name.  */
13676   expand_symtabs_matching (NULL,
13677                            lookup_name_info::match_any (),
13678                            [&] (const char *search_name)
13679                            {
13680                              const char *decoded = ada_decode (search_name);
13681                              return name_matches_regex (decoded, preg);
13682                            },
13683                            NULL,
13684                            VARIABLES_DOMAIN);
13685
13686   ALL_COMPUNITS (objfile, s)
13687     {
13688       const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
13689       int i;
13690
13691       for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13692         {
13693           struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13694           struct block_iterator iter;
13695           struct symbol *sym;
13696
13697           ALL_BLOCK_SYMBOLS (b, iter, sym)
13698             if (ada_is_non_standard_exception_sym (sym)
13699                 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
13700               {
13701                 struct ada_exc_info info
13702                   = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13703
13704                 exceptions->push_back (info);
13705               }
13706         }
13707     }
13708 }
13709
13710 /* Implements ada_exceptions_list with the regular expression passed
13711    as a regex_t, rather than a string.
13712
13713    If not NULL, PREG is used to filter out exceptions whose names
13714    do not match.  Otherwise, all exceptions are listed.  */
13715
13716 static std::vector<ada_exc_info>
13717 ada_exceptions_list_1 (compiled_regex *preg)
13718 {
13719   std::vector<ada_exc_info> result;
13720   int prev_len;
13721
13722   /* First, list the known standard exceptions.  These exceptions
13723      need to be handled separately, as they are usually defined in
13724      runtime units that have been compiled without debugging info.  */
13725
13726   ada_add_standard_exceptions (preg, &result);
13727
13728   /* Next, find all exceptions whose scope is local and accessible
13729      from the currently selected frame.  */
13730
13731   if (has_stack_frames ())
13732     {
13733       prev_len = result.size ();
13734       ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13735                                      &result);
13736       if (result.size () > prev_len)
13737         sort_remove_dups_ada_exceptions_list (&result, prev_len);
13738     }
13739
13740   /* Add all exceptions whose scope is global.  */
13741
13742   prev_len = result.size ();
13743   ada_add_global_exceptions (preg, &result);
13744   if (result.size () > prev_len)
13745     sort_remove_dups_ada_exceptions_list (&result, prev_len);
13746
13747   return result;
13748 }
13749
13750 /* Return a vector of ada_exc_info.
13751
13752    If REGEXP is NULL, all exceptions are included in the result.
13753    Otherwise, it should contain a valid regular expression,
13754    and only the exceptions whose names match that regular expression
13755    are included in the result.
13756
13757    The exceptions are sorted in the following order:
13758      - Standard exceptions (defined by the Ada language), in
13759        alphabetical order;
13760      - Exceptions only visible from the current frame, in
13761        alphabetical order;
13762      - Exceptions whose scope is global, in alphabetical order.  */
13763
13764 std::vector<ada_exc_info>
13765 ada_exceptions_list (const char *regexp)
13766 {
13767   if (regexp == NULL)
13768     return ada_exceptions_list_1 (NULL);
13769
13770   compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13771   return ada_exceptions_list_1 (&reg);
13772 }
13773
13774 /* Implement the "info exceptions" command.  */
13775
13776 static void
13777 info_exceptions_command (const char *regexp, int from_tty)
13778 {
13779   struct gdbarch *gdbarch = get_current_arch ();
13780
13781   std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13782
13783   if (regexp != NULL)
13784     printf_filtered
13785       (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13786   else
13787     printf_filtered (_("All defined Ada exceptions:\n"));
13788
13789   for (const ada_exc_info &info : exceptions)
13790     printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13791 }
13792
13793                                 /* Operators */
13794 /* Information about operators given special treatment in functions
13795    below.  */
13796 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>).  */
13797
13798 #define ADA_OPERATORS \
13799     OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13800     OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13801     OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13802     OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13803     OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13804     OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13805     OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13806     OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13807     OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13808     OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13809     OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13810     OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13811     OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13812     OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13813     OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13814     OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13815     OP_DEFN (OP_OTHERS, 1, 1, 0) \
13816     OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13817     OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13818
13819 static void
13820 ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13821                      int *argsp)
13822 {
13823   switch (exp->elts[pc - 1].opcode)
13824     {
13825     default:
13826       operator_length_standard (exp, pc, oplenp, argsp);
13827       break;
13828
13829 #define OP_DEFN(op, len, args, binop) \
13830     case op: *oplenp = len; *argsp = args; break;
13831       ADA_OPERATORS;
13832 #undef OP_DEFN
13833
13834     case OP_AGGREGATE:
13835       *oplenp = 3;
13836       *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13837       break;
13838
13839     case OP_CHOICES:
13840       *oplenp = 3;
13841       *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13842       break;
13843     }
13844 }
13845
13846 /* Implementation of the exp_descriptor method operator_check.  */
13847
13848 static int
13849 ada_operator_check (struct expression *exp, int pos,
13850                     int (*objfile_func) (struct objfile *objfile, void *data),
13851                     void *data)
13852 {
13853   const union exp_element *const elts = exp->elts;
13854   struct type *type = NULL;
13855
13856   switch (elts[pos].opcode)
13857     {
13858       case UNOP_IN_RANGE:
13859       case UNOP_QUAL:
13860         type = elts[pos + 1].type;
13861         break;
13862
13863       default:
13864         return operator_check_standard (exp, pos, objfile_func, data);
13865     }
13866
13867   /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL.  */
13868
13869   if (type && TYPE_OBJFILE (type)
13870       && (*objfile_func) (TYPE_OBJFILE (type), data))
13871     return 1;
13872
13873   return 0;
13874 }
13875
13876 static const char *
13877 ada_op_name (enum exp_opcode opcode)
13878 {
13879   switch (opcode)
13880     {
13881     default:
13882       return op_name_standard (opcode);
13883
13884 #define OP_DEFN(op, len, args, binop) case op: return #op;
13885       ADA_OPERATORS;
13886 #undef OP_DEFN
13887
13888     case OP_AGGREGATE:
13889       return "OP_AGGREGATE";
13890     case OP_CHOICES:
13891       return "OP_CHOICES";
13892     case OP_NAME:
13893       return "OP_NAME";
13894     }
13895 }
13896
13897 /* As for operator_length, but assumes PC is pointing at the first
13898    element of the operator, and gives meaningful results only for the 
13899    Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise.  */
13900
13901 static void
13902 ada_forward_operator_length (struct expression *exp, int pc,
13903                              int *oplenp, int *argsp)
13904 {
13905   switch (exp->elts[pc].opcode)
13906     {
13907     default:
13908       *oplenp = *argsp = 0;
13909       break;
13910
13911 #define OP_DEFN(op, len, args, binop) \
13912     case op: *oplenp = len; *argsp = args; break;
13913       ADA_OPERATORS;
13914 #undef OP_DEFN
13915
13916     case OP_AGGREGATE:
13917       *oplenp = 3;
13918       *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13919       break;
13920
13921     case OP_CHOICES:
13922       *oplenp = 3;
13923       *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13924       break;
13925
13926     case OP_STRING:
13927     case OP_NAME:
13928       {
13929         int len = longest_to_int (exp->elts[pc + 1].longconst);
13930
13931         *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13932         *argsp = 0;
13933         break;
13934       }
13935     }
13936 }
13937
13938 static int
13939 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13940 {
13941   enum exp_opcode op = exp->elts[elt].opcode;
13942   int oplen, nargs;
13943   int pc = elt;
13944   int i;
13945
13946   ada_forward_operator_length (exp, elt, &oplen, &nargs);
13947
13948   switch (op)
13949     {
13950       /* Ada attributes ('Foo).  */
13951     case OP_ATR_FIRST:
13952     case OP_ATR_LAST:
13953     case OP_ATR_LENGTH:
13954     case OP_ATR_IMAGE:
13955     case OP_ATR_MAX:
13956     case OP_ATR_MIN:
13957     case OP_ATR_MODULUS:
13958     case OP_ATR_POS:
13959     case OP_ATR_SIZE:
13960     case OP_ATR_TAG:
13961     case OP_ATR_VAL:
13962       break;
13963
13964     case UNOP_IN_RANGE:
13965     case UNOP_QUAL:
13966       /* XXX: gdb_sprint_host_address, type_sprint */
13967       fprintf_filtered (stream, _("Type @"));
13968       gdb_print_host_address (exp->elts[pc + 1].type, stream);
13969       fprintf_filtered (stream, " (");
13970       type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13971       fprintf_filtered (stream, ")");
13972       break;
13973     case BINOP_IN_BOUNDS:
13974       fprintf_filtered (stream, " (%d)",
13975                         longest_to_int (exp->elts[pc + 2].longconst));
13976       break;
13977     case TERNOP_IN_RANGE:
13978       break;
13979
13980     case OP_AGGREGATE:
13981     case OP_OTHERS:
13982     case OP_DISCRETE_RANGE:
13983     case OP_POSITIONAL:
13984     case OP_CHOICES:
13985       break;
13986
13987     case OP_NAME:
13988     case OP_STRING:
13989       {
13990         char *name = &exp->elts[elt + 2].string;
13991         int len = longest_to_int (exp->elts[elt + 1].longconst);
13992
13993         fprintf_filtered (stream, "Text: `%.*s'", len, name);
13994         break;
13995       }
13996
13997     default:
13998       return dump_subexp_body_standard (exp, stream, elt);
13999     }
14000
14001   elt += oplen;
14002   for (i = 0; i < nargs; i += 1)
14003     elt = dump_subexp (exp, stream, elt);
14004
14005   return elt;
14006 }
14007
14008 /* The Ada extension of print_subexp (q.v.).  */
14009
14010 static void
14011 ada_print_subexp (struct expression *exp, int *pos,
14012                   struct ui_file *stream, enum precedence prec)
14013 {
14014   int oplen, nargs, i;
14015   int pc = *pos;
14016   enum exp_opcode op = exp->elts[pc].opcode;
14017
14018   ada_forward_operator_length (exp, pc, &oplen, &nargs);
14019
14020   *pos += oplen;
14021   switch (op)
14022     {
14023     default:
14024       *pos -= oplen;
14025       print_subexp_standard (exp, pos, stream, prec);
14026       return;
14027
14028     case OP_VAR_VALUE:
14029       fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
14030       return;
14031
14032     case BINOP_IN_BOUNDS:
14033       /* XXX: sprint_subexp */
14034       print_subexp (exp, pos, stream, PREC_SUFFIX);
14035       fputs_filtered (" in ", stream);
14036       print_subexp (exp, pos, stream, PREC_SUFFIX);
14037       fputs_filtered ("'range", stream);
14038       if (exp->elts[pc + 1].longconst > 1)
14039         fprintf_filtered (stream, "(%ld)",
14040                           (long) exp->elts[pc + 1].longconst);
14041       return;
14042
14043     case TERNOP_IN_RANGE:
14044       if (prec >= PREC_EQUAL)
14045         fputs_filtered ("(", stream);
14046       /* XXX: sprint_subexp */
14047       print_subexp (exp, pos, stream, PREC_SUFFIX);
14048       fputs_filtered (" in ", stream);
14049       print_subexp (exp, pos, stream, PREC_EQUAL);
14050       fputs_filtered (" .. ", stream);
14051       print_subexp (exp, pos, stream, PREC_EQUAL);
14052       if (prec >= PREC_EQUAL)
14053         fputs_filtered (")", stream);
14054       return;
14055
14056     case OP_ATR_FIRST:
14057     case OP_ATR_LAST:
14058     case OP_ATR_LENGTH:
14059     case OP_ATR_IMAGE:
14060     case OP_ATR_MAX:
14061     case OP_ATR_MIN:
14062     case OP_ATR_MODULUS:
14063     case OP_ATR_POS:
14064     case OP_ATR_SIZE:
14065     case OP_ATR_TAG:
14066     case OP_ATR_VAL:
14067       if (exp->elts[*pos].opcode == OP_TYPE)
14068         {
14069           if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
14070             LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
14071                            &type_print_raw_options);
14072           *pos += 3;
14073         }
14074       else
14075         print_subexp (exp, pos, stream, PREC_SUFFIX);
14076       fprintf_filtered (stream, "'%s", ada_attribute_name (op));
14077       if (nargs > 1)
14078         {
14079           int tem;
14080
14081           for (tem = 1; tem < nargs; tem += 1)
14082             {
14083               fputs_filtered ((tem == 1) ? " (" : ", ", stream);
14084               print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
14085             }
14086           fputs_filtered (")", stream);
14087         }
14088       return;
14089
14090     case UNOP_QUAL:
14091       type_print (exp->elts[pc + 1].type, "", stream, 0);
14092       fputs_filtered ("'(", stream);
14093       print_subexp (exp, pos, stream, PREC_PREFIX);
14094       fputs_filtered (")", stream);
14095       return;
14096
14097     case UNOP_IN_RANGE:
14098       /* XXX: sprint_subexp */
14099       print_subexp (exp, pos, stream, PREC_SUFFIX);
14100       fputs_filtered (" in ", stream);
14101       LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
14102                      &type_print_raw_options);
14103       return;
14104
14105     case OP_DISCRETE_RANGE:
14106       print_subexp (exp, pos, stream, PREC_SUFFIX);
14107       fputs_filtered ("..", stream);
14108       print_subexp (exp, pos, stream, PREC_SUFFIX);
14109       return;
14110
14111     case OP_OTHERS:
14112       fputs_filtered ("others => ", stream);
14113       print_subexp (exp, pos, stream, PREC_SUFFIX);
14114       return;
14115
14116     case OP_CHOICES:
14117       for (i = 0; i < nargs-1; i += 1)
14118         {
14119           if (i > 0)
14120             fputs_filtered ("|", stream);
14121           print_subexp (exp, pos, stream, PREC_SUFFIX);
14122         }
14123       fputs_filtered (" => ", stream);
14124       print_subexp (exp, pos, stream, PREC_SUFFIX);
14125       return;
14126       
14127     case OP_POSITIONAL:
14128       print_subexp (exp, pos, stream, PREC_SUFFIX);
14129       return;
14130
14131     case OP_AGGREGATE:
14132       fputs_filtered ("(", stream);
14133       for (i = 0; i < nargs; i += 1)
14134         {
14135           if (i > 0)
14136             fputs_filtered (", ", stream);
14137           print_subexp (exp, pos, stream, PREC_SUFFIX);
14138         }
14139       fputs_filtered (")", stream);
14140       return;
14141     }
14142 }
14143
14144 /* Table mapping opcodes into strings for printing operators
14145    and precedences of the operators.  */
14146
14147 static const struct op_print ada_op_print_tab[] = {
14148   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
14149   {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
14150   {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
14151   {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
14152   {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
14153   {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
14154   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
14155   {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
14156   {"<=", BINOP_LEQ, PREC_ORDER, 0},
14157   {">=", BINOP_GEQ, PREC_ORDER, 0},
14158   {">", BINOP_GTR, PREC_ORDER, 0},
14159   {"<", BINOP_LESS, PREC_ORDER, 0},
14160   {">>", BINOP_RSH, PREC_SHIFT, 0},
14161   {"<<", BINOP_LSH, PREC_SHIFT, 0},
14162   {"+", BINOP_ADD, PREC_ADD, 0},
14163   {"-", BINOP_SUB, PREC_ADD, 0},
14164   {"&", BINOP_CONCAT, PREC_ADD, 0},
14165   {"*", BINOP_MUL, PREC_MUL, 0},
14166   {"/", BINOP_DIV, PREC_MUL, 0},
14167   {"rem", BINOP_REM, PREC_MUL, 0},
14168   {"mod", BINOP_MOD, PREC_MUL, 0},
14169   {"**", BINOP_EXP, PREC_REPEAT, 0},
14170   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
14171   {"-", UNOP_NEG, PREC_PREFIX, 0},
14172   {"+", UNOP_PLUS, PREC_PREFIX, 0},
14173   {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
14174   {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
14175   {"abs ", UNOP_ABS, PREC_PREFIX, 0},
14176   {".all", UNOP_IND, PREC_SUFFIX, 1},
14177   {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
14178   {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
14179   {NULL, OP_NULL, PREC_SUFFIX, 0}
14180 };
14181 \f
14182 enum ada_primitive_types {
14183   ada_primitive_type_int,
14184   ada_primitive_type_long,
14185   ada_primitive_type_short,
14186   ada_primitive_type_char,
14187   ada_primitive_type_float,
14188   ada_primitive_type_double,
14189   ada_primitive_type_void,
14190   ada_primitive_type_long_long,
14191   ada_primitive_type_long_double,
14192   ada_primitive_type_natural,
14193   ada_primitive_type_positive,
14194   ada_primitive_type_system_address,
14195   ada_primitive_type_storage_offset,
14196   nr_ada_primitive_types
14197 };
14198
14199 static void
14200 ada_language_arch_info (struct gdbarch *gdbarch,
14201                         struct language_arch_info *lai)
14202 {
14203   const struct builtin_type *builtin = builtin_type (gdbarch);
14204
14205   lai->primitive_type_vector
14206     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
14207                               struct type *);
14208
14209   lai->primitive_type_vector [ada_primitive_type_int]
14210     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14211                          0, "integer");
14212   lai->primitive_type_vector [ada_primitive_type_long]
14213     = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
14214                          0, "long_integer");
14215   lai->primitive_type_vector [ada_primitive_type_short]
14216     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
14217                          0, "short_integer");
14218   lai->string_char_type
14219     = lai->primitive_type_vector [ada_primitive_type_char]
14220     = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
14221   lai->primitive_type_vector [ada_primitive_type_float]
14222     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
14223                        "float", gdbarch_float_format (gdbarch));
14224   lai->primitive_type_vector [ada_primitive_type_double]
14225     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
14226                        "long_float", gdbarch_double_format (gdbarch));
14227   lai->primitive_type_vector [ada_primitive_type_long_long]
14228     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
14229                          0, "long_long_integer");
14230   lai->primitive_type_vector [ada_primitive_type_long_double]
14231     = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
14232                        "long_long_float", gdbarch_long_double_format (gdbarch));
14233   lai->primitive_type_vector [ada_primitive_type_natural]
14234     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14235                          0, "natural");
14236   lai->primitive_type_vector [ada_primitive_type_positive]
14237     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14238                          0, "positive");
14239   lai->primitive_type_vector [ada_primitive_type_void]
14240     = builtin->builtin_void;
14241
14242   lai->primitive_type_vector [ada_primitive_type_system_address]
14243     = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
14244                                       "void"));
14245   TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
14246     = "system__address";
14247
14248   /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14249      type.  This is a signed integral type whose size is the same as
14250      the size of addresses.  */
14251   {
14252     unsigned int addr_length = TYPE_LENGTH
14253       (lai->primitive_type_vector [ada_primitive_type_system_address]);
14254
14255     lai->primitive_type_vector [ada_primitive_type_storage_offset]
14256       = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
14257                            "storage_offset");
14258   }
14259
14260   lai->bool_type_symbol = NULL;
14261   lai->bool_type_default = builtin->builtin_bool;
14262 }
14263 \f
14264                                 /* Language vector */
14265
14266 /* Not really used, but needed in the ada_language_defn.  */
14267
14268 static void
14269 emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
14270 {
14271   ada_emit_char (c, type, stream, quoter, 1);
14272 }
14273
14274 static int
14275 parse (struct parser_state *ps)
14276 {
14277   warnings_issued = 0;
14278   return ada_parse (ps);
14279 }
14280
14281 static const struct exp_descriptor ada_exp_descriptor = {
14282   ada_print_subexp,
14283   ada_operator_length,
14284   ada_operator_check,
14285   ada_op_name,
14286   ada_dump_subexp_body,
14287   ada_evaluate_subexp
14288 };
14289
14290 /* symbol_name_matcher_ftype adapter for wild_match.  */
14291
14292 static bool
14293 do_wild_match (const char *symbol_search_name,
14294                const lookup_name_info &lookup_name,
14295                completion_match_result *comp_match_res)
14296 {
14297   return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
14298 }
14299
14300 /* symbol_name_matcher_ftype adapter for full_match.  */
14301
14302 static bool
14303 do_full_match (const char *symbol_search_name,
14304                const lookup_name_info &lookup_name,
14305                completion_match_result *comp_match_res)
14306 {
14307   return full_match (symbol_search_name, ada_lookup_name (lookup_name));
14308 }
14309
14310 /* Build the Ada lookup name for LOOKUP_NAME.  */
14311
14312 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
14313 {
14314   const std::string &user_name = lookup_name.name ();
14315
14316   if (user_name[0] == '<')
14317     {
14318       if (user_name.back () == '>')
14319         m_encoded_name = user_name.substr (1, user_name.size () - 2);
14320       else
14321         m_encoded_name = user_name.substr (1, user_name.size () - 1);
14322       m_encoded_p = true;
14323       m_verbatim_p = true;
14324       m_wild_match_p = false;
14325       m_standard_p = false;
14326     }
14327   else
14328     {
14329       m_verbatim_p = false;
14330
14331       m_encoded_p = user_name.find ("__") != std::string::npos;
14332
14333       if (!m_encoded_p)
14334         {
14335           const char *folded = ada_fold_name (user_name.c_str ());
14336           const char *encoded = ada_encode_1 (folded, false);
14337           if (encoded != NULL)
14338             m_encoded_name = encoded;
14339           else
14340             m_encoded_name = user_name;
14341         }
14342       else
14343         m_encoded_name = user_name;
14344
14345       /* Handle the 'package Standard' special case.  See description
14346          of m_standard_p.  */
14347       if (startswith (m_encoded_name.c_str (), "standard__"))
14348         {
14349           m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
14350           m_standard_p = true;
14351         }
14352       else
14353         m_standard_p = false;
14354
14355       /* If the name contains a ".", then the user is entering a fully
14356          qualified entity name, and the match must not be done in wild
14357          mode.  Similarly, if the user wants to complete what looks
14358          like an encoded name, the match must not be done in wild
14359          mode.  Also, in the standard__ special case always do
14360          non-wild matching.  */
14361       m_wild_match_p
14362         = (lookup_name.match_type () != symbol_name_match_type::FULL
14363            && !m_encoded_p
14364            && !m_standard_p
14365            && user_name.find ('.') == std::string::npos);
14366     }
14367 }
14368
14369 /* symbol_name_matcher_ftype method for Ada.  This only handles
14370    completion mode.  */
14371
14372 static bool
14373 ada_symbol_name_matches (const char *symbol_search_name,
14374                          const lookup_name_info &lookup_name,
14375                          completion_match_result *comp_match_res)
14376 {
14377   return lookup_name.ada ().matches (symbol_search_name,
14378                                      lookup_name.match_type (),
14379                                      comp_match_res);
14380 }
14381
14382 /* A name matcher that matches the symbol name exactly, with
14383    strcmp.  */
14384
14385 static bool
14386 literal_symbol_name_matcher (const char *symbol_search_name,
14387                              const lookup_name_info &lookup_name,
14388                              completion_match_result *comp_match_res)
14389 {
14390   const std::string &name = lookup_name.name ();
14391
14392   int cmp = (lookup_name.completion_mode ()
14393              ? strncmp (symbol_search_name, name.c_str (), name.size ())
14394              : strcmp (symbol_search_name, name.c_str ()));
14395   if (cmp == 0)
14396     {
14397       if (comp_match_res != NULL)
14398         comp_match_res->set_match (symbol_search_name);
14399       return true;
14400     }
14401   else
14402     return false;
14403 }
14404
14405 /* Implement the "la_get_symbol_name_matcher" language_defn method for
14406    Ada.  */
14407
14408 static symbol_name_matcher_ftype *
14409 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14410 {
14411   if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14412     return literal_symbol_name_matcher;
14413
14414   if (lookup_name.completion_mode ())
14415     return ada_symbol_name_matches;
14416   else
14417     {
14418       if (lookup_name.ada ().wild_match_p ())
14419         return do_wild_match;
14420       else
14421         return do_full_match;
14422     }
14423 }
14424
14425 /* Implement the "la_read_var_value" language_defn method for Ada.  */
14426
14427 static struct value *
14428 ada_read_var_value (struct symbol *var, const struct block *var_block,
14429                     struct frame_info *frame)
14430 {
14431   const struct block *frame_block = NULL;
14432   struct symbol *renaming_sym = NULL;
14433
14434   /* The only case where default_read_var_value is not sufficient
14435      is when VAR is a renaming...  */
14436   if (frame)
14437     frame_block = get_frame_block (frame, NULL);
14438   if (frame_block)
14439     renaming_sym = ada_find_renaming_symbol (var, frame_block);
14440   if (renaming_sym != NULL)
14441     return ada_read_renaming_var_value (renaming_sym, frame_block);
14442
14443   /* This is a typical case where we expect the default_read_var_value
14444      function to work.  */
14445   return default_read_var_value (var, var_block, frame);
14446 }
14447
14448 static const char *ada_extensions[] =
14449 {
14450   ".adb", ".ads", ".a", ".ada", ".dg", NULL
14451 };
14452
14453 extern const struct language_defn ada_language_defn = {
14454   "ada",                        /* Language name */
14455   "Ada",
14456   language_ada,
14457   range_check_off,
14458   case_sensitive_on,            /* Yes, Ada is case-insensitive, but
14459                                    that's not quite what this means.  */
14460   array_row_major,
14461   macro_expansion_no,
14462   ada_extensions,
14463   &ada_exp_descriptor,
14464   parse,
14465   ada_yyerror,
14466   resolve,
14467   ada_printchar,                /* Print a character constant */
14468   ada_printstr,                 /* Function to print string constant */
14469   emit_char,                    /* Function to print single char (not used) */
14470   ada_print_type,               /* Print a type using appropriate syntax */
14471   ada_print_typedef,            /* Print a typedef using appropriate syntax */
14472   ada_val_print,                /* Print a value using appropriate syntax */
14473   ada_value_print,              /* Print a top-level value */
14474   ada_read_var_value,           /* la_read_var_value */
14475   NULL,                         /* Language specific skip_trampoline */
14476   NULL,                         /* name_of_this */
14477   true,                         /* la_store_sym_names_in_linkage_form_p */
14478   ada_lookup_symbol_nonlocal,   /* Looking up non-local symbols.  */
14479   basic_lookup_transparent_type,        /* lookup_transparent_type */
14480   ada_la_decode,                /* Language specific symbol demangler */
14481   ada_sniff_from_mangled_name,
14482   NULL,                         /* Language specific
14483                                    class_name_from_physname */
14484   ada_op_print_tab,             /* expression operators for printing */
14485   0,                            /* c-style arrays */
14486   1,                            /* String lower bound */
14487   ada_get_gdb_completer_word_break_characters,
14488   ada_collect_symbol_completion_matches,
14489   ada_language_arch_info,
14490   ada_print_array_index,
14491   default_pass_by_reference,
14492   c_get_string,
14493   c_watch_location_expression,
14494   ada_get_symbol_name_matcher,  /* la_get_symbol_name_matcher */
14495   ada_iterate_over_symbols,
14496   default_search_name_hash,
14497   &ada_varobj_ops,
14498   NULL,
14499   NULL,
14500   LANG_MAGIC
14501 };
14502
14503 /* Command-list for the "set/show ada" prefix command.  */
14504 static struct cmd_list_element *set_ada_list;
14505 static struct cmd_list_element *show_ada_list;
14506
14507 /* Implement the "set ada" prefix command.  */
14508
14509 static void
14510 set_ada_command (const char *arg, int from_tty)
14511 {
14512   printf_unfiltered (_(\
14513 "\"set ada\" must be followed by the name of a setting.\n"));
14514   help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
14515 }
14516
14517 /* Implement the "show ada" prefix command.  */
14518
14519 static void
14520 show_ada_command (const char *args, int from_tty)
14521 {
14522   cmd_show_list (show_ada_list, from_tty, "");
14523 }
14524
14525 static void
14526 initialize_ada_catchpoint_ops (void)
14527 {
14528   struct breakpoint_ops *ops;
14529
14530   initialize_breakpoint_ops ();
14531
14532   ops = &catch_exception_breakpoint_ops;
14533   *ops = bkpt_breakpoint_ops;
14534   ops->allocate_location = allocate_location_catch_exception;
14535   ops->re_set = re_set_catch_exception;
14536   ops->check_status = check_status_catch_exception;
14537   ops->print_it = print_it_catch_exception;
14538   ops->print_one = print_one_catch_exception;
14539   ops->print_mention = print_mention_catch_exception;
14540   ops->print_recreate = print_recreate_catch_exception;
14541
14542   ops = &catch_exception_unhandled_breakpoint_ops;
14543   *ops = bkpt_breakpoint_ops;
14544   ops->allocate_location = allocate_location_catch_exception_unhandled;
14545   ops->re_set = re_set_catch_exception_unhandled;
14546   ops->check_status = check_status_catch_exception_unhandled;
14547   ops->print_it = print_it_catch_exception_unhandled;
14548   ops->print_one = print_one_catch_exception_unhandled;
14549   ops->print_mention = print_mention_catch_exception_unhandled;
14550   ops->print_recreate = print_recreate_catch_exception_unhandled;
14551
14552   ops = &catch_assert_breakpoint_ops;
14553   *ops = bkpt_breakpoint_ops;
14554   ops->allocate_location = allocate_location_catch_assert;
14555   ops->re_set = re_set_catch_assert;
14556   ops->check_status = check_status_catch_assert;
14557   ops->print_it = print_it_catch_assert;
14558   ops->print_one = print_one_catch_assert;
14559   ops->print_mention = print_mention_catch_assert;
14560   ops->print_recreate = print_recreate_catch_assert;
14561
14562   ops = &catch_handlers_breakpoint_ops;
14563   *ops = bkpt_breakpoint_ops;
14564   ops->allocate_location = allocate_location_catch_handlers;
14565   ops->re_set = re_set_catch_handlers;
14566   ops->check_status = check_status_catch_handlers;
14567   ops->print_it = print_it_catch_handlers;
14568   ops->print_one = print_one_catch_handlers;
14569   ops->print_mention = print_mention_catch_handlers;
14570   ops->print_recreate = print_recreate_catch_handlers;
14571 }
14572
14573 /* This module's 'new_objfile' observer.  */
14574
14575 static void
14576 ada_new_objfile_observer (struct objfile *objfile)
14577 {
14578   ada_clear_symbol_cache ();
14579 }
14580
14581 /* This module's 'free_objfile' observer.  */
14582
14583 static void
14584 ada_free_objfile_observer (struct objfile *objfile)
14585 {
14586   ada_clear_symbol_cache ();
14587 }
14588
14589 void
14590 _initialize_ada_language (void)
14591 {
14592   initialize_ada_catchpoint_ops ();
14593
14594   add_prefix_cmd ("ada", no_class, set_ada_command,
14595                   _("Prefix command for changing Ada-specfic settings"),
14596                   &set_ada_list, "set ada ", 0, &setlist);
14597
14598   add_prefix_cmd ("ada", no_class, show_ada_command,
14599                   _("Generic command for showing Ada-specific settings."),
14600                   &show_ada_list, "show ada ", 0, &showlist);
14601
14602   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14603                            &trust_pad_over_xvs, _("\
14604 Enable or disable an optimization trusting PAD types over XVS types"), _("\
14605 Show whether an optimization trusting PAD types over XVS types is activated"),
14606                            _("\
14607 This is related to the encoding used by the GNAT compiler.  The debugger\n\
14608 should normally trust the contents of PAD types, but certain older versions\n\
14609 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14610 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
14611 work around this bug.  It is always safe to turn this option \"off\", but\n\
14612 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14613 this option to \"off\" unless necessary."),
14614                             NULL, NULL, &set_ada_list, &show_ada_list);
14615
14616   add_setshow_boolean_cmd ("print-signatures", class_vars,
14617                            &print_signatures, _("\
14618 Enable or disable the output of formal and return types for functions in the \
14619 overloads selection menu"), _("\
14620 Show whether the output of formal and return types for functions in the \
14621 overloads selection menu is activated"),
14622                            NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14623
14624   add_catch_command ("exception", _("\
14625 Catch Ada exceptions, when raised.\n\
14626 With an argument, catch only exceptions with the given name."),
14627                      catch_ada_exception_command,
14628                      NULL,
14629                      CATCH_PERMANENT,
14630                      CATCH_TEMPORARY);
14631
14632   add_catch_command ("handlers", _("\
14633 Catch Ada exceptions, when handled.\n\
14634 With an argument, catch only exceptions with the given name."),
14635                      catch_ada_handlers_command,
14636                      NULL,
14637                      CATCH_PERMANENT,
14638                      CATCH_TEMPORARY);
14639   add_catch_command ("assert", _("\
14640 Catch failed Ada assertions, when raised.\n\
14641 With an argument, catch only exceptions with the given name."),
14642                      catch_assert_command,
14643                      NULL,
14644                      CATCH_PERMANENT,
14645                      CATCH_TEMPORARY);
14646
14647   varsize_limit = 65536;
14648   add_setshow_uinteger_cmd ("varsize-limit", class_support,
14649                             &varsize_limit, _("\
14650 Set the maximum number of bytes allowed in a variable-size object."), _("\
14651 Show the maximum number of bytes allowed in a variable-size object."), _("\
14652 Attempts to access an object whose size is not a compile-time constant\n\
14653 and exceeds this limit will cause an error."),
14654                             NULL, NULL, &setlist, &showlist);
14655
14656   add_info ("exceptions", info_exceptions_command,
14657             _("\
14658 List all Ada exception names.\n\
14659 If a regular expression is passed as an argument, only those matching\n\
14660 the regular expression are listed."));
14661
14662   add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14663                   _("Set Ada maintenance-related variables."),
14664                   &maint_set_ada_cmdlist, "maintenance set ada ",
14665                   0/*allow-unknown*/, &maintenance_set_cmdlist);
14666
14667   add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14668                   _("Show Ada maintenance-related variables"),
14669                   &maint_show_ada_cmdlist, "maintenance show ada ",
14670                   0/*allow-unknown*/, &maintenance_show_cmdlist);
14671
14672   add_setshow_boolean_cmd
14673     ("ignore-descriptive-types", class_maintenance,
14674      &ada_ignore_descriptive_types_p,
14675      _("Set whether descriptive types generated by GNAT should be ignored."),
14676      _("Show whether descriptive types generated by GNAT should be ignored."),
14677      _("\
14678 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14679 DWARF attribute."),
14680      NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14681
14682   decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
14683                                            NULL, xcalloc, xfree);
14684
14685   /* The ada-lang observers.  */
14686   gdb::observers::new_objfile.attach (ada_new_objfile_observer);
14687   gdb::observers::free_objfile.attach (ada_free_objfile_observer);
14688   gdb::observers::inferior_exit.attach (ada_inferior_exit);
14689
14690   /* Setup various context-specific data.  */
14691   ada_inferior_data
14692     = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
14693   ada_pspace_data_handle
14694     = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14695 }