Upgrade GDB from 7.4.1 to 7.6.1 on the vendor branch
[dragonfly.git] / contrib / gdb-7 / gdb / ada-lang.c
1 /* Ada language support routines for GDB, the GNU debugger.
2
3    Copyright (C) 1992-2013 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 <stdio.h>
23 #include "gdb_string.h"
24 #include <ctype.h>
25 #include <stdarg.h>
26 #include "demangle.h"
27 #include "gdb_regex.h"
28 #include "frame.h"
29 #include "symtab.h"
30 #include "gdbtypes.h"
31 #include "gdbcmd.h"
32 #include "expression.h"
33 #include "parser-defs.h"
34 #include "language.h"
35 #include "c-lang.h"
36 #include "inferior.h"
37 #include "symfile.h"
38 #include "objfiles.h"
39 #include "breakpoint.h"
40 #include "gdbcore.h"
41 #include "hashtab.h"
42 #include "gdb_obstack.h"
43 #include "ada-lang.h"
44 #include "completer.h"
45 #include "gdb_stat.h"
46 #ifdef UI_OUT
47 #include "ui-out.h"
48 #endif
49 #include "block.h"
50 #include "infcall.h"
51 #include "dictionary.h"
52 #include "exceptions.h"
53 #include "annotate.h"
54 #include "valprint.h"
55 #include "source.h"
56 #include "observer.h"
57 #include "vec.h"
58 #include "stack.h"
59 #include "gdb_vecs.h"
60 #include "typeprint.h"
61
62 #include "psymtab.h"
63 #include "value.h"
64 #include "mi/mi-common.h"
65 #include "arch-utils.h"
66 #include "exceptions.h"
67 #include "cli/cli-utils.h"
68
69 /* Define whether or not the C operator '/' truncates towards zero for
70    differently signed operands (truncation direction is undefined in C).
71    Copied from valarith.c.  */
72
73 #ifndef TRUNCATION_TOWARDS_ZERO
74 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
75 #endif
76
77 static struct type *desc_base_type (struct type *);
78
79 static struct type *desc_bounds_type (struct type *);
80
81 static struct value *desc_bounds (struct value *);
82
83 static int fat_pntr_bounds_bitpos (struct type *);
84
85 static int fat_pntr_bounds_bitsize (struct type *);
86
87 static struct type *desc_data_target_type (struct type *);
88
89 static struct value *desc_data (struct value *);
90
91 static int fat_pntr_data_bitpos (struct type *);
92
93 static int fat_pntr_data_bitsize (struct type *);
94
95 static struct value *desc_one_bound (struct value *, int, int);
96
97 static int desc_bound_bitpos (struct type *, int, int);
98
99 static int desc_bound_bitsize (struct type *, int, int);
100
101 static struct type *desc_index_type (struct type *, int);
102
103 static int desc_arity (struct type *);
104
105 static int ada_type_match (struct type *, struct type *, int);
106
107 static int ada_args_match (struct symbol *, struct value **, int);
108
109 static int full_match (const char *, const char *);
110
111 static struct value *make_array_descriptor (struct type *, struct value *);
112
113 static void ada_add_block_symbols (struct obstack *,
114                                    struct block *, const char *,
115                                    domain_enum, struct objfile *, int);
116
117 static int is_nonfunction (struct ada_symbol_info *, int);
118
119 static void add_defn_to_vec (struct obstack *, struct symbol *,
120                              struct block *);
121
122 static int num_defns_collected (struct obstack *);
123
124 static struct ada_symbol_info *defns_collected (struct obstack *, int);
125
126 static struct value *resolve_subexp (struct expression **, int *, int,
127                                      struct type *);
128
129 static void replace_operator_with_call (struct expression **, int, int, int,
130                                         struct symbol *, const struct block *);
131
132 static int possible_user_operator_p (enum exp_opcode, struct value **);
133
134 static char *ada_op_name (enum exp_opcode);
135
136 static const char *ada_decoded_op_name (enum exp_opcode);
137
138 static int numeric_type_p (struct type *);
139
140 static int integer_type_p (struct type *);
141
142 static int scalar_type_p (struct type *);
143
144 static int discrete_type_p (struct type *);
145
146 static enum ada_renaming_category parse_old_style_renaming (struct type *,
147                                                             const char **,
148                                                             int *,
149                                                             const char **);
150
151 static struct symbol *find_old_style_renaming_symbol (const char *,
152                                                       const struct block *);
153
154 static struct type *ada_lookup_struct_elt_type (struct type *, char *,
155                                                 int, int, int *);
156
157 static struct value *evaluate_subexp_type (struct expression *, int *);
158
159 static struct type *ada_find_parallel_type_with_name (struct type *,
160                                                       const char *);
161
162 static int is_dynamic_field (struct type *, int);
163
164 static struct type *to_fixed_variant_branch_type (struct type *,
165                                                   const gdb_byte *,
166                                                   CORE_ADDR, struct value *);
167
168 static struct type *to_fixed_array_type (struct type *, struct value *, int);
169
170 static struct type *to_fixed_range_type (struct type *, struct value *);
171
172 static struct type *to_static_fixed_type (struct type *);
173 static struct type *static_unwrap_type (struct type *type);
174
175 static struct value *unwrap_value (struct value *);
176
177 static struct type *constrained_packed_array_type (struct type *, long *);
178
179 static struct type *decode_constrained_packed_array_type (struct type *);
180
181 static long decode_packed_array_bitsize (struct type *);
182
183 static struct value *decode_constrained_packed_array (struct value *);
184
185 static int ada_is_packed_array_type  (struct type *);
186
187 static int ada_is_unconstrained_packed_array_type (struct type *);
188
189 static struct value *value_subscript_packed (struct value *, int,
190                                              struct value **);
191
192 static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
193
194 static struct value *coerce_unspec_val_to_type (struct value *,
195                                                 struct type *);
196
197 static struct value *get_var_value (char *, char *);
198
199 static int lesseq_defined_than (struct symbol *, struct symbol *);
200
201 static int equiv_types (struct type *, struct type *);
202
203 static int is_name_suffix (const char *);
204
205 static int advance_wild_match (const char **, const char *, int);
206
207 static int wild_match (const char *, const char *);
208
209 static struct value *ada_coerce_ref (struct value *);
210
211 static LONGEST pos_atr (struct value *);
212
213 static struct value *value_pos_atr (struct type *, struct value *);
214
215 static struct value *value_val_atr (struct type *, struct value *);
216
217 static struct symbol *standard_lookup (const char *, const struct block *,
218                                        domain_enum);
219
220 static struct value *ada_search_struct_field (char *, struct value *, int,
221                                               struct type *);
222
223 static struct value *ada_value_primitive_field (struct value *, int, int,
224                                                 struct type *);
225
226 static int find_struct_field (const char *, struct type *, int,
227                               struct type **, int *, int *, int *, int *);
228
229 static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
230                                                 struct value *);
231
232 static int ada_resolve_function (struct ada_symbol_info *, int,
233                                  struct value **, int, const char *,
234                                  struct type *);
235
236 static int ada_is_direct_array_type (struct type *);
237
238 static void ada_language_arch_info (struct gdbarch *,
239                                     struct language_arch_info *);
240
241 static void check_size (const struct type *);
242
243 static struct value *ada_index_struct_field (int, struct value *, int,
244                                              struct type *);
245
246 static struct value *assign_aggregate (struct value *, struct value *, 
247                                        struct expression *,
248                                        int *, enum noside);
249
250 static void aggregate_assign_from_choices (struct value *, struct value *, 
251                                            struct expression *,
252                                            int *, LONGEST *, int *,
253                                            int, LONGEST, LONGEST);
254
255 static void aggregate_assign_positional (struct value *, struct value *,
256                                          struct expression *,
257                                          int *, LONGEST *, int *, int,
258                                          LONGEST, LONGEST);
259
260
261 static void aggregate_assign_others (struct value *, struct value *,
262                                      struct expression *,
263                                      int *, LONGEST *, int, LONGEST, LONGEST);
264
265
266 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
267
268
269 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
270                                           int *, enum noside);
271
272 static void ada_forward_operator_length (struct expression *, int, int *,
273                                          int *);
274
275 static struct type *ada_find_any_type (const char *name);
276 \f
277
278
279 /* Maximum-sized dynamic type.  */
280 static unsigned int varsize_limit;
281
282 /* FIXME: brobecker/2003-09-17: No longer a const because it is
283    returned by a function that does not return a const char *.  */
284 static char *ada_completer_word_break_characters =
285 #ifdef VMS
286   " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
287 #else
288   " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
289 #endif
290
291 /* The name of the symbol to use to get the name of the main subprogram.  */
292 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
293   = "__gnat_ada_main_program_name";
294
295 /* Limit on the number of warnings to raise per expression evaluation.  */
296 static int warning_limit = 2;
297
298 /* Number of warning messages issued; reset to 0 by cleanups after
299    expression evaluation.  */
300 static int warnings_issued = 0;
301
302 static const char *known_runtime_file_name_patterns[] = {
303   ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
304 };
305
306 static const char *known_auxiliary_function_name_patterns[] = {
307   ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
308 };
309
310 /* Space for allocating results of ada_lookup_symbol_list.  */
311 static struct obstack symbol_list_obstack;
312
313                         /* Inferior-specific data.  */
314
315 /* Per-inferior data for this module.  */
316
317 struct ada_inferior_data
318 {
319   /* The ada__tags__type_specific_data type, which is used when decoding
320      tagged types.  With older versions of GNAT, this type was directly
321      accessible through a component ("tsd") in the object tag.  But this
322      is no longer the case, so we cache it for each inferior.  */
323   struct type *tsd_type;
324
325   /* The exception_support_info data.  This data is used to determine
326      how to implement support for Ada exception catchpoints in a given
327      inferior.  */
328   const struct exception_support_info *exception_info;
329 };
330
331 /* Our key to this module's inferior data.  */
332 static const struct inferior_data *ada_inferior_data;
333
334 /* A cleanup routine for our inferior data.  */
335 static void
336 ada_inferior_data_cleanup (struct inferior *inf, void *arg)
337 {
338   struct ada_inferior_data *data;
339
340   data = inferior_data (inf, ada_inferior_data);
341   if (data != NULL)
342     xfree (data);
343 }
344
345 /* Return our inferior data for the given inferior (INF).
346
347    This function always returns a valid pointer to an allocated
348    ada_inferior_data structure.  If INF's inferior data has not
349    been previously set, this functions creates a new one with all
350    fields set to zero, sets INF's inferior to it, and then returns
351    a pointer to that newly allocated ada_inferior_data.  */
352
353 static struct ada_inferior_data *
354 get_ada_inferior_data (struct inferior *inf)
355 {
356   struct ada_inferior_data *data;
357
358   data = inferior_data (inf, ada_inferior_data);
359   if (data == NULL)
360     {
361       data = XZALLOC (struct ada_inferior_data);
362       set_inferior_data (inf, ada_inferior_data, data);
363     }
364
365   return data;
366 }
367
368 /* Perform all necessary cleanups regarding our module's inferior data
369    that is required after the inferior INF just exited.  */
370
371 static void
372 ada_inferior_exit (struct inferior *inf)
373 {
374   ada_inferior_data_cleanup (inf, NULL);
375   set_inferior_data (inf, ada_inferior_data, NULL);
376 }
377
378                         /* Utilities */
379
380 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
381    all typedef layers have been peeled.  Otherwise, return TYPE.
382
383    Normally, we really expect a typedef type to only have 1 typedef layer.
384    In other words, we really expect the target type of a typedef type to be
385    a non-typedef type.  This is particularly true for Ada units, because
386    the language does not have a typedef vs not-typedef distinction.
387    In that respect, the Ada compiler has been trying to eliminate as many
388    typedef definitions in the debugging information, since they generally
389    do not bring any extra information (we still use typedef under certain
390    circumstances related mostly to the GNAT encoding).
391
392    Unfortunately, we have seen situations where the debugging information
393    generated by the compiler leads to such multiple typedef layers.  For
394    instance, consider the following example with stabs:
395
396      .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
397      .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
398
399    This is an error in the debugging information which causes type
400    pck__float_array___XUP to be defined twice, and the second time,
401    it is defined as a typedef of a typedef.
402
403    This is on the fringe of legality as far as debugging information is
404    concerned, and certainly unexpected.  But it is easy to handle these
405    situations correctly, so we can afford to be lenient in this case.  */
406
407 static struct type *
408 ada_typedef_target_type (struct type *type)
409 {
410   while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
411     type = TYPE_TARGET_TYPE (type);
412   return type;
413 }
414
415 /* Given DECODED_NAME a string holding a symbol name in its
416    decoded form (ie using the Ada dotted notation), returns
417    its unqualified name.  */
418
419 static const char *
420 ada_unqualified_name (const char *decoded_name)
421 {
422   const char *result = strrchr (decoded_name, '.');
423
424   if (result != NULL)
425     result++;                   /* Skip the dot...  */
426   else
427     result = decoded_name;
428
429   return result;
430 }
431
432 /* Return a string starting with '<', followed by STR, and '>'.
433    The result is good until the next call.  */
434
435 static char *
436 add_angle_brackets (const char *str)
437 {
438   static char *result = NULL;
439
440   xfree (result);
441   result = xstrprintf ("<%s>", str);
442   return result;
443 }
444
445 static char *
446 ada_get_gdb_completer_word_break_characters (void)
447 {
448   return ada_completer_word_break_characters;
449 }
450
451 /* Print an array element index using the Ada syntax.  */
452
453 static void
454 ada_print_array_index (struct value *index_value, struct ui_file *stream,
455                        const struct value_print_options *options)
456 {
457   LA_VALUE_PRINT (index_value, stream, options);
458   fprintf_filtered (stream, " => ");
459 }
460
461 /* Assuming VECT points to an array of *SIZE objects of size
462    ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
463    updating *SIZE as necessary and returning the (new) array.  */
464
465 void *
466 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
467 {
468   if (*size < min_size)
469     {
470       *size *= 2;
471       if (*size < min_size)
472         *size = min_size;
473       vect = xrealloc (vect, *size * element_size);
474     }
475   return vect;
476 }
477
478 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
479    suffix of FIELD_NAME beginning "___".  */
480
481 static int
482 field_name_match (const char *field_name, const char *target)
483 {
484   int len = strlen (target);
485
486   return
487     (strncmp (field_name, target, len) == 0
488      && (field_name[len] == '\0'
489          || (strncmp (field_name + len, "___", 3) == 0
490              && strcmp (field_name + strlen (field_name) - 6,
491                         "___XVN") != 0)));
492 }
493
494
495 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
496    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
497    and return its index.  This function also handles fields whose name
498    have ___ suffixes because the compiler sometimes alters their name
499    by adding such a suffix to represent fields with certain constraints.
500    If the field could not be found, return a negative number if
501    MAYBE_MISSING is set.  Otherwise raise an error.  */
502
503 int
504 ada_get_field_index (const struct type *type, const char *field_name,
505                      int maybe_missing)
506 {
507   int fieldno;
508   struct type *struct_type = check_typedef ((struct type *) type);
509
510   for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
511     if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
512       return fieldno;
513
514   if (!maybe_missing)
515     error (_("Unable to find field %s in struct %s.  Aborting"),
516            field_name, TYPE_NAME (struct_type));
517
518   return -1;
519 }
520
521 /* The length of the prefix of NAME prior to any "___" suffix.  */
522
523 int
524 ada_name_prefix_len (const char *name)
525 {
526   if (name == NULL)
527     return 0;
528   else
529     {
530       const char *p = strstr (name, "___");
531
532       if (p == NULL)
533         return strlen (name);
534       else
535         return p - name;
536     }
537 }
538
539 /* Return non-zero if SUFFIX is a suffix of STR.
540    Return zero if STR is null.  */
541
542 static int
543 is_suffix (const char *str, const char *suffix)
544 {
545   int len1, len2;
546
547   if (str == NULL)
548     return 0;
549   len1 = strlen (str);
550   len2 = strlen (suffix);
551   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
552 }
553
554 /* The contents of value VAL, treated as a value of type TYPE.  The
555    result is an lval in memory if VAL is.  */
556
557 static struct value *
558 coerce_unspec_val_to_type (struct value *val, struct type *type)
559 {
560   type = ada_check_typedef (type);
561   if (value_type (val) == type)
562     return val;
563   else
564     {
565       struct value *result;
566
567       /* Make sure that the object size is not unreasonable before
568          trying to allocate some memory for it.  */
569       check_size (type);
570
571       if (value_lazy (val)
572           || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
573         result = allocate_value_lazy (type);
574       else
575         {
576           result = allocate_value (type);
577           memcpy (value_contents_raw (result), value_contents (val),
578                   TYPE_LENGTH (type));
579         }
580       set_value_component_location (result, val);
581       set_value_bitsize (result, value_bitsize (val));
582       set_value_bitpos (result, value_bitpos (val));
583       set_value_address (result, value_address (val));
584       set_value_optimized_out (result, value_optimized_out (val));
585       return result;
586     }
587 }
588
589 static const gdb_byte *
590 cond_offset_host (const gdb_byte *valaddr, long offset)
591 {
592   if (valaddr == NULL)
593     return NULL;
594   else
595     return valaddr + offset;
596 }
597
598 static CORE_ADDR
599 cond_offset_target (CORE_ADDR address, long offset)
600 {
601   if (address == 0)
602     return 0;
603   else
604     return address + offset;
605 }
606
607 /* Issue a warning (as for the definition of warning in utils.c, but
608    with exactly one argument rather than ...), unless the limit on the
609    number of warnings has passed during the evaluation of the current
610    expression.  */
611
612 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
613    provided by "complaint".  */
614 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
615
616 static void
617 lim_warning (const char *format, ...)
618 {
619   va_list args;
620
621   va_start (args, format);
622   warnings_issued += 1;
623   if (warnings_issued <= warning_limit)
624     vwarning (format, args);
625
626   va_end (args);
627 }
628
629 /* Issue an error if the size of an object of type T is unreasonable,
630    i.e. if it would be a bad idea to allocate a value of this type in
631    GDB.  */
632
633 static void
634 check_size (const struct type *type)
635 {
636   if (TYPE_LENGTH (type) > varsize_limit)
637     error (_("object size is larger than varsize-limit"));
638 }
639
640 /* Maximum value of a SIZE-byte signed integer type.  */
641 static LONGEST
642 max_of_size (int size)
643 {
644   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
645
646   return top_bit | (top_bit - 1);
647 }
648
649 /* Minimum value of a SIZE-byte signed integer type.  */
650 static LONGEST
651 min_of_size (int size)
652 {
653   return -max_of_size (size) - 1;
654 }
655
656 /* Maximum value of a SIZE-byte unsigned integer type.  */
657 static ULONGEST
658 umax_of_size (int size)
659 {
660   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
661
662   return top_bit | (top_bit - 1);
663 }
664
665 /* Maximum value of integral type T, as a signed quantity.  */
666 static LONGEST
667 max_of_type (struct type *t)
668 {
669   if (TYPE_UNSIGNED (t))
670     return (LONGEST) umax_of_size (TYPE_LENGTH (t));
671   else
672     return max_of_size (TYPE_LENGTH (t));
673 }
674
675 /* Minimum value of integral type T, as a signed quantity.  */
676 static LONGEST
677 min_of_type (struct type *t)
678 {
679   if (TYPE_UNSIGNED (t)) 
680     return 0;
681   else
682     return min_of_size (TYPE_LENGTH (t));
683 }
684
685 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
686 LONGEST
687 ada_discrete_type_high_bound (struct type *type)
688 {
689   switch (TYPE_CODE (type))
690     {
691     case TYPE_CODE_RANGE:
692       return TYPE_HIGH_BOUND (type);
693     case TYPE_CODE_ENUM:
694       return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
695     case TYPE_CODE_BOOL:
696       return 1;
697     case TYPE_CODE_CHAR:
698     case TYPE_CODE_INT:
699       return max_of_type (type);
700     default:
701       error (_("Unexpected type in ada_discrete_type_high_bound."));
702     }
703 }
704
705 /* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
706 LONGEST
707 ada_discrete_type_low_bound (struct type *type)
708 {
709   switch (TYPE_CODE (type))
710     {
711     case TYPE_CODE_RANGE:
712       return TYPE_LOW_BOUND (type);
713     case TYPE_CODE_ENUM:
714       return TYPE_FIELD_ENUMVAL (type, 0);
715     case TYPE_CODE_BOOL:
716       return 0;
717     case TYPE_CODE_CHAR:
718     case TYPE_CODE_INT:
719       return min_of_type (type);
720     default:
721       error (_("Unexpected type in ada_discrete_type_low_bound."));
722     }
723 }
724
725 /* The identity on non-range types.  For range types, the underlying
726    non-range scalar type.  */
727
728 static struct type *
729 get_base_type (struct type *type)
730 {
731   while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
732     {
733       if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
734         return type;
735       type = TYPE_TARGET_TYPE (type);
736     }
737   return type;
738 }
739
740 /* Return a decoded version of the given VALUE.  This means returning
741    a value whose type is obtained by applying all the GNAT-specific
742    encondings, making the resulting type a static but standard description
743    of the initial type.  */
744
745 struct value *
746 ada_get_decoded_value (struct value *value)
747 {
748   struct type *type = ada_check_typedef (value_type (value));
749
750   if (ada_is_array_descriptor_type (type)
751       || (ada_is_constrained_packed_array_type (type)
752           && TYPE_CODE (type) != TYPE_CODE_PTR))
753     {
754       if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)  /* array access type.  */
755         value = ada_coerce_to_simple_array_ptr (value);
756       else
757         value = ada_coerce_to_simple_array (value);
758     }
759   else
760     value = ada_to_fixed_value (value);
761
762   return value;
763 }
764
765 /* Same as ada_get_decoded_value, but with the given TYPE.
766    Because there is no associated actual value for this type,
767    the resulting type might be a best-effort approximation in
768    the case of dynamic types.  */
769
770 struct type *
771 ada_get_decoded_type (struct type *type)
772 {
773   type = to_static_fixed_type (type);
774   if (ada_is_constrained_packed_array_type (type))
775     type = ada_coerce_to_simple_array_type (type);
776   return type;
777 }
778
779 \f
780
781                                 /* Language Selection */
782
783 /* If the main program is in Ada, return language_ada, otherwise return LANG
784    (the main program is in Ada iif the adainit symbol is found).  */
785
786 enum language
787 ada_update_initial_language (enum language lang)
788 {
789   if (lookup_minimal_symbol ("adainit", (const char *) NULL,
790                              (struct objfile *) NULL) != NULL)
791     return language_ada;
792
793   return lang;
794 }
795
796 /* If the main procedure is written in Ada, then return its name.
797    The result is good until the next call.  Return NULL if the main
798    procedure doesn't appear to be in Ada.  */
799
800 char *
801 ada_main_name (void)
802 {
803   struct minimal_symbol *msym;
804   static char *main_program_name = NULL;
805
806   /* For Ada, the name of the main procedure is stored in a specific
807      string constant, generated by the binder.  Look for that symbol,
808      extract its address, and then read that string.  If we didn't find
809      that string, then most probably the main procedure is not written
810      in Ada.  */
811   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
812
813   if (msym != NULL)
814     {
815       CORE_ADDR main_program_name_addr;
816       int err_code;
817
818       main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
819       if (main_program_name_addr == 0)
820         error (_("Invalid address for Ada main program name."));
821
822       xfree (main_program_name);
823       target_read_string (main_program_name_addr, &main_program_name,
824                           1024, &err_code);
825
826       if (err_code != 0)
827         return NULL;
828       return main_program_name;
829     }
830
831   /* The main procedure doesn't seem to be in Ada.  */
832   return NULL;
833 }
834 \f
835                                 /* Symbols */
836
837 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
838    of NULLs.  */
839
840 const struct ada_opname_map ada_opname_table[] = {
841   {"Oadd", "\"+\"", BINOP_ADD},
842   {"Osubtract", "\"-\"", BINOP_SUB},
843   {"Omultiply", "\"*\"", BINOP_MUL},
844   {"Odivide", "\"/\"", BINOP_DIV},
845   {"Omod", "\"mod\"", BINOP_MOD},
846   {"Orem", "\"rem\"", BINOP_REM},
847   {"Oexpon", "\"**\"", BINOP_EXP},
848   {"Olt", "\"<\"", BINOP_LESS},
849   {"Ole", "\"<=\"", BINOP_LEQ},
850   {"Ogt", "\">\"", BINOP_GTR},
851   {"Oge", "\">=\"", BINOP_GEQ},
852   {"Oeq", "\"=\"", BINOP_EQUAL},
853   {"One", "\"/=\"", BINOP_NOTEQUAL},
854   {"Oand", "\"and\"", BINOP_BITWISE_AND},
855   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
856   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
857   {"Oconcat", "\"&\"", BINOP_CONCAT},
858   {"Oabs", "\"abs\"", UNOP_ABS},
859   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
860   {"Oadd", "\"+\"", UNOP_PLUS},
861   {"Osubtract", "\"-\"", UNOP_NEG},
862   {NULL, NULL}
863 };
864
865 /* The "encoded" form of DECODED, according to GNAT conventions.
866    The result is valid until the next call to ada_encode.  */
867
868 char *
869 ada_encode (const char *decoded)
870 {
871   static char *encoding_buffer = NULL;
872   static size_t encoding_buffer_size = 0;
873   const char *p;
874   int k;
875
876   if (decoded == NULL)
877     return NULL;
878
879   GROW_VECT (encoding_buffer, encoding_buffer_size,
880              2 * strlen (decoded) + 10);
881
882   k = 0;
883   for (p = decoded; *p != '\0'; p += 1)
884     {
885       if (*p == '.')
886         {
887           encoding_buffer[k] = encoding_buffer[k + 1] = '_';
888           k += 2;
889         }
890       else if (*p == '"')
891         {
892           const struct ada_opname_map *mapping;
893
894           for (mapping = ada_opname_table;
895                mapping->encoded != NULL
896                && strncmp (mapping->decoded, p,
897                            strlen (mapping->decoded)) != 0; mapping += 1)
898             ;
899           if (mapping->encoded == NULL)
900             error (_("invalid Ada operator name: %s"), p);
901           strcpy (encoding_buffer + k, mapping->encoded);
902           k += strlen (mapping->encoded);
903           break;
904         }
905       else
906         {
907           encoding_buffer[k] = *p;
908           k += 1;
909         }
910     }
911
912   encoding_buffer[k] = '\0';
913   return encoding_buffer;
914 }
915
916 /* Return NAME folded to lower case, or, if surrounded by single
917    quotes, unfolded, but with the quotes stripped away.  Result good
918    to next call.  */
919
920 char *
921 ada_fold_name (const char *name)
922 {
923   static char *fold_buffer = NULL;
924   static size_t fold_buffer_size = 0;
925
926   int len = strlen (name);
927   GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
928
929   if (name[0] == '\'')
930     {
931       strncpy (fold_buffer, name + 1, len - 2);
932       fold_buffer[len - 2] = '\000';
933     }
934   else
935     {
936       int i;
937
938       for (i = 0; i <= len; i += 1)
939         fold_buffer[i] = tolower (name[i]);
940     }
941
942   return fold_buffer;
943 }
944
945 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
946
947 static int
948 is_lower_alphanum (const char c)
949 {
950   return (isdigit (c) || (isalpha (c) && islower (c)));
951 }
952
953 /* ENCODED is the linkage name of a symbol and LEN contains its length.
954    This function saves in LEN the length of that same symbol name but
955    without either of these suffixes:
956      . .{DIGIT}+
957      . ${DIGIT}+
958      . ___{DIGIT}+
959      . __{DIGIT}+.
960
961    These are suffixes introduced by the compiler for entities such as
962    nested subprogram for instance, in order to avoid name clashes.
963    They do not serve any purpose for the debugger.  */
964
965 static void
966 ada_remove_trailing_digits (const char *encoded, int *len)
967 {
968   if (*len > 1 && isdigit (encoded[*len - 1]))
969     {
970       int i = *len - 2;
971
972       while (i > 0 && isdigit (encoded[i]))
973         i--;
974       if (i >= 0 && encoded[i] == '.')
975         *len = i;
976       else if (i >= 0 && encoded[i] == '$')
977         *len = i;
978       else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
979         *len = i - 2;
980       else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
981         *len = i - 1;
982     }
983 }
984
985 /* Remove the suffix introduced by the compiler for protected object
986    subprograms.  */
987
988 static void
989 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
990 {
991   /* Remove trailing N.  */
992
993   /* Protected entry subprograms are broken into two
994      separate subprograms: The first one is unprotected, and has
995      a 'N' suffix; the second is the protected version, and has
996      the 'P' suffix.  The second calls the first one after handling
997      the protection.  Since the P subprograms are internally generated,
998      we leave these names undecoded, giving the user a clue that this
999      entity is internal.  */
1000
1001   if (*len > 1
1002       && encoded[*len - 1] == 'N'
1003       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1004     *len = *len - 1;
1005 }
1006
1007 /* Remove trailing X[bn]* suffixes (indicating names in package bodies).  */
1008
1009 static void
1010 ada_remove_Xbn_suffix (const char *encoded, int *len)
1011 {
1012   int i = *len - 1;
1013
1014   while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1015     i--;
1016
1017   if (encoded[i] != 'X')
1018     return;
1019
1020   if (i == 0)
1021     return;
1022
1023   if (isalnum (encoded[i-1]))
1024     *len = i;
1025 }
1026
1027 /* If ENCODED follows the GNAT entity encoding conventions, then return
1028    the decoded form of ENCODED.  Otherwise, return "<%s>" where "%s" is
1029    replaced by ENCODED.
1030
1031    The resulting string is valid until the next call of ada_decode.
1032    If the string is unchanged by decoding, the original string pointer
1033    is returned.  */
1034
1035 const char *
1036 ada_decode (const char *encoded)
1037 {
1038   int i, j;
1039   int len0;
1040   const char *p;
1041   char *decoded;
1042   int at_start_name;
1043   static char *decoding_buffer = NULL;
1044   static size_t decoding_buffer_size = 0;
1045
1046   /* The name of the Ada main procedure starts with "_ada_".
1047      This prefix is not part of the decoded name, so skip this part
1048      if we see this prefix.  */
1049   if (strncmp (encoded, "_ada_", 5) == 0)
1050     encoded += 5;
1051
1052   /* If the name starts with '_', then it is not a properly encoded
1053      name, so do not attempt to decode it.  Similarly, if the name
1054      starts with '<', the name should not be decoded.  */
1055   if (encoded[0] == '_' || encoded[0] == '<')
1056     goto Suppress;
1057
1058   len0 = strlen (encoded);
1059
1060   ada_remove_trailing_digits (encoded, &len0);
1061   ada_remove_po_subprogram_suffix (encoded, &len0);
1062
1063   /* Remove the ___X.* suffix if present.  Do not forget to verify that
1064      the suffix is located before the current "end" of ENCODED.  We want
1065      to avoid re-matching parts of ENCODED that have previously been
1066      marked as discarded (by decrementing LEN0).  */
1067   p = strstr (encoded, "___");
1068   if (p != NULL && p - encoded < len0 - 3)
1069     {
1070       if (p[3] == 'X')
1071         len0 = p - encoded;
1072       else
1073         goto Suppress;
1074     }
1075
1076   /* Remove any trailing TKB suffix.  It tells us that this symbol
1077      is for the body of a task, but that information does not actually
1078      appear in the decoded name.  */
1079
1080   if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
1081     len0 -= 3;
1082
1083   /* Remove any trailing TB suffix.  The TB suffix is slightly different
1084      from the TKB suffix because it is used for non-anonymous task
1085      bodies.  */
1086
1087   if (len0 > 2 && strncmp (encoded + len0 - 2, "TB", 2) == 0)
1088     len0 -= 2;
1089
1090   /* Remove trailing "B" suffixes.  */
1091   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
1092
1093   if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
1094     len0 -= 1;
1095
1096   /* Make decoded big enough for possible expansion by operator name.  */
1097
1098   GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1099   decoded = decoding_buffer;
1100
1101   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
1102
1103   if (len0 > 1 && isdigit (encoded[len0 - 1]))
1104     {
1105       i = len0 - 2;
1106       while ((i >= 0 && isdigit (encoded[i]))
1107              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1108         i -= 1;
1109       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1110         len0 = i - 1;
1111       else if (encoded[i] == '$')
1112         len0 = i;
1113     }
1114
1115   /* The first few characters that are not alphabetic are not part
1116      of any encoding we use, so we can copy them over verbatim.  */
1117
1118   for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1119     decoded[j] = encoded[i];
1120
1121   at_start_name = 1;
1122   while (i < len0)
1123     {
1124       /* Is this a symbol function?  */
1125       if (at_start_name && encoded[i] == 'O')
1126         {
1127           int k;
1128
1129           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1130             {
1131               int op_len = strlen (ada_opname_table[k].encoded);
1132               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1133                             op_len - 1) == 0)
1134                   && !isalnum (encoded[i + op_len]))
1135                 {
1136                   strcpy (decoded + j, ada_opname_table[k].decoded);
1137                   at_start_name = 0;
1138                   i += op_len;
1139                   j += strlen (ada_opname_table[k].decoded);
1140                   break;
1141                 }
1142             }
1143           if (ada_opname_table[k].encoded != NULL)
1144             continue;
1145         }
1146       at_start_name = 0;
1147
1148       /* Replace "TK__" with "__", which will eventually be translated
1149          into "." (just below).  */
1150
1151       if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
1152         i += 2;
1153
1154       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1155          be translated into "." (just below).  These are internal names
1156          generated for anonymous blocks inside which our symbol is nested.  */
1157
1158       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1159           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1160           && isdigit (encoded [i+4]))
1161         {
1162           int k = i + 5;
1163           
1164           while (k < len0 && isdigit (encoded[k]))
1165             k++;  /* Skip any extra digit.  */
1166
1167           /* Double-check that the "__B_{DIGITS}+" sequence we found
1168              is indeed followed by "__".  */
1169           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1170             i = k;
1171         }
1172
1173       /* Remove _E{DIGITS}+[sb] */
1174
1175       /* Just as for protected object subprograms, there are 2 categories
1176          of subprograms created by the compiler for each entry.  The first
1177          one implements the actual entry code, and has a suffix following
1178          the convention above; the second one implements the barrier and
1179          uses the same convention as above, except that the 'E' is replaced
1180          by a 'B'.
1181
1182          Just as above, we do not decode the name of barrier functions
1183          to give the user a clue that the code he is debugging has been
1184          internally generated.  */
1185
1186       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1187           && isdigit (encoded[i+2]))
1188         {
1189           int k = i + 3;
1190
1191           while (k < len0 && isdigit (encoded[k]))
1192             k++;
1193
1194           if (k < len0
1195               && (encoded[k] == 'b' || encoded[k] == 's'))
1196             {
1197               k++;
1198               /* Just as an extra precaution, make sure that if this
1199                  suffix is followed by anything else, it is a '_'.
1200                  Otherwise, we matched this sequence by accident.  */
1201               if (k == len0
1202                   || (k < len0 && encoded[k] == '_'))
1203                 i = k;
1204             }
1205         }
1206
1207       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1208          the GNAT front-end in protected object subprograms.  */
1209
1210       if (i < len0 + 3
1211           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1212         {
1213           /* Backtrack a bit up until we reach either the begining of
1214              the encoded name, or "__".  Make sure that we only find
1215              digits or lowercase characters.  */
1216           const char *ptr = encoded + i - 1;
1217
1218           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1219             ptr--;
1220           if (ptr < encoded
1221               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1222             i++;
1223         }
1224
1225       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1226         {
1227           /* This is a X[bn]* sequence not separated from the previous
1228              part of the name with a non-alpha-numeric character (in other
1229              words, immediately following an alpha-numeric character), then
1230              verify that it is placed at the end of the encoded name.  If
1231              not, then the encoding is not valid and we should abort the
1232              decoding.  Otherwise, just skip it, it is used in body-nested
1233              package names.  */
1234           do
1235             i += 1;
1236           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1237           if (i < len0)
1238             goto Suppress;
1239         }
1240       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1241         {
1242          /* Replace '__' by '.'.  */
1243           decoded[j] = '.';
1244           at_start_name = 1;
1245           i += 2;
1246           j += 1;
1247         }
1248       else
1249         {
1250           /* It's a character part of the decoded name, so just copy it
1251              over.  */
1252           decoded[j] = encoded[i];
1253           i += 1;
1254           j += 1;
1255         }
1256     }
1257   decoded[j] = '\000';
1258
1259   /* Decoded names should never contain any uppercase character.
1260      Double-check this, and abort the decoding if we find one.  */
1261
1262   for (i = 0; decoded[i] != '\0'; i += 1)
1263     if (isupper (decoded[i]) || decoded[i] == ' ')
1264       goto Suppress;
1265
1266   if (strcmp (decoded, encoded) == 0)
1267     return encoded;
1268   else
1269     return decoded;
1270
1271 Suppress:
1272   GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1273   decoded = decoding_buffer;
1274   if (encoded[0] == '<')
1275     strcpy (decoded, encoded);
1276   else
1277     xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
1278   return decoded;
1279
1280 }
1281
1282 /* Table for keeping permanent unique copies of decoded names.  Once
1283    allocated, names in this table are never released.  While this is a
1284    storage leak, it should not be significant unless there are massive
1285    changes in the set of decoded names in successive versions of a 
1286    symbol table loaded during a single session.  */
1287 static struct htab *decoded_names_store;
1288
1289 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1290    in the language-specific part of GSYMBOL, if it has not been
1291    previously computed.  Tries to save the decoded name in the same
1292    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1293    in any case, the decoded symbol has a lifetime at least that of
1294    GSYMBOL).
1295    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1296    const, but nevertheless modified to a semantically equivalent form
1297    when a decoded name is cached in it.  */
1298
1299 const char *
1300 ada_decode_symbol (const struct general_symbol_info *gsymbol)
1301 {
1302   const char **resultp =
1303     (const char **) &gsymbol->language_specific.mangled_lang.demangled_name;
1304
1305   if (*resultp == NULL)
1306     {
1307       const char *decoded = ada_decode (gsymbol->name);
1308
1309       if (gsymbol->obj_section != NULL)
1310         {
1311           struct objfile *objf = gsymbol->obj_section->objfile;
1312
1313           *resultp = obstack_copy0 (&objf->objfile_obstack,
1314                                     decoded, strlen (decoded));
1315         }
1316       /* Sometimes, we can't find a corresponding objfile, in which
1317          case, we put the result on the heap.  Since we only decode
1318          when needed, we hope this usually does not cause a
1319          significant memory leak (FIXME).  */
1320       if (*resultp == NULL)
1321         {
1322           char **slot = (char **) htab_find_slot (decoded_names_store,
1323                                                   decoded, INSERT);
1324
1325           if (*slot == NULL)
1326             *slot = xstrdup (decoded);
1327           *resultp = *slot;
1328         }
1329     }
1330
1331   return *resultp;
1332 }
1333
1334 static char *
1335 ada_la_decode (const char *encoded, int options)
1336 {
1337   return xstrdup (ada_decode (encoded));
1338 }
1339
1340 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1341    suffixes that encode debugging information or leading _ada_ on
1342    SYM_NAME (see is_name_suffix commentary for the debugging
1343    information that is ignored).  If WILD, then NAME need only match a
1344    suffix of SYM_NAME minus the same suffixes.  Also returns 0 if
1345    either argument is NULL.  */
1346
1347 static int
1348 match_name (const char *sym_name, const char *name, int wild)
1349 {
1350   if (sym_name == NULL || name == NULL)
1351     return 0;
1352   else if (wild)
1353     return wild_match (sym_name, name) == 0;
1354   else
1355     {
1356       int len_name = strlen (name);
1357
1358       return (strncmp (sym_name, name, len_name) == 0
1359               && is_name_suffix (sym_name + len_name))
1360         || (strncmp (sym_name, "_ada_", 5) == 0
1361             && strncmp (sym_name + 5, name, len_name) == 0
1362             && is_name_suffix (sym_name + len_name + 5));
1363     }
1364 }
1365 \f
1366
1367                                 /* Arrays */
1368
1369 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1370    generated by the GNAT compiler to describe the index type used
1371    for each dimension of an array, check whether it follows the latest
1372    known encoding.  If not, fix it up to conform to the latest encoding.
1373    Otherwise, do nothing.  This function also does nothing if
1374    INDEX_DESC_TYPE is NULL.
1375
1376    The GNAT encoding used to describle the array index type evolved a bit.
1377    Initially, the information would be provided through the name of each
1378    field of the structure type only, while the type of these fields was
1379    described as unspecified and irrelevant.  The debugger was then expected
1380    to perform a global type lookup using the name of that field in order
1381    to get access to the full index type description.  Because these global
1382    lookups can be very expensive, the encoding was later enhanced to make
1383    the global lookup unnecessary by defining the field type as being
1384    the full index type description.
1385
1386    The purpose of this routine is to allow us to support older versions
1387    of the compiler by detecting the use of the older encoding, and by
1388    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1389    we essentially replace each field's meaningless type by the associated
1390    index subtype).  */
1391
1392 void
1393 ada_fixup_array_indexes_type (struct type *index_desc_type)
1394 {
1395   int i;
1396
1397   if (index_desc_type == NULL)
1398     return;
1399   gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1400
1401   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1402      to check one field only, no need to check them all).  If not, return
1403      now.
1404
1405      If our INDEX_DESC_TYPE was generated using the older encoding,
1406      the field type should be a meaningless integer type whose name
1407      is not equal to the field name.  */
1408   if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1409       && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1410                  TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1411     return;
1412
1413   /* Fixup each field of INDEX_DESC_TYPE.  */
1414   for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1415    {
1416      const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1417      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1418
1419      if (raw_type)
1420        TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1421    }
1422 }
1423
1424 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors.  */
1425
1426 static char *bound_name[] = {
1427   "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1428   "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1429 };
1430
1431 /* Maximum number of array dimensions we are prepared to handle.  */
1432
1433 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1434
1435
1436 /* The desc_* routines return primitive portions of array descriptors
1437    (fat pointers).  */
1438
1439 /* The descriptor or array type, if any, indicated by TYPE; removes
1440    level of indirection, if needed.  */
1441
1442 static struct type *
1443 desc_base_type (struct type *type)
1444 {
1445   if (type == NULL)
1446     return NULL;
1447   type = ada_check_typedef (type);
1448   if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1449     type = ada_typedef_target_type (type);
1450
1451   if (type != NULL
1452       && (TYPE_CODE (type) == TYPE_CODE_PTR
1453           || TYPE_CODE (type) == TYPE_CODE_REF))
1454     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1455   else
1456     return type;
1457 }
1458
1459 /* True iff TYPE indicates a "thin" array pointer type.  */
1460
1461 static int
1462 is_thin_pntr (struct type *type)
1463 {
1464   return
1465     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1466     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1467 }
1468
1469 /* The descriptor type for thin pointer type TYPE.  */
1470
1471 static struct type *
1472 thin_descriptor_type (struct type *type)
1473 {
1474   struct type *base_type = desc_base_type (type);
1475
1476   if (base_type == NULL)
1477     return NULL;
1478   if (is_suffix (ada_type_name (base_type), "___XVE"))
1479     return base_type;
1480   else
1481     {
1482       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1483
1484       if (alt_type == NULL)
1485         return base_type;
1486       else
1487         return alt_type;
1488     }
1489 }
1490
1491 /* A pointer to the array data for thin-pointer value VAL.  */
1492
1493 static struct value *
1494 thin_data_pntr (struct value *val)
1495 {
1496   struct type *type = ada_check_typedef (value_type (val));
1497   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1498
1499   data_type = lookup_pointer_type (data_type);
1500
1501   if (TYPE_CODE (type) == TYPE_CODE_PTR)
1502     return value_cast (data_type, value_copy (val));
1503   else
1504     return value_from_longest (data_type, value_address (val));
1505 }
1506
1507 /* True iff TYPE indicates a "thick" array pointer type.  */
1508
1509 static int
1510 is_thick_pntr (struct type *type)
1511 {
1512   type = desc_base_type (type);
1513   return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1514           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1515 }
1516
1517 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1518    pointer to one, the type of its bounds data; otherwise, NULL.  */
1519
1520 static struct type *
1521 desc_bounds_type (struct type *type)
1522 {
1523   struct type *r;
1524
1525   type = desc_base_type (type);
1526
1527   if (type == NULL)
1528     return NULL;
1529   else if (is_thin_pntr (type))
1530     {
1531       type = thin_descriptor_type (type);
1532       if (type == NULL)
1533         return NULL;
1534       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1535       if (r != NULL)
1536         return ada_check_typedef (r);
1537     }
1538   else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1539     {
1540       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1541       if (r != NULL)
1542         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1543     }
1544   return NULL;
1545 }
1546
1547 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1548    one, a pointer to its bounds data.   Otherwise NULL.  */
1549
1550 static struct value *
1551 desc_bounds (struct value *arr)
1552 {
1553   struct type *type = ada_check_typedef (value_type (arr));
1554
1555   if (is_thin_pntr (type))
1556     {
1557       struct type *bounds_type =
1558         desc_bounds_type (thin_descriptor_type (type));
1559       LONGEST addr;
1560
1561       if (bounds_type == NULL)
1562         error (_("Bad GNAT array descriptor"));
1563
1564       /* NOTE: The following calculation is not really kosher, but
1565          since desc_type is an XVE-encoded type (and shouldn't be),
1566          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1567       if (TYPE_CODE (type) == TYPE_CODE_PTR)
1568         addr = value_as_long (arr);
1569       else
1570         addr = value_address (arr);
1571
1572       return
1573         value_from_longest (lookup_pointer_type (bounds_type),
1574                             addr - TYPE_LENGTH (bounds_type));
1575     }
1576
1577   else if (is_thick_pntr (type))
1578     {
1579       struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1580                                                _("Bad GNAT array descriptor"));
1581       struct type *p_bounds_type = value_type (p_bounds);
1582
1583       if (p_bounds_type
1584           && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1585         {
1586           struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1587
1588           if (TYPE_STUB (target_type))
1589             p_bounds = value_cast (lookup_pointer_type
1590                                    (ada_check_typedef (target_type)),
1591                                    p_bounds);
1592         }
1593       else
1594         error (_("Bad GNAT array descriptor"));
1595
1596       return p_bounds;
1597     }
1598   else
1599     return NULL;
1600 }
1601
1602 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1603    position of the field containing the address of the bounds data.  */
1604
1605 static int
1606 fat_pntr_bounds_bitpos (struct type *type)
1607 {
1608   return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1609 }
1610
1611 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1612    size of the field containing the address of the bounds data.  */
1613
1614 static int
1615 fat_pntr_bounds_bitsize (struct type *type)
1616 {
1617   type = desc_base_type (type);
1618
1619   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1620     return TYPE_FIELD_BITSIZE (type, 1);
1621   else
1622     return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1623 }
1624
1625 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1626    pointer to one, the type of its array data (a array-with-no-bounds type);
1627    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1628    data.  */
1629
1630 static struct type *
1631 desc_data_target_type (struct type *type)
1632 {
1633   type = desc_base_type (type);
1634
1635   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1636   if (is_thin_pntr (type))
1637     return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
1638   else if (is_thick_pntr (type))
1639     {
1640       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1641
1642       if (data_type
1643           && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
1644         return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1645     }
1646
1647   return NULL;
1648 }
1649
1650 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1651    its array data.  */
1652
1653 static struct value *
1654 desc_data (struct value *arr)
1655 {
1656   struct type *type = value_type (arr);
1657
1658   if (is_thin_pntr (type))
1659     return thin_data_pntr (arr);
1660   else if (is_thick_pntr (type))
1661     return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1662                              _("Bad GNAT array descriptor"));
1663   else
1664     return NULL;
1665 }
1666
1667
1668 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1669    position of the field containing the address of the data.  */
1670
1671 static int
1672 fat_pntr_data_bitpos (struct type *type)
1673 {
1674   return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1675 }
1676
1677 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1678    size of the field containing the address of the data.  */
1679
1680 static int
1681 fat_pntr_data_bitsize (struct type *type)
1682 {
1683   type = desc_base_type (type);
1684
1685   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1686     return TYPE_FIELD_BITSIZE (type, 0);
1687   else
1688     return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1689 }
1690
1691 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1692    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1693    bound, if WHICH is 1.  The first bound is I=1.  */
1694
1695 static struct value *
1696 desc_one_bound (struct value *bounds, int i, int which)
1697 {
1698   return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1699                            _("Bad GNAT array descriptor bounds"));
1700 }
1701
1702 /* If BOUNDS is an array-bounds structure type, return the bit position
1703    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1704    bound, if WHICH is 1.  The first bound is I=1.  */
1705
1706 static int
1707 desc_bound_bitpos (struct type *type, int i, int which)
1708 {
1709   return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1710 }
1711
1712 /* If BOUNDS is an array-bounds structure type, return the bit field size
1713    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1714    bound, if WHICH is 1.  The first bound is I=1.  */
1715
1716 static int
1717 desc_bound_bitsize (struct type *type, int i, int which)
1718 {
1719   type = desc_base_type (type);
1720
1721   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1722     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1723   else
1724     return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1725 }
1726
1727 /* If TYPE is the type of an array-bounds structure, the type of its
1728    Ith bound (numbering from 1).  Otherwise, NULL.  */
1729
1730 static struct type *
1731 desc_index_type (struct type *type, int i)
1732 {
1733   type = desc_base_type (type);
1734
1735   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1736     return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1737   else
1738     return NULL;
1739 }
1740
1741 /* The number of index positions in the array-bounds type TYPE.
1742    Return 0 if TYPE is NULL.  */
1743
1744 static int
1745 desc_arity (struct type *type)
1746 {
1747   type = desc_base_type (type);
1748
1749   if (type != NULL)
1750     return TYPE_NFIELDS (type) / 2;
1751   return 0;
1752 }
1753
1754 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
1755    an array descriptor type (representing an unconstrained array
1756    type).  */
1757
1758 static int
1759 ada_is_direct_array_type (struct type *type)
1760 {
1761   if (type == NULL)
1762     return 0;
1763   type = ada_check_typedef (type);
1764   return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1765           || ada_is_array_descriptor_type (type));
1766 }
1767
1768 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1769  * to one.  */
1770
1771 static int
1772 ada_is_array_type (struct type *type)
1773 {
1774   while (type != NULL 
1775          && (TYPE_CODE (type) == TYPE_CODE_PTR 
1776              || TYPE_CODE (type) == TYPE_CODE_REF))
1777     type = TYPE_TARGET_TYPE (type);
1778   return ada_is_direct_array_type (type);
1779 }
1780
1781 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
1782
1783 int
1784 ada_is_simple_array_type (struct type *type)
1785 {
1786   if (type == NULL)
1787     return 0;
1788   type = ada_check_typedef (type);
1789   return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1790           || (TYPE_CODE (type) == TYPE_CODE_PTR
1791               && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1792                  == TYPE_CODE_ARRAY));
1793 }
1794
1795 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
1796
1797 int
1798 ada_is_array_descriptor_type (struct type *type)
1799 {
1800   struct type *data_type = desc_data_target_type (type);
1801
1802   if (type == NULL)
1803     return 0;
1804   type = ada_check_typedef (type);
1805   return (data_type != NULL
1806           && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1807           && desc_arity (desc_bounds_type (type)) > 0);
1808 }
1809
1810 /* Non-zero iff type is a partially mal-formed GNAT array
1811    descriptor.  FIXME: This is to compensate for some problems with
1812    debugging output from GNAT.  Re-examine periodically to see if it
1813    is still needed.  */
1814
1815 int
1816 ada_is_bogus_array_descriptor (struct type *type)
1817 {
1818   return
1819     type != NULL
1820     && TYPE_CODE (type) == TYPE_CODE_STRUCT
1821     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1822         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1823     && !ada_is_array_descriptor_type (type);
1824 }
1825
1826
1827 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1828    (fat pointer) returns the type of the array data described---specifically,
1829    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
1830    in from the descriptor; otherwise, they are left unspecified.  If
1831    the ARR denotes a null array descriptor and BOUNDS is non-zero,
1832    returns NULL.  The result is simply the type of ARR if ARR is not
1833    a descriptor.  */
1834 struct type *
1835 ada_type_of_array (struct value *arr, int bounds)
1836 {
1837   if (ada_is_constrained_packed_array_type (value_type (arr)))
1838     return decode_constrained_packed_array_type (value_type (arr));
1839
1840   if (!ada_is_array_descriptor_type (value_type (arr)))
1841     return value_type (arr);
1842
1843   if (!bounds)
1844     {
1845       struct type *array_type =
1846         ada_check_typedef (desc_data_target_type (value_type (arr)));
1847
1848       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1849         TYPE_FIELD_BITSIZE (array_type, 0) =
1850           decode_packed_array_bitsize (value_type (arr));
1851       
1852       return array_type;
1853     }
1854   else
1855     {
1856       struct type *elt_type;
1857       int arity;
1858       struct value *descriptor;
1859
1860       elt_type = ada_array_element_type (value_type (arr), -1);
1861       arity = ada_array_arity (value_type (arr));
1862
1863       if (elt_type == NULL || arity == 0)
1864         return ada_check_typedef (value_type (arr));
1865
1866       descriptor = desc_bounds (arr);
1867       if (value_as_long (descriptor) == 0)
1868         return NULL;
1869       while (arity > 0)
1870         {
1871           struct type *range_type = alloc_type_copy (value_type (arr));
1872           struct type *array_type = alloc_type_copy (value_type (arr));
1873           struct value *low = desc_one_bound (descriptor, arity, 0);
1874           struct value *high = desc_one_bound (descriptor, arity, 1);
1875
1876           arity -= 1;
1877           create_range_type (range_type, value_type (low),
1878                              longest_to_int (value_as_long (low)),
1879                              longest_to_int (value_as_long (high)));
1880           elt_type = create_array_type (array_type, elt_type, range_type);
1881
1882           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1883             {
1884               /* We need to store the element packed bitsize, as well as
1885                  recompute the array size, because it was previously
1886                  computed based on the unpacked element size.  */
1887               LONGEST lo = value_as_long (low);
1888               LONGEST hi = value_as_long (high);
1889
1890               TYPE_FIELD_BITSIZE (elt_type, 0) =
1891                 decode_packed_array_bitsize (value_type (arr));
1892               /* If the array has no element, then the size is already
1893                  zero, and does not need to be recomputed.  */
1894               if (lo < hi)
1895                 {
1896                   int array_bitsize =
1897                         (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1898
1899                   TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1900                 }
1901             }
1902         }
1903
1904       return lookup_pointer_type (elt_type);
1905     }
1906 }
1907
1908 /* If ARR does not represent an array, returns ARR unchanged.
1909    Otherwise, returns either a standard GDB array with bounds set
1910    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1911    GDB array.  Returns NULL if ARR is a null fat pointer.  */
1912
1913 struct value *
1914 ada_coerce_to_simple_array_ptr (struct value *arr)
1915 {
1916   if (ada_is_array_descriptor_type (value_type (arr)))
1917     {
1918       struct type *arrType = ada_type_of_array (arr, 1);
1919
1920       if (arrType == NULL)
1921         return NULL;
1922       return value_cast (arrType, value_copy (desc_data (arr)));
1923     }
1924   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1925     return decode_constrained_packed_array (arr);
1926   else
1927     return arr;
1928 }
1929
1930 /* If ARR does not represent an array, returns ARR unchanged.
1931    Otherwise, returns a standard GDB array describing ARR (which may
1932    be ARR itself if it already is in the proper form).  */
1933
1934 struct value *
1935 ada_coerce_to_simple_array (struct value *arr)
1936 {
1937   if (ada_is_array_descriptor_type (value_type (arr)))
1938     {
1939       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1940
1941       if (arrVal == NULL)
1942         error (_("Bounds unavailable for null array pointer."));
1943       check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
1944       return value_ind (arrVal);
1945     }
1946   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1947     return decode_constrained_packed_array (arr);
1948   else
1949     return arr;
1950 }
1951
1952 /* If TYPE represents a GNAT array type, return it translated to an
1953    ordinary GDB array type (possibly with BITSIZE fields indicating
1954    packing).  For other types, is the identity.  */
1955
1956 struct type *
1957 ada_coerce_to_simple_array_type (struct type *type)
1958 {
1959   if (ada_is_constrained_packed_array_type (type))
1960     return decode_constrained_packed_array_type (type);
1961
1962   if (ada_is_array_descriptor_type (type))
1963     return ada_check_typedef (desc_data_target_type (type));
1964
1965   return type;
1966 }
1967
1968 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
1969
1970 static int
1971 ada_is_packed_array_type  (struct type *type)
1972 {
1973   if (type == NULL)
1974     return 0;
1975   type = desc_base_type (type);
1976   type = ada_check_typedef (type);
1977   return
1978     ada_type_name (type) != NULL
1979     && strstr (ada_type_name (type), "___XP") != NULL;
1980 }
1981
1982 /* Non-zero iff TYPE represents a standard GNAT constrained
1983    packed-array type.  */
1984
1985 int
1986 ada_is_constrained_packed_array_type (struct type *type)
1987 {
1988   return ada_is_packed_array_type (type)
1989     && !ada_is_array_descriptor_type (type);
1990 }
1991
1992 /* Non-zero iff TYPE represents an array descriptor for a
1993    unconstrained packed-array type.  */
1994
1995 static int
1996 ada_is_unconstrained_packed_array_type (struct type *type)
1997 {
1998   return ada_is_packed_array_type (type)
1999     && ada_is_array_descriptor_type (type);
2000 }
2001
2002 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2003    return the size of its elements in bits.  */
2004
2005 static long
2006 decode_packed_array_bitsize (struct type *type)
2007 {
2008   const char *raw_name;
2009   const char *tail;
2010   long bits;
2011
2012   /* Access to arrays implemented as fat pointers are encoded as a typedef
2013      of the fat pointer type.  We need the name of the fat pointer type
2014      to do the decoding, so strip the typedef layer.  */
2015   if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2016     type = ada_typedef_target_type (type);
2017
2018   raw_name = ada_type_name (ada_check_typedef (type));
2019   if (!raw_name)
2020     raw_name = ada_type_name (desc_base_type (type));
2021
2022   if (!raw_name)
2023     return 0;
2024
2025   tail = strstr (raw_name, "___XP");
2026   gdb_assert (tail != NULL);
2027
2028   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2029     {
2030       lim_warning
2031         (_("could not understand bit size information on packed array"));
2032       return 0;
2033     }
2034
2035   return bits;
2036 }
2037
2038 /* Given that TYPE is a standard GDB array type with all bounds filled
2039    in, and that the element size of its ultimate scalar constituents
2040    (that is, either its elements, or, if it is an array of arrays, its
2041    elements' elements, etc.) is *ELT_BITS, return an identical type,
2042    but with the bit sizes of its elements (and those of any
2043    constituent arrays) recorded in the BITSIZE components of its
2044    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2045    in bits.  */
2046
2047 static struct type *
2048 constrained_packed_array_type (struct type *type, long *elt_bits)
2049 {
2050   struct type *new_elt_type;
2051   struct type *new_type;
2052   struct type *index_type_desc;
2053   struct type *index_type;
2054   LONGEST low_bound, high_bound;
2055
2056   type = ada_check_typedef (type);
2057   if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2058     return type;
2059
2060   index_type_desc = ada_find_parallel_type (type, "___XA");
2061   if (index_type_desc)
2062     index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2063                                       NULL);
2064   else
2065     index_type = TYPE_INDEX_TYPE (type);
2066
2067   new_type = alloc_type_copy (type);
2068   new_elt_type =
2069     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2070                                    elt_bits);
2071   create_array_type (new_type, new_elt_type, index_type);
2072   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2073   TYPE_NAME (new_type) = ada_type_name (type);
2074
2075   if (get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
2076     low_bound = high_bound = 0;
2077   if (high_bound < low_bound)
2078     *elt_bits = TYPE_LENGTH (new_type) = 0;
2079   else
2080     {
2081       *elt_bits *= (high_bound - low_bound + 1);
2082       TYPE_LENGTH (new_type) =
2083         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2084     }
2085
2086   TYPE_FIXED_INSTANCE (new_type) = 1;
2087   return new_type;
2088 }
2089
2090 /* The array type encoded by TYPE, where
2091    ada_is_constrained_packed_array_type (TYPE).  */
2092
2093 static struct type *
2094 decode_constrained_packed_array_type (struct type *type)
2095 {
2096   const char *raw_name = ada_type_name (ada_check_typedef (type));
2097   char *name;
2098   const char *tail;
2099   struct type *shadow_type;
2100   long bits;
2101
2102   if (!raw_name)
2103     raw_name = ada_type_name (desc_base_type (type));
2104
2105   if (!raw_name)
2106     return NULL;
2107
2108   name = (char *) alloca (strlen (raw_name) + 1);
2109   tail = strstr (raw_name, "___XP");
2110   type = desc_base_type (type);
2111
2112   memcpy (name, raw_name, tail - raw_name);
2113   name[tail - raw_name] = '\000';
2114
2115   shadow_type = ada_find_parallel_type_with_name (type, name);
2116
2117   if (shadow_type == NULL)
2118     {
2119       lim_warning (_("could not find bounds information on packed array"));
2120       return NULL;
2121     }
2122   CHECK_TYPEDEF (shadow_type);
2123
2124   if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2125     {
2126       lim_warning (_("could not understand bounds "
2127                      "information on packed array"));
2128       return NULL;
2129     }
2130
2131   bits = decode_packed_array_bitsize (type);
2132   return constrained_packed_array_type (shadow_type, &bits);
2133 }
2134
2135 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2136    array, returns a simple array that denotes that array.  Its type is a
2137    standard GDB array type except that the BITSIZEs of the array
2138    target types are set to the number of bits in each element, and the
2139    type length is set appropriately.  */
2140
2141 static struct value *
2142 decode_constrained_packed_array (struct value *arr)
2143 {
2144   struct type *type;
2145
2146   arr = ada_coerce_ref (arr);
2147
2148   /* If our value is a pointer, then dererence it.  Make sure that
2149      this operation does not cause the target type to be fixed, as
2150      this would indirectly cause this array to be decoded.  The rest
2151      of the routine assumes that the array hasn't been decoded yet,
2152      so we use the basic "value_ind" routine to perform the dereferencing,
2153      as opposed to using "ada_value_ind".  */
2154   if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
2155     arr = value_ind (arr);
2156
2157   type = decode_constrained_packed_array_type (value_type (arr));
2158   if (type == NULL)
2159     {
2160       error (_("can't unpack array"));
2161       return NULL;
2162     }
2163
2164   if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
2165       && ada_is_modular_type (value_type (arr)))
2166     {
2167        /* This is a (right-justified) modular type representing a packed
2168          array with no wrapper.  In order to interpret the value through
2169          the (left-justified) packed array type we just built, we must
2170          first left-justify it.  */
2171       int bit_size, bit_pos;
2172       ULONGEST mod;
2173
2174       mod = ada_modulus (value_type (arr)) - 1;
2175       bit_size = 0;
2176       while (mod > 0)
2177         {
2178           bit_size += 1;
2179           mod >>= 1;
2180         }
2181       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2182       arr = ada_value_primitive_packed_val (arr, NULL,
2183                                             bit_pos / HOST_CHAR_BIT,
2184                                             bit_pos % HOST_CHAR_BIT,
2185                                             bit_size,
2186                                             type);
2187     }
2188
2189   return coerce_unspec_val_to_type (arr, type);
2190 }
2191
2192
2193 /* The value of the element of packed array ARR at the ARITY indices
2194    given in IND.   ARR must be a simple array.  */
2195
2196 static struct value *
2197 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2198 {
2199   int i;
2200   int bits, elt_off, bit_off;
2201   long elt_total_bit_offset;
2202   struct type *elt_type;
2203   struct value *v;
2204
2205   bits = 0;
2206   elt_total_bit_offset = 0;
2207   elt_type = ada_check_typedef (value_type (arr));
2208   for (i = 0; i < arity; i += 1)
2209     {
2210       if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
2211           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2212         error
2213           (_("attempt to do packed indexing of "
2214              "something other than a packed array"));
2215       else
2216         {
2217           struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2218           LONGEST lowerbound, upperbound;
2219           LONGEST idx;
2220
2221           if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2222             {
2223               lim_warning (_("don't know bounds of array"));
2224               lowerbound = upperbound = 0;
2225             }
2226
2227           idx = pos_atr (ind[i]);
2228           if (idx < lowerbound || idx > upperbound)
2229             lim_warning (_("packed array index %ld out of bounds"),
2230                          (long) idx);
2231           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2232           elt_total_bit_offset += (idx - lowerbound) * bits;
2233           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2234         }
2235     }
2236   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2237   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2238
2239   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2240                                       bits, elt_type);
2241   return v;
2242 }
2243
2244 /* Non-zero iff TYPE includes negative integer values.  */
2245
2246 static int
2247 has_negatives (struct type *type)
2248 {
2249   switch (TYPE_CODE (type))
2250     {
2251     default:
2252       return 0;
2253     case TYPE_CODE_INT:
2254       return !TYPE_UNSIGNED (type);
2255     case TYPE_CODE_RANGE:
2256       return TYPE_LOW_BOUND (type) < 0;
2257     }
2258 }
2259
2260
2261 /* Create a new value of type TYPE from the contents of OBJ starting
2262    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2263    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2264    assigning through the result will set the field fetched from.
2265    VALADDR is ignored unless OBJ is NULL, in which case,
2266    VALADDR+OFFSET must address the start of storage containing the 
2267    packed value.  The value returned  in this case is never an lval.
2268    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2269
2270 struct value *
2271 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2272                                 long offset, int bit_offset, int bit_size,
2273                                 struct type *type)
2274 {
2275   struct value *v;
2276   int src,                      /* Index into the source area */
2277     targ,                       /* Index into the target area */
2278     srcBitsLeft,                /* Number of source bits left to move */
2279     nsrc, ntarg,                /* Number of source and target bytes */
2280     unusedLS,                   /* Number of bits in next significant
2281                                    byte of source that are unused */
2282     accumSize;                  /* Number of meaningful bits in accum */
2283   unsigned char *bytes;         /* First byte containing data to unpack */
2284   unsigned char *unpacked;
2285   unsigned long accum;          /* Staging area for bits being transferred */
2286   unsigned char sign;
2287   int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2288   /* Transmit bytes from least to most significant; delta is the direction
2289      the indices move.  */
2290   int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1;
2291
2292   type = ada_check_typedef (type);
2293
2294   if (obj == NULL)
2295     {
2296       v = allocate_value (type);
2297       bytes = (unsigned char *) (valaddr + offset);
2298     }
2299   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2300     {
2301       v = value_at (type, value_address (obj));
2302       bytes = (unsigned char *) alloca (len);
2303       read_memory (value_address (v) + offset, bytes, len);
2304     }
2305   else
2306     {
2307       v = allocate_value (type);
2308       bytes = (unsigned char *) value_contents (obj) + offset;
2309     }
2310
2311   if (obj != NULL)
2312     {
2313       long new_offset = offset;
2314
2315       set_value_component_location (v, obj);
2316       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2317       set_value_bitsize (v, bit_size);
2318       if (value_bitpos (v) >= HOST_CHAR_BIT)
2319         {
2320           ++new_offset;
2321           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2322         }
2323       set_value_offset (v, new_offset);
2324
2325       /* Also set the parent value.  This is needed when trying to
2326          assign a new value (in inferior memory).  */
2327       set_value_parent (v, obj);
2328       value_incref (obj);
2329     }
2330   else
2331     set_value_bitsize (v, bit_size);
2332   unpacked = (unsigned char *) value_contents (v);
2333
2334   srcBitsLeft = bit_size;
2335   nsrc = len;
2336   ntarg = TYPE_LENGTH (type);
2337   sign = 0;
2338   if (bit_size == 0)
2339     {
2340       memset (unpacked, 0, TYPE_LENGTH (type));
2341       return v;
2342     }
2343   else if (gdbarch_bits_big_endian (get_type_arch (type)))
2344     {
2345       src = len - 1;
2346       if (has_negatives (type)
2347           && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2348         sign = ~0;
2349
2350       unusedLS =
2351         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2352         % HOST_CHAR_BIT;
2353
2354       switch (TYPE_CODE (type))
2355         {
2356         case TYPE_CODE_ARRAY:
2357         case TYPE_CODE_UNION:
2358         case TYPE_CODE_STRUCT:
2359           /* Non-scalar values must be aligned at a byte boundary...  */
2360           accumSize =
2361             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2362           /* ... And are placed at the beginning (most-significant) bytes
2363              of the target.  */
2364           targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2365           ntarg = targ + 1;
2366           break;
2367         default:
2368           accumSize = 0;
2369           targ = TYPE_LENGTH (type) - 1;
2370           break;
2371         }
2372     }
2373   else
2374     {
2375       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2376
2377       src = targ = 0;
2378       unusedLS = bit_offset;
2379       accumSize = 0;
2380
2381       if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
2382         sign = ~0;
2383     }
2384
2385   accum = 0;
2386   while (nsrc > 0)
2387     {
2388       /* Mask for removing bits of the next source byte that are not
2389          part of the value.  */
2390       unsigned int unusedMSMask =
2391         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2392         1;
2393       /* Sign-extend bits for this byte.  */
2394       unsigned int signMask = sign & ~unusedMSMask;
2395
2396       accum |=
2397         (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2398       accumSize += HOST_CHAR_BIT - unusedLS;
2399       if (accumSize >= HOST_CHAR_BIT)
2400         {
2401           unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2402           accumSize -= HOST_CHAR_BIT;
2403           accum >>= HOST_CHAR_BIT;
2404           ntarg -= 1;
2405           targ += delta;
2406         }
2407       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2408       unusedLS = 0;
2409       nsrc -= 1;
2410       src += delta;
2411     }
2412   while (ntarg > 0)
2413     {
2414       accum |= sign << accumSize;
2415       unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2416       accumSize -= HOST_CHAR_BIT;
2417       accum >>= HOST_CHAR_BIT;
2418       ntarg -= 1;
2419       targ += delta;
2420     }
2421
2422   return v;
2423 }
2424
2425 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2426    TARGET, starting at bit offset TARG_OFFSET.  SOURCE and TARGET must
2427    not overlap.  */
2428 static void
2429 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
2430            int src_offset, int n, int bits_big_endian_p)
2431 {
2432   unsigned int accum, mask;
2433   int accum_bits, chunk_size;
2434
2435   target += targ_offset / HOST_CHAR_BIT;
2436   targ_offset %= HOST_CHAR_BIT;
2437   source += src_offset / HOST_CHAR_BIT;
2438   src_offset %= HOST_CHAR_BIT;
2439   if (bits_big_endian_p)
2440     {
2441       accum = (unsigned char) *source;
2442       source += 1;
2443       accum_bits = HOST_CHAR_BIT - src_offset;
2444
2445       while (n > 0)
2446         {
2447           int unused_right;
2448
2449           accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2450           accum_bits += HOST_CHAR_BIT;
2451           source += 1;
2452           chunk_size = HOST_CHAR_BIT - targ_offset;
2453           if (chunk_size > n)
2454             chunk_size = n;
2455           unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2456           mask = ((1 << chunk_size) - 1) << unused_right;
2457           *target =
2458             (*target & ~mask)
2459             | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2460           n -= chunk_size;
2461           accum_bits -= chunk_size;
2462           target += 1;
2463           targ_offset = 0;
2464         }
2465     }
2466   else
2467     {
2468       accum = (unsigned char) *source >> src_offset;
2469       source += 1;
2470       accum_bits = HOST_CHAR_BIT - src_offset;
2471
2472       while (n > 0)
2473         {
2474           accum = accum + ((unsigned char) *source << accum_bits);
2475           accum_bits += HOST_CHAR_BIT;
2476           source += 1;
2477           chunk_size = HOST_CHAR_BIT - targ_offset;
2478           if (chunk_size > n)
2479             chunk_size = n;
2480           mask = ((1 << chunk_size) - 1) << targ_offset;
2481           *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2482           n -= chunk_size;
2483           accum_bits -= chunk_size;
2484           accum >>= chunk_size;
2485           target += 1;
2486           targ_offset = 0;
2487         }
2488     }
2489 }
2490
2491 /* Store the contents of FROMVAL into the location of TOVAL.
2492    Return a new value with the location of TOVAL and contents of
2493    FROMVAL.   Handles assignment into packed fields that have
2494    floating-point or non-scalar types.  */
2495
2496 static struct value *
2497 ada_value_assign (struct value *toval, struct value *fromval)
2498 {
2499   struct type *type = value_type (toval);
2500   int bits = value_bitsize (toval);
2501
2502   toval = ada_coerce_ref (toval);
2503   fromval = ada_coerce_ref (fromval);
2504
2505   if (ada_is_direct_array_type (value_type (toval)))
2506     toval = ada_coerce_to_simple_array (toval);
2507   if (ada_is_direct_array_type (value_type (fromval)))
2508     fromval = ada_coerce_to_simple_array (fromval);
2509
2510   if (!deprecated_value_modifiable (toval))
2511     error (_("Left operand of assignment is not a modifiable lvalue."));
2512
2513   if (VALUE_LVAL (toval) == lval_memory
2514       && bits > 0
2515       && (TYPE_CODE (type) == TYPE_CODE_FLT
2516           || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2517     {
2518       int len = (value_bitpos (toval)
2519                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2520       int from_size;
2521       char *buffer = (char *) alloca (len);
2522       struct value *val;
2523       CORE_ADDR to_addr = value_address (toval);
2524
2525       if (TYPE_CODE (type) == TYPE_CODE_FLT)
2526         fromval = value_cast (type, fromval);
2527
2528       read_memory (to_addr, buffer, len);
2529       from_size = value_bitsize (fromval);
2530       if (from_size == 0)
2531         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2532       if (gdbarch_bits_big_endian (get_type_arch (type)))
2533         move_bits (buffer, value_bitpos (toval),
2534                    value_contents (fromval), from_size - bits, bits, 1);
2535       else
2536         move_bits (buffer, value_bitpos (toval),
2537                    value_contents (fromval), 0, bits, 0);
2538       write_memory_with_notification (to_addr, buffer, len);
2539
2540       val = value_copy (toval);
2541       memcpy (value_contents_raw (val), value_contents (fromval),
2542               TYPE_LENGTH (type));
2543       deprecated_set_value_type (val, type);
2544
2545       return val;
2546     }
2547
2548   return value_assign (toval, fromval);
2549 }
2550
2551
2552 /* Given that COMPONENT is a memory lvalue that is part of the lvalue 
2553  * CONTAINER, assign the contents of VAL to COMPONENTS's place in 
2554  * CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not 
2555  * COMPONENT, and not the inferior's memory.  The current contents 
2556  * of COMPONENT are ignored.  */
2557 static void
2558 value_assign_to_component (struct value *container, struct value *component,
2559                            struct value *val)
2560 {
2561   LONGEST offset_in_container =
2562     (LONGEST)  (value_address (component) - value_address (container));
2563   int bit_offset_in_container = 
2564     value_bitpos (component) - value_bitpos (container);
2565   int bits;
2566   
2567   val = value_cast (value_type (component), val);
2568
2569   if (value_bitsize (component) == 0)
2570     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2571   else
2572     bits = value_bitsize (component);
2573
2574   if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2575     move_bits (value_contents_writeable (container) + offset_in_container, 
2576                value_bitpos (container) + bit_offset_in_container,
2577                value_contents (val),
2578                TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2579                bits, 1);
2580   else
2581     move_bits (value_contents_writeable (container) + offset_in_container, 
2582                value_bitpos (container) + bit_offset_in_container,
2583                value_contents (val), 0, bits, 0);
2584 }              
2585                         
2586 /* The value of the element of array ARR at the ARITY indices given in IND.
2587    ARR may be either a simple array, GNAT array descriptor, or pointer
2588    thereto.  */
2589
2590 struct value *
2591 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2592 {
2593   int k;
2594   struct value *elt;
2595   struct type *elt_type;
2596
2597   elt = ada_coerce_to_simple_array (arr);
2598
2599   elt_type = ada_check_typedef (value_type (elt));
2600   if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2601       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2602     return value_subscript_packed (elt, arity, ind);
2603
2604   for (k = 0; k < arity; k += 1)
2605     {
2606       if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2607         error (_("too many subscripts (%d expected)"), k);
2608       elt = value_subscript (elt, pos_atr (ind[k]));
2609     }
2610   return elt;
2611 }
2612
2613 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2614    value of the element of *ARR at the ARITY indices given in
2615    IND.  Does not read the entire array into memory.  */
2616
2617 static struct value *
2618 ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
2619                          struct value **ind)
2620 {
2621   int k;
2622
2623   for (k = 0; k < arity; k += 1)
2624     {
2625       LONGEST lwb, upb;
2626
2627       if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2628         error (_("too many subscripts (%d expected)"), k);
2629       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2630                         value_copy (arr));
2631       get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2632       arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
2633       type = TYPE_TARGET_TYPE (type);
2634     }
2635
2636   return value_ind (arr);
2637 }
2638
2639 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2640    actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2641    elements starting at index LOW.  The lower bound of this array is LOW, as
2642    per Ada rules.  */
2643 static struct value *
2644 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2645                           int low, int high)
2646 {
2647   struct type *type0 = ada_check_typedef (type);
2648   CORE_ADDR base = value_as_address (array_ptr)
2649     + ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)))
2650        * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
2651   struct type *index_type =
2652     create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)),
2653                        low, high);
2654   struct type *slice_type =
2655     create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
2656
2657   return value_at_lazy (slice_type, base);
2658 }
2659
2660
2661 static struct value *
2662 ada_value_slice (struct value *array, int low, int high)
2663 {
2664   struct type *type = ada_check_typedef (value_type (array));
2665   struct type *index_type =
2666     create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2667   struct type *slice_type =
2668     create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2669
2670   return value_cast (slice_type, value_slice (array, low, high - low + 1));
2671 }
2672
2673 /* If type is a record type in the form of a standard GNAT array
2674    descriptor, returns the number of dimensions for type.  If arr is a
2675    simple array, returns the number of "array of"s that prefix its
2676    type designation.  Otherwise, returns 0.  */
2677
2678 int
2679 ada_array_arity (struct type *type)
2680 {
2681   int arity;
2682
2683   if (type == NULL)
2684     return 0;
2685
2686   type = desc_base_type (type);
2687
2688   arity = 0;
2689   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2690     return desc_arity (desc_bounds_type (type));
2691   else
2692     while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2693       {
2694         arity += 1;
2695         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2696       }
2697
2698   return arity;
2699 }
2700
2701 /* If TYPE is a record type in the form of a standard GNAT array
2702    descriptor or a simple array type, returns the element type for
2703    TYPE after indexing by NINDICES indices, or by all indices if
2704    NINDICES is -1.  Otherwise, returns NULL.  */
2705
2706 struct type *
2707 ada_array_element_type (struct type *type, int nindices)
2708 {
2709   type = desc_base_type (type);
2710
2711   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2712     {
2713       int k;
2714       struct type *p_array_type;
2715
2716       p_array_type = desc_data_target_type (type);
2717
2718       k = ada_array_arity (type);
2719       if (k == 0)
2720         return NULL;
2721
2722       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
2723       if (nindices >= 0 && k > nindices)
2724         k = nindices;
2725       while (k > 0 && p_array_type != NULL)
2726         {
2727           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2728           k -= 1;
2729         }
2730       return p_array_type;
2731     }
2732   else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2733     {
2734       while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
2735         {
2736           type = TYPE_TARGET_TYPE (type);
2737           nindices -= 1;
2738         }
2739       return type;
2740     }
2741
2742   return NULL;
2743 }
2744
2745 /* The type of nth index in arrays of given type (n numbering from 1).
2746    Does not examine memory.  Throws an error if N is invalid or TYPE
2747    is not an array type.  NAME is the name of the Ada attribute being
2748    evaluated ('range, 'first, 'last, or 'length); it is used in building
2749    the error message.  */
2750
2751 static struct type *
2752 ada_index_type (struct type *type, int n, const char *name)
2753 {
2754   struct type *result_type;
2755
2756   type = desc_base_type (type);
2757
2758   if (n < 0 || n > ada_array_arity (type))
2759     error (_("invalid dimension number to '%s"), name);
2760
2761   if (ada_is_simple_array_type (type))
2762     {
2763       int i;
2764
2765       for (i = 1; i < n; i += 1)
2766         type = TYPE_TARGET_TYPE (type);
2767       result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2768       /* FIXME: The stabs type r(0,0);bound;bound in an array type
2769          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
2770          perhaps stabsread.c would make more sense.  */
2771       if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2772         result_type = NULL;
2773     }
2774   else
2775     {
2776       result_type = desc_index_type (desc_bounds_type (type), n);
2777       if (result_type == NULL)
2778         error (_("attempt to take bound of something that is not an array"));
2779     }
2780
2781   return result_type;
2782 }
2783
2784 /* Given that arr is an array type, returns the lower bound of the
2785    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2786    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
2787    array-descriptor type.  It works for other arrays with bounds supplied
2788    by run-time quantities other than discriminants.  */
2789
2790 static LONGEST
2791 ada_array_bound_from_type (struct type * arr_type, int n, int which)
2792 {
2793   struct type *type, *elt_type, *index_type_desc, *index_type;
2794   int i;
2795
2796   gdb_assert (which == 0 || which == 1);
2797
2798   if (ada_is_constrained_packed_array_type (arr_type))
2799     arr_type = decode_constrained_packed_array_type (arr_type);
2800
2801   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2802     return (LONGEST) - which;
2803
2804   if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2805     type = TYPE_TARGET_TYPE (arr_type);
2806   else
2807     type = arr_type;
2808
2809   elt_type = type;
2810   for (i = n; i > 1; i--)
2811     elt_type = TYPE_TARGET_TYPE (type);
2812
2813   index_type_desc = ada_find_parallel_type (type, "___XA");
2814   ada_fixup_array_indexes_type (index_type_desc);
2815   if (index_type_desc != NULL)
2816     index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2817                                       NULL);
2818   else
2819     index_type = TYPE_INDEX_TYPE (elt_type);
2820
2821   return
2822     (LONGEST) (which == 0
2823                ? ada_discrete_type_low_bound (index_type)
2824                : ada_discrete_type_high_bound (index_type));
2825 }
2826
2827 /* Given that arr is an array value, returns the lower bound of the
2828    nth index (numbering from 1) if WHICH is 0, and the upper bound if
2829    WHICH is 1.  This routine will also work for arrays with bounds
2830    supplied by run-time quantities other than discriminants.  */
2831
2832 static LONGEST
2833 ada_array_bound (struct value *arr, int n, int which)
2834 {
2835   struct type *arr_type = value_type (arr);
2836
2837   if (ada_is_constrained_packed_array_type (arr_type))
2838     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
2839   else if (ada_is_simple_array_type (arr_type))
2840     return ada_array_bound_from_type (arr_type, n, which);
2841   else
2842     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
2843 }
2844
2845 /* Given that arr is an array value, returns the length of the
2846    nth index.  This routine will also work for arrays with bounds
2847    supplied by run-time quantities other than discriminants.
2848    Does not work for arrays indexed by enumeration types with representation
2849    clauses at the moment.  */
2850
2851 static LONGEST
2852 ada_array_length (struct value *arr, int n)
2853 {
2854   struct type *arr_type = ada_check_typedef (value_type (arr));
2855
2856   if (ada_is_constrained_packed_array_type (arr_type))
2857     return ada_array_length (decode_constrained_packed_array (arr), n);
2858
2859   if (ada_is_simple_array_type (arr_type))
2860     return (ada_array_bound_from_type (arr_type, n, 1)
2861             - ada_array_bound_from_type (arr_type, n, 0) + 1);
2862   else
2863     return (value_as_long (desc_one_bound (desc_bounds (arr), n, 1))
2864             - value_as_long (desc_one_bound (desc_bounds (arr), n, 0)) + 1);
2865 }
2866
2867 /* An empty array whose type is that of ARR_TYPE (an array type),
2868    with bounds LOW to LOW-1.  */
2869
2870 static struct value *
2871 empty_array (struct type *arr_type, int low)
2872 {
2873   struct type *arr_type0 = ada_check_typedef (arr_type);
2874   struct type *index_type =
2875     create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)),
2876                        low, low - 1);
2877   struct type *elt_type = ada_array_element_type (arr_type0, 1);
2878
2879   return allocate_value (create_array_type (NULL, elt_type, index_type));
2880 }
2881 \f
2882
2883                                 /* Name resolution */
2884
2885 /* The "decoded" name for the user-definable Ada operator corresponding
2886    to OP.  */
2887
2888 static const char *
2889 ada_decoded_op_name (enum exp_opcode op)
2890 {
2891   int i;
2892
2893   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
2894     {
2895       if (ada_opname_table[i].op == op)
2896         return ada_opname_table[i].decoded;
2897     }
2898   error (_("Could not find operator name for opcode"));
2899 }
2900
2901
2902 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2903    references (marked by OP_VAR_VALUE nodes in which the symbol has an
2904    undefined namespace) and converts operators that are
2905    user-defined into appropriate function calls.  If CONTEXT_TYPE is
2906    non-null, it provides a preferred result type [at the moment, only
2907    type void has any effect---causing procedures to be preferred over
2908    functions in calls].  A null CONTEXT_TYPE indicates that a non-void
2909    return type is preferred.  May change (expand) *EXP.  */
2910
2911 static void
2912 resolve (struct expression **expp, int void_context_p)
2913 {
2914   struct type *context_type = NULL;
2915   int pc = 0;
2916
2917   if (void_context_p)
2918     context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
2919
2920   resolve_subexp (expp, &pc, 1, context_type);
2921 }
2922
2923 /* Resolve the operator of the subexpression beginning at
2924    position *POS of *EXPP.  "Resolving" consists of replacing
2925    the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2926    with their resolutions, replacing built-in operators with
2927    function calls to user-defined operators, where appropriate, and,
2928    when DEPROCEDURE_P is non-zero, converting function-valued variables
2929    into parameterless calls.  May expand *EXPP.  The CONTEXT_TYPE functions
2930    are as in ada_resolve, above.  */
2931
2932 static struct value *
2933 resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
2934                 struct type *context_type)
2935 {
2936   int pc = *pos;
2937   int i;
2938   struct expression *exp;       /* Convenience: == *expp.  */
2939   enum exp_opcode op = (*expp)->elts[pc].opcode;
2940   struct value **argvec;        /* Vector of operand types (alloca'ed).  */
2941   int nargs;                    /* Number of operands.  */
2942   int oplen;
2943
2944   argvec = NULL;
2945   nargs = 0;
2946   exp = *expp;
2947
2948   /* Pass one: resolve operands, saving their types and updating *pos,
2949      if needed.  */
2950   switch (op)
2951     {
2952     case OP_FUNCALL:
2953       if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
2954           && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2955         *pos += 7;
2956       else
2957         {
2958           *pos += 3;
2959           resolve_subexp (expp, pos, 0, NULL);
2960         }
2961       nargs = longest_to_int (exp->elts[pc + 1].longconst);
2962       break;
2963
2964     case UNOP_ADDR:
2965       *pos += 1;
2966       resolve_subexp (expp, pos, 0, NULL);
2967       break;
2968
2969     case UNOP_QUAL:
2970       *pos += 3;
2971       resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
2972       break;
2973
2974     case OP_ATR_MODULUS:
2975     case OP_ATR_SIZE:
2976     case OP_ATR_TAG:
2977     case OP_ATR_FIRST:
2978     case OP_ATR_LAST:
2979     case OP_ATR_LENGTH:
2980     case OP_ATR_POS:
2981     case OP_ATR_VAL:
2982     case OP_ATR_MIN:
2983     case OP_ATR_MAX:
2984     case TERNOP_IN_RANGE:
2985     case BINOP_IN_BOUNDS:
2986     case UNOP_IN_RANGE:
2987     case OP_AGGREGATE:
2988     case OP_OTHERS:
2989     case OP_CHOICES:
2990     case OP_POSITIONAL:
2991     case OP_DISCRETE_RANGE:
2992     case OP_NAME:
2993       ada_forward_operator_length (exp, pc, &oplen, &nargs);
2994       *pos += oplen;
2995       break;
2996
2997     case BINOP_ASSIGN:
2998       {
2999         struct value *arg1;
3000
3001         *pos += 1;
3002         arg1 = resolve_subexp (expp, pos, 0, NULL);
3003         if (arg1 == NULL)
3004           resolve_subexp (expp, pos, 1, NULL);
3005         else
3006           resolve_subexp (expp, pos, 1, value_type (arg1));
3007         break;
3008       }
3009
3010     case UNOP_CAST:
3011       *pos += 3;
3012       nargs = 1;
3013       break;
3014
3015     case BINOP_ADD:
3016     case BINOP_SUB:
3017     case BINOP_MUL:
3018     case BINOP_DIV:
3019     case BINOP_REM:
3020     case BINOP_MOD:
3021     case BINOP_EXP:
3022     case BINOP_CONCAT:
3023     case BINOP_LOGICAL_AND:
3024     case BINOP_LOGICAL_OR:
3025     case BINOP_BITWISE_AND:
3026     case BINOP_BITWISE_IOR:
3027     case BINOP_BITWISE_XOR:
3028
3029     case BINOP_EQUAL:
3030     case BINOP_NOTEQUAL:
3031     case BINOP_LESS:
3032     case BINOP_GTR:
3033     case BINOP_LEQ:
3034     case BINOP_GEQ:
3035
3036     case BINOP_REPEAT:
3037     case BINOP_SUBSCRIPT:
3038     case BINOP_COMMA:
3039       *pos += 1;
3040       nargs = 2;
3041       break;
3042
3043     case UNOP_NEG:
3044     case UNOP_PLUS:
3045     case UNOP_LOGICAL_NOT:
3046     case UNOP_ABS:
3047     case UNOP_IND:
3048       *pos += 1;
3049       nargs = 1;
3050       break;
3051
3052     case OP_LONG:
3053     case OP_DOUBLE:
3054     case OP_VAR_VALUE:
3055       *pos += 4;
3056       break;
3057
3058     case OP_TYPE:
3059     case OP_BOOL:
3060     case OP_LAST:
3061     case OP_INTERNALVAR:
3062       *pos += 3;
3063       break;
3064
3065     case UNOP_MEMVAL:
3066       *pos += 3;
3067       nargs = 1;
3068       break;
3069
3070     case OP_REGISTER:
3071       *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3072       break;
3073
3074     case STRUCTOP_STRUCT:
3075       *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3076       nargs = 1;
3077       break;
3078
3079     case TERNOP_SLICE:
3080       *pos += 1;
3081       nargs = 3;
3082       break;
3083
3084     case OP_STRING:
3085       break;
3086
3087     default:
3088       error (_("Unexpected operator during name resolution"));
3089     }
3090
3091   argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
3092   for (i = 0; i < nargs; i += 1)
3093     argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3094   argvec[i] = NULL;
3095   exp = *expp;
3096
3097   /* Pass two: perform any resolution on principal operator.  */
3098   switch (op)
3099     {
3100     default:
3101       break;
3102
3103     case OP_VAR_VALUE:
3104       if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
3105         {
3106           struct ada_symbol_info *candidates;
3107           int n_candidates;
3108
3109           n_candidates =
3110             ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3111                                     (exp->elts[pc + 2].symbol),
3112                                     exp->elts[pc + 1].block, VAR_DOMAIN,
3113                                     &candidates);
3114
3115           if (n_candidates > 1)
3116             {
3117               /* Types tend to get re-introduced locally, so if there
3118                  are any local symbols that are not types, first filter
3119                  out all types.  */
3120               int j;
3121               for (j = 0; j < n_candidates; j += 1)
3122                 switch (SYMBOL_CLASS (candidates[j].sym))
3123                   {
3124                   case LOC_REGISTER:
3125                   case LOC_ARG:
3126                   case LOC_REF_ARG:
3127                   case LOC_REGPARM_ADDR:
3128                   case LOC_LOCAL:
3129                   case LOC_COMPUTED:
3130                     goto FoundNonType;
3131                   default:
3132                     break;
3133                   }
3134             FoundNonType:
3135               if (j < n_candidates)
3136                 {
3137                   j = 0;
3138                   while (j < n_candidates)
3139                     {
3140                       if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
3141                         {
3142                           candidates[j] = candidates[n_candidates - 1];
3143                           n_candidates -= 1;
3144                         }
3145                       else
3146                         j += 1;
3147                     }
3148                 }
3149             }
3150
3151           if (n_candidates == 0)
3152             error (_("No definition found for %s"),
3153                    SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3154           else if (n_candidates == 1)
3155             i = 0;
3156           else if (deprocedure_p
3157                    && !is_nonfunction (candidates, n_candidates))
3158             {
3159               i = ada_resolve_function
3160                 (candidates, n_candidates, NULL, 0,
3161                  SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3162                  context_type);
3163               if (i < 0)
3164                 error (_("Could not find a match for %s"),
3165                        SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3166             }
3167           else
3168             {
3169               printf_filtered (_("Multiple matches for %s\n"),
3170                                SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3171               user_select_syms (candidates, n_candidates, 1);
3172               i = 0;
3173             }
3174
3175           exp->elts[pc + 1].block = candidates[i].block;
3176           exp->elts[pc + 2].symbol = candidates[i].sym;
3177           if (innermost_block == NULL
3178               || contained_in (candidates[i].block, innermost_block))
3179             innermost_block = candidates[i].block;
3180         }
3181
3182       if (deprocedure_p
3183           && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3184               == TYPE_CODE_FUNC))
3185         {
3186           replace_operator_with_call (expp, pc, 0, 0,
3187                                       exp->elts[pc + 2].symbol,
3188                                       exp->elts[pc + 1].block);
3189           exp = *expp;
3190         }
3191       break;
3192
3193     case OP_FUNCALL:
3194       {
3195         if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3196             && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3197           {
3198             struct ada_symbol_info *candidates;
3199             int n_candidates;
3200
3201             n_candidates =
3202               ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3203                                       (exp->elts[pc + 5].symbol),
3204                                       exp->elts[pc + 4].block, VAR_DOMAIN,
3205                                       &candidates);
3206             if (n_candidates == 1)
3207               i = 0;
3208             else
3209               {
3210                 i = ada_resolve_function
3211                   (candidates, n_candidates,
3212                    argvec, nargs,
3213                    SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3214                    context_type);
3215                 if (i < 0)
3216                   error (_("Could not find a match for %s"),
3217                          SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3218               }
3219
3220             exp->elts[pc + 4].block = candidates[i].block;
3221             exp->elts[pc + 5].symbol = candidates[i].sym;
3222             if (innermost_block == NULL
3223                 || contained_in (candidates[i].block, innermost_block))
3224               innermost_block = candidates[i].block;
3225           }
3226       }
3227       break;
3228     case BINOP_ADD:
3229     case BINOP_SUB:
3230     case BINOP_MUL:
3231     case BINOP_DIV:
3232     case BINOP_REM:
3233     case BINOP_MOD:
3234     case BINOP_CONCAT:
3235     case BINOP_BITWISE_AND:
3236     case BINOP_BITWISE_IOR:
3237     case BINOP_BITWISE_XOR:
3238     case BINOP_EQUAL:
3239     case BINOP_NOTEQUAL:
3240     case BINOP_LESS:
3241     case BINOP_GTR:
3242     case BINOP_LEQ:
3243     case BINOP_GEQ:
3244     case BINOP_EXP:
3245     case UNOP_NEG:
3246     case UNOP_PLUS:
3247     case UNOP_LOGICAL_NOT:
3248     case UNOP_ABS:
3249       if (possible_user_operator_p (op, argvec))
3250         {
3251           struct ada_symbol_info *candidates;
3252           int n_candidates;
3253
3254           n_candidates =
3255             ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3256                                     (struct block *) NULL, VAR_DOMAIN,
3257                                     &candidates);
3258           i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
3259                                     ada_decoded_op_name (op), NULL);
3260           if (i < 0)
3261             break;
3262
3263           replace_operator_with_call (expp, pc, nargs, 1,
3264                                       candidates[i].sym, candidates[i].block);
3265           exp = *expp;
3266         }
3267       break;
3268
3269     case OP_TYPE:
3270     case OP_REGISTER:
3271       return NULL;
3272     }
3273
3274   *pos = pc;
3275   return evaluate_subexp_type (exp, pos);
3276 }
3277
3278 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  If
3279    MAY_DEREF is non-zero, the formal may be a pointer and the actual
3280    a non-pointer.  */
3281 /* The term "match" here is rather loose.  The match is heuristic and
3282    liberal.  */
3283
3284 static int
3285 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3286 {
3287   ftype = ada_check_typedef (ftype);
3288   atype = ada_check_typedef (atype);
3289
3290   if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3291     ftype = TYPE_TARGET_TYPE (ftype);
3292   if (TYPE_CODE (atype) == TYPE_CODE_REF)
3293     atype = TYPE_TARGET_TYPE (atype);
3294
3295   switch (TYPE_CODE (ftype))
3296     {
3297     default:
3298       return TYPE_CODE (ftype) == TYPE_CODE (atype);
3299     case TYPE_CODE_PTR:
3300       if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3301         return ada_type_match (TYPE_TARGET_TYPE (ftype),
3302                                TYPE_TARGET_TYPE (atype), 0);
3303       else
3304         return (may_deref
3305                 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3306     case TYPE_CODE_INT:
3307     case TYPE_CODE_ENUM:
3308     case TYPE_CODE_RANGE:
3309       switch (TYPE_CODE (atype))
3310         {
3311         case TYPE_CODE_INT:
3312         case TYPE_CODE_ENUM:
3313         case TYPE_CODE_RANGE:
3314           return 1;
3315         default:
3316           return 0;
3317         }
3318
3319     case TYPE_CODE_ARRAY:
3320       return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3321               || ada_is_array_descriptor_type (atype));
3322
3323     case TYPE_CODE_STRUCT:
3324       if (ada_is_array_descriptor_type (ftype))
3325         return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3326                 || ada_is_array_descriptor_type (atype));
3327       else
3328         return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3329                 && !ada_is_array_descriptor_type (atype));
3330
3331     case TYPE_CODE_UNION:
3332     case TYPE_CODE_FLT:
3333       return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3334     }
3335 }
3336
3337 /* Return non-zero if the formals of FUNC "sufficiently match" the
3338    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3339    may also be an enumeral, in which case it is treated as a 0-
3340    argument function.  */
3341
3342 static int
3343 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3344 {
3345   int i;
3346   struct type *func_type = SYMBOL_TYPE (func);
3347
3348   if (SYMBOL_CLASS (func) == LOC_CONST
3349       && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3350     return (n_actuals == 0);
3351   else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3352     return 0;
3353
3354   if (TYPE_NFIELDS (func_type) != n_actuals)
3355     return 0;
3356
3357   for (i = 0; i < n_actuals; i += 1)
3358     {
3359       if (actuals[i] == NULL)
3360         return 0;
3361       else
3362         {
3363           struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3364                                                                    i));
3365           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3366
3367           if (!ada_type_match (ftype, atype, 1))
3368             return 0;
3369         }
3370     }
3371   return 1;
3372 }
3373
3374 /* False iff function type FUNC_TYPE definitely does not produce a value
3375    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3376    FUNC_TYPE is not a valid function type with a non-null return type
3377    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3378
3379 static int
3380 return_match (struct type *func_type, struct type *context_type)
3381 {
3382   struct type *return_type;
3383
3384   if (func_type == NULL)
3385     return 1;
3386
3387   if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3388     return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3389   else
3390     return_type = get_base_type (func_type);
3391   if (return_type == NULL)
3392     return 1;
3393
3394   context_type = get_base_type (context_type);
3395
3396   if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3397     return context_type == NULL || return_type == context_type;
3398   else if (context_type == NULL)
3399     return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3400   else
3401     return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3402 }
3403
3404
3405 /* Returns the index in SYMS[0..NSYMS-1] that contains  the symbol for the
3406    function (if any) that matches the types of the NARGS arguments in
3407    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
3408    that returns that type, then eliminate matches that don't.  If
3409    CONTEXT_TYPE is void and there is at least one match that does not
3410    return void, eliminate all matches that do.
3411
3412    Asks the user if there is more than one match remaining.  Returns -1
3413    if there is no such symbol or none is selected.  NAME is used
3414    solely for messages.  May re-arrange and modify SYMS in
3415    the process; the index returned is for the modified vector.  */
3416
3417 static int
3418 ada_resolve_function (struct ada_symbol_info syms[],
3419                       int nsyms, struct value **args, int nargs,
3420                       const char *name, struct type *context_type)
3421 {
3422   int fallback;
3423   int k;
3424   int m;                        /* Number of hits */
3425
3426   m = 0;
3427   /* In the first pass of the loop, we only accept functions matching
3428      context_type.  If none are found, we add a second pass of the loop
3429      where every function is accepted.  */
3430   for (fallback = 0; m == 0 && fallback < 2; fallback++)
3431     {
3432       for (k = 0; k < nsyms; k += 1)
3433         {
3434           struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
3435
3436           if (ada_args_match (syms[k].sym, args, nargs)
3437               && (fallback || return_match (type, context_type)))
3438             {
3439               syms[m] = syms[k];
3440               m += 1;
3441             }
3442         }
3443     }
3444
3445   if (m == 0)
3446     return -1;
3447   else if (m > 1)
3448     {
3449       printf_filtered (_("Multiple matches for %s\n"), name);
3450       user_select_syms (syms, m, 1);
3451       return 0;
3452     }
3453   return 0;
3454 }
3455
3456 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3457    in a listing of choices during disambiguation (see sort_choices, below).
3458    The idea is that overloadings of a subprogram name from the
3459    same package should sort in their source order.  We settle for ordering
3460    such symbols by their trailing number (__N  or $N).  */
3461
3462 static int
3463 encoded_ordered_before (const char *N0, const char *N1)
3464 {
3465   if (N1 == NULL)
3466     return 0;
3467   else if (N0 == NULL)
3468     return 1;
3469   else
3470     {
3471       int k0, k1;
3472
3473       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3474         ;
3475       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3476         ;
3477       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3478           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3479         {
3480           int n0, n1;
3481
3482           n0 = k0;
3483           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3484             n0 -= 1;
3485           n1 = k1;
3486           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3487             n1 -= 1;
3488           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3489             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3490         }
3491       return (strcmp (N0, N1) < 0);
3492     }
3493 }
3494
3495 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3496    encoded names.  */
3497
3498 static void
3499 sort_choices (struct ada_symbol_info syms[], int nsyms)
3500 {
3501   int i;
3502
3503   for (i = 1; i < nsyms; i += 1)
3504     {
3505       struct ada_symbol_info sym = syms[i];
3506       int j;
3507
3508       for (j = i - 1; j >= 0; j -= 1)
3509         {
3510           if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3511                                       SYMBOL_LINKAGE_NAME (sym.sym)))
3512             break;
3513           syms[j + 1] = syms[j];
3514         }
3515       syms[j + 1] = sym;
3516     }
3517 }
3518
3519 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0 
3520    by asking the user (if necessary), returning the number selected, 
3521    and setting the first elements of SYMS items.  Error if no symbols
3522    selected.  */
3523
3524 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3525    to be re-integrated one of these days.  */
3526
3527 int
3528 user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
3529 {
3530   int i;
3531   int *chosen = (int *) alloca (sizeof (int) * nsyms);
3532   int n_chosen;
3533   int first_choice = (max_results == 1) ? 1 : 2;
3534   const char *select_mode = multiple_symbols_select_mode ();
3535
3536   if (max_results < 1)
3537     error (_("Request to select 0 symbols!"));
3538   if (nsyms <= 1)
3539     return nsyms;
3540
3541   if (select_mode == multiple_symbols_cancel)
3542     error (_("\
3543 canceled because the command is ambiguous\n\
3544 See set/show multiple-symbol."));
3545   
3546   /* If select_mode is "all", then return all possible symbols.
3547      Only do that if more than one symbol can be selected, of course.
3548      Otherwise, display the menu as usual.  */
3549   if (select_mode == multiple_symbols_all && max_results > 1)
3550     return nsyms;
3551
3552   printf_unfiltered (_("[0] cancel\n"));
3553   if (max_results > 1)
3554     printf_unfiltered (_("[1] all\n"));
3555
3556   sort_choices (syms, nsyms);
3557
3558   for (i = 0; i < nsyms; i += 1)
3559     {
3560       if (syms[i].sym == NULL)
3561         continue;
3562
3563       if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3564         {
3565           struct symtab_and_line sal =
3566             find_function_start_sal (syms[i].sym, 1);
3567
3568           if (sal.symtab == NULL)
3569             printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3570                                i + first_choice,
3571                                SYMBOL_PRINT_NAME (syms[i].sym),
3572                                sal.line);
3573           else
3574             printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3575                                SYMBOL_PRINT_NAME (syms[i].sym),
3576                                symtab_to_filename_for_display (sal.symtab),
3577                                sal.line);
3578           continue;
3579         }
3580       else
3581         {
3582           int is_enumeral =
3583             (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3584              && SYMBOL_TYPE (syms[i].sym) != NULL
3585              && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
3586           struct symtab *symtab = SYMBOL_SYMTAB (syms[i].sym);
3587
3588           if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
3589             printf_unfiltered (_("[%d] %s at %s:%d\n"),
3590                                i + first_choice,
3591                                SYMBOL_PRINT_NAME (syms[i].sym),
3592                                symtab_to_filename_for_display (symtab),
3593                                SYMBOL_LINE (syms[i].sym));
3594           else if (is_enumeral
3595                    && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
3596             {
3597               printf_unfiltered (("[%d] "), i + first_choice);
3598               ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
3599                               gdb_stdout, -1, 0, &type_print_raw_options);
3600               printf_unfiltered (_("'(%s) (enumeral)\n"),
3601                                  SYMBOL_PRINT_NAME (syms[i].sym));
3602             }
3603           else if (symtab != NULL)
3604             printf_unfiltered (is_enumeral
3605                                ? _("[%d] %s in %s (enumeral)\n")
3606                                : _("[%d] %s at %s:?\n"),
3607                                i + first_choice,
3608                                SYMBOL_PRINT_NAME (syms[i].sym),
3609                                symtab_to_filename_for_display (symtab));
3610           else
3611             printf_unfiltered (is_enumeral
3612                                ? _("[%d] %s (enumeral)\n")
3613                                : _("[%d] %s at ?\n"),
3614                                i + first_choice,
3615                                SYMBOL_PRINT_NAME (syms[i].sym));
3616         }
3617     }
3618
3619   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3620                              "overload-choice");
3621
3622   for (i = 0; i < n_chosen; i += 1)
3623     syms[i] = syms[chosen[i]];
3624
3625   return n_chosen;
3626 }
3627
3628 /* Read and validate a set of numeric choices from the user in the
3629    range 0 .. N_CHOICES-1.  Place the results in increasing
3630    order in CHOICES[0 .. N-1], and return N.
3631
3632    The user types choices as a sequence of numbers on one line
3633    separated by blanks, encoding them as follows:
3634
3635      + A choice of 0 means to cancel the selection, throwing an error.
3636      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3637      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3638
3639    The user is not allowed to choose more than MAX_RESULTS values.
3640
3641    ANNOTATION_SUFFIX, if present, is used to annotate the input
3642    prompts (for use with the -f switch).  */
3643
3644 int
3645 get_selections (int *choices, int n_choices, int max_results,
3646                 int is_all_choice, char *annotation_suffix)
3647 {
3648   char *args;
3649   char *prompt;
3650   int n_chosen;
3651   int first_choice = is_all_choice ? 2 : 1;
3652
3653   prompt = getenv ("PS2");
3654   if (prompt == NULL)
3655     prompt = "> ";
3656
3657   args = command_line_input (prompt, 0, annotation_suffix);
3658
3659   if (args == NULL)
3660     error_no_arg (_("one or more choice numbers"));
3661
3662   n_chosen = 0;
3663
3664   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3665      order, as given in args.  Choices are validated.  */
3666   while (1)
3667     {
3668       char *args2;
3669       int choice, j;
3670
3671       args = skip_spaces (args);
3672       if (*args == '\0' && n_chosen == 0)
3673         error_no_arg (_("one or more choice numbers"));
3674       else if (*args == '\0')
3675         break;
3676
3677       choice = strtol (args, &args2, 10);
3678       if (args == args2 || choice < 0
3679           || choice > n_choices + first_choice - 1)
3680         error (_("Argument must be choice number"));
3681       args = args2;
3682
3683       if (choice == 0)
3684         error (_("cancelled"));
3685
3686       if (choice < first_choice)
3687         {
3688           n_chosen = n_choices;
3689           for (j = 0; j < n_choices; j += 1)
3690             choices[j] = j;
3691           break;
3692         }
3693       choice -= first_choice;
3694
3695       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3696         {
3697         }
3698
3699       if (j < 0 || choice != choices[j])
3700         {
3701           int k;
3702
3703           for (k = n_chosen - 1; k > j; k -= 1)
3704             choices[k + 1] = choices[k];
3705           choices[j + 1] = choice;
3706           n_chosen += 1;
3707         }
3708     }
3709
3710   if (n_chosen > max_results)
3711     error (_("Select no more than %d of the above"), max_results);
3712
3713   return n_chosen;
3714 }
3715
3716 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3717    on the function identified by SYM and BLOCK, and taking NARGS
3718    arguments.  Update *EXPP as needed to hold more space.  */
3719
3720 static void
3721 replace_operator_with_call (struct expression **expp, int pc, int nargs,
3722                             int oplen, struct symbol *sym,
3723                             const struct block *block)
3724 {
3725   /* A new expression, with 6 more elements (3 for funcall, 4 for function
3726      symbol, -oplen for operator being replaced).  */
3727   struct expression *newexp = (struct expression *)
3728     xzalloc (sizeof (struct expression)
3729              + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
3730   struct expression *exp = *expp;
3731
3732   newexp->nelts = exp->nelts + 7 - oplen;
3733   newexp->language_defn = exp->language_defn;
3734   newexp->gdbarch = exp->gdbarch;
3735   memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
3736   memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
3737           EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
3738
3739   newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3740   newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3741
3742   newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3743   newexp->elts[pc + 4].block = block;
3744   newexp->elts[pc + 5].symbol = sym;
3745
3746   *expp = newexp;
3747   xfree (exp);
3748 }
3749
3750 /* Type-class predicates */
3751
3752 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3753    or FLOAT).  */
3754
3755 static int
3756 numeric_type_p (struct type *type)
3757 {
3758   if (type == NULL)
3759     return 0;
3760   else
3761     {
3762       switch (TYPE_CODE (type))
3763         {
3764         case TYPE_CODE_INT:
3765         case TYPE_CODE_FLT:
3766           return 1;
3767         case TYPE_CODE_RANGE:
3768           return (type == TYPE_TARGET_TYPE (type)
3769                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
3770         default:
3771           return 0;
3772         }
3773     }
3774 }
3775
3776 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
3777
3778 static int
3779 integer_type_p (struct type *type)
3780 {
3781   if (type == NULL)
3782     return 0;
3783   else
3784     {
3785       switch (TYPE_CODE (type))
3786         {
3787         case TYPE_CODE_INT:
3788           return 1;
3789         case TYPE_CODE_RANGE:
3790           return (type == TYPE_TARGET_TYPE (type)
3791                   || integer_type_p (TYPE_TARGET_TYPE (type)));
3792         default:
3793           return 0;
3794         }
3795     }
3796 }
3797
3798 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
3799
3800 static int
3801 scalar_type_p (struct type *type)
3802 {
3803   if (type == NULL)
3804     return 0;
3805   else
3806     {
3807       switch (TYPE_CODE (type))
3808         {
3809         case TYPE_CODE_INT:
3810         case TYPE_CODE_RANGE:
3811         case TYPE_CODE_ENUM:
3812         case TYPE_CODE_FLT:
3813           return 1;
3814         default:
3815           return 0;
3816         }
3817     }
3818 }
3819
3820 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
3821
3822 static int
3823 discrete_type_p (struct type *type)
3824 {
3825   if (type == NULL)
3826     return 0;
3827   else
3828     {
3829       switch (TYPE_CODE (type))
3830         {
3831         case TYPE_CODE_INT:
3832         case TYPE_CODE_RANGE:
3833         case TYPE_CODE_ENUM:
3834         case TYPE_CODE_BOOL:
3835           return 1;
3836         default:
3837           return 0;
3838         }
3839     }
3840 }
3841
3842 /* Returns non-zero if OP with operands in the vector ARGS could be
3843    a user-defined function.  Errs on the side of pre-defined operators
3844    (i.e., result 0).  */
3845
3846 static int
3847 possible_user_operator_p (enum exp_opcode op, struct value *args[])
3848 {
3849   struct type *type0 =
3850     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
3851   struct type *type1 =
3852     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
3853
3854   if (type0 == NULL)
3855     return 0;
3856
3857   switch (op)
3858     {
3859     default:
3860       return 0;
3861
3862     case BINOP_ADD:
3863     case BINOP_SUB:
3864     case BINOP_MUL:
3865     case BINOP_DIV:
3866       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
3867
3868     case BINOP_REM:
3869     case BINOP_MOD:
3870     case BINOP_BITWISE_AND:
3871     case BINOP_BITWISE_IOR:
3872     case BINOP_BITWISE_XOR:
3873       return (!(integer_type_p (type0) && integer_type_p (type1)));
3874
3875     case BINOP_EQUAL:
3876     case BINOP_NOTEQUAL:
3877     case BINOP_LESS:
3878     case BINOP_GTR:
3879     case BINOP_LEQ:
3880     case BINOP_GEQ:
3881       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
3882
3883     case BINOP_CONCAT:
3884       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
3885
3886     case BINOP_EXP:
3887       return (!(numeric_type_p (type0) && integer_type_p (type1)));
3888
3889     case UNOP_NEG:
3890     case UNOP_PLUS:
3891     case UNOP_LOGICAL_NOT:
3892     case UNOP_ABS:
3893       return (!numeric_type_p (type0));
3894
3895     }
3896 }
3897 \f
3898                                 /* Renaming */
3899
3900 /* NOTES: 
3901
3902    1. In the following, we assume that a renaming type's name may
3903       have an ___XD suffix.  It would be nice if this went away at some
3904       point.
3905    2. We handle both the (old) purely type-based representation of 
3906       renamings and the (new) variable-based encoding.  At some point,
3907       it is devoutly to be hoped that the former goes away 
3908       (FIXME: hilfinger-2007-07-09).
3909    3. Subprogram renamings are not implemented, although the XRS
3910       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
3911
3912 /* If SYM encodes a renaming, 
3913
3914        <renaming> renames <renamed entity>,
3915
3916    sets *LEN to the length of the renamed entity's name,
3917    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3918    the string describing the subcomponent selected from the renamed
3919    entity.  Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3920    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3921    are undefined).  Otherwise, returns a value indicating the category
3922    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3923    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3924    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
3925    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3926    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3927    may be NULL, in which case they are not assigned.
3928
3929    [Currently, however, GCC does not generate subprogram renamings.]  */
3930
3931 enum ada_renaming_category
3932 ada_parse_renaming (struct symbol *sym,
3933                     const char **renamed_entity, int *len, 
3934                     const char **renaming_expr)
3935 {
3936   enum ada_renaming_category kind;
3937   const char *info;
3938   const char *suffix;
3939
3940   if (sym == NULL)
3941     return ADA_NOT_RENAMING;
3942   switch (SYMBOL_CLASS (sym)) 
3943     {
3944     default:
3945       return ADA_NOT_RENAMING;
3946     case LOC_TYPEDEF:
3947       return parse_old_style_renaming (SYMBOL_TYPE (sym), 
3948                                        renamed_entity, len, renaming_expr);
3949     case LOC_LOCAL:
3950     case LOC_STATIC:
3951     case LOC_COMPUTED:
3952     case LOC_OPTIMIZED_OUT:
3953       info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
3954       if (info == NULL)
3955         return ADA_NOT_RENAMING;
3956       switch (info[5])
3957         {
3958         case '_':
3959           kind = ADA_OBJECT_RENAMING;
3960           info += 6;
3961           break;
3962         case 'E':
3963           kind = ADA_EXCEPTION_RENAMING;
3964           info += 7;
3965           break;
3966         case 'P':
3967           kind = ADA_PACKAGE_RENAMING;
3968           info += 7;
3969           break;
3970         case 'S':
3971           kind = ADA_SUBPROGRAM_RENAMING;
3972           info += 7;
3973           break;
3974         default:
3975           return ADA_NOT_RENAMING;
3976         }
3977     }
3978
3979   if (renamed_entity != NULL)
3980     *renamed_entity = info;
3981   suffix = strstr (info, "___XE");
3982   if (suffix == NULL || suffix == info)
3983     return ADA_NOT_RENAMING;
3984   if (len != NULL)
3985     *len = strlen (info) - strlen (suffix);
3986   suffix += 5;
3987   if (renaming_expr != NULL)
3988     *renaming_expr = suffix;
3989   return kind;
3990 }
3991
3992 /* Assuming TYPE encodes a renaming according to the old encoding in
3993    exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3994    *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above.  Returns
3995    ADA_NOT_RENAMING otherwise.  */
3996 static enum ada_renaming_category
3997 parse_old_style_renaming (struct type *type,
3998                           const char **renamed_entity, int *len, 
3999                           const char **renaming_expr)
4000 {
4001   enum ada_renaming_category kind;
4002   const char *name;
4003   const char *info;
4004   const char *suffix;
4005
4006   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM 
4007       || TYPE_NFIELDS (type) != 1)
4008     return ADA_NOT_RENAMING;
4009
4010   name = type_name_no_tag (type);
4011   if (name == NULL)
4012     return ADA_NOT_RENAMING;
4013   
4014   name = strstr (name, "___XR");
4015   if (name == NULL)
4016     return ADA_NOT_RENAMING;
4017   switch (name[5])
4018     {
4019     case '\0':
4020     case '_':
4021       kind = ADA_OBJECT_RENAMING;
4022       break;
4023     case 'E':
4024       kind = ADA_EXCEPTION_RENAMING;
4025       break;
4026     case 'P':
4027       kind = ADA_PACKAGE_RENAMING;
4028       break;
4029     case 'S':
4030       kind = ADA_SUBPROGRAM_RENAMING;
4031       break;
4032     default:
4033       return ADA_NOT_RENAMING;
4034     }
4035
4036   info = TYPE_FIELD_NAME (type, 0);
4037   if (info == NULL)
4038     return ADA_NOT_RENAMING;
4039   if (renamed_entity != NULL)
4040     *renamed_entity = info;
4041   suffix = strstr (info, "___XE");
4042   if (renaming_expr != NULL)
4043     *renaming_expr = suffix + 5;
4044   if (suffix == NULL || suffix == info)
4045     return ADA_NOT_RENAMING;
4046   if (len != NULL)
4047     *len = suffix - info;
4048   return kind;
4049 }
4050
4051 /* Compute the value of the given RENAMING_SYM, which is expected to
4052    be a symbol encoding a renaming expression.  BLOCK is the block
4053    used to evaluate the renaming.  */
4054
4055 static struct value *
4056 ada_read_renaming_var_value (struct symbol *renaming_sym,
4057                              struct block *block)
4058 {
4059   const char *sym_name;
4060   struct expression *expr;
4061   struct value *value;
4062   struct cleanup *old_chain = NULL;
4063
4064   sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4065   expr = parse_exp_1 (&sym_name, 0, block, 0);
4066   old_chain = make_cleanup (free_current_contents, &expr);
4067   value = evaluate_expression (expr);
4068
4069   do_cleanups (old_chain);
4070   return value;
4071 }
4072 \f
4073
4074                                 /* Evaluation: Function Calls */
4075
4076 /* Return an lvalue containing the value VAL.  This is the identity on
4077    lvalues, and otherwise has the side-effect of allocating memory
4078    in the inferior where a copy of the value contents is copied.  */
4079
4080 static struct value *
4081 ensure_lval (struct value *val)
4082 {
4083   if (VALUE_LVAL (val) == not_lval
4084       || VALUE_LVAL (val) == lval_internalvar)
4085     {
4086       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4087       const CORE_ADDR addr =
4088         value_as_long (value_allocate_space_in_inferior (len));
4089
4090       set_value_address (val, addr);
4091       VALUE_LVAL (val) = lval_memory;
4092       write_memory (addr, value_contents (val), len);
4093     }
4094
4095   return val;
4096 }
4097
4098 /* Return the value ACTUAL, converted to be an appropriate value for a
4099    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
4100    allocating any necessary descriptors (fat pointers), or copies of
4101    values not residing in memory, updating it as needed.  */
4102
4103 struct value *
4104 ada_convert_actual (struct value *actual, struct type *formal_type0)
4105 {
4106   struct type *actual_type = ada_check_typedef (value_type (actual));
4107   struct type *formal_type = ada_check_typedef (formal_type0);
4108   struct type *formal_target =
4109     TYPE_CODE (formal_type) == TYPE_CODE_PTR
4110     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4111   struct type *actual_target =
4112     TYPE_CODE (actual_type) == TYPE_CODE_PTR
4113     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4114
4115   if (ada_is_array_descriptor_type (formal_target)
4116       && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
4117     return make_array_descriptor (formal_type, actual);
4118   else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4119            || TYPE_CODE (formal_type) == TYPE_CODE_REF)
4120     {
4121       struct value *result;
4122
4123       if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4124           && ada_is_array_descriptor_type (actual_target))
4125         result = desc_data (actual);
4126       else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4127         {
4128           if (VALUE_LVAL (actual) != lval_memory)
4129             {
4130               struct value *val;
4131
4132               actual_type = ada_check_typedef (value_type (actual));
4133               val = allocate_value (actual_type);
4134               memcpy ((char *) value_contents_raw (val),
4135                       (char *) value_contents (actual),
4136                       TYPE_LENGTH (actual_type));
4137               actual = ensure_lval (val);
4138             }
4139           result = value_addr (actual);
4140         }
4141       else
4142         return actual;
4143       return value_cast_pointers (formal_type, result, 0);
4144     }
4145   else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4146     return ada_value_ind (actual);
4147
4148   return actual;
4149 }
4150
4151 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4152    type TYPE.  This is usually an inefficient no-op except on some targets
4153    (such as AVR) where the representation of a pointer and an address
4154    differs.  */
4155
4156 static CORE_ADDR
4157 value_pointer (struct value *value, struct type *type)
4158 {
4159   struct gdbarch *gdbarch = get_type_arch (type);
4160   unsigned len = TYPE_LENGTH (type);
4161   gdb_byte *buf = alloca (len);
4162   CORE_ADDR addr;
4163
4164   addr = value_address (value);
4165   gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4166   addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4167   return addr;
4168 }
4169
4170
4171 /* Push a descriptor of type TYPE for array value ARR on the stack at
4172    *SP, updating *SP to reflect the new descriptor.  Return either
4173    an lvalue representing the new descriptor, or (if TYPE is a pointer-
4174    to-descriptor type rather than a descriptor type), a struct value *
4175    representing a pointer to this descriptor.  */
4176
4177 static struct value *
4178 make_array_descriptor (struct type *type, struct value *arr)
4179 {
4180   struct type *bounds_type = desc_bounds_type (type);
4181   struct type *desc_type = desc_base_type (type);
4182   struct value *descriptor = allocate_value (desc_type);
4183   struct value *bounds = allocate_value (bounds_type);
4184   int i;
4185
4186   for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4187        i > 0; i -= 1)
4188     {
4189       modify_field (value_type (bounds), value_contents_writeable (bounds),
4190                     ada_array_bound (arr, i, 0),
4191                     desc_bound_bitpos (bounds_type, i, 0),
4192                     desc_bound_bitsize (bounds_type, i, 0));
4193       modify_field (value_type (bounds), value_contents_writeable (bounds),
4194                     ada_array_bound (arr, i, 1),
4195                     desc_bound_bitpos (bounds_type, i, 1),
4196                     desc_bound_bitsize (bounds_type, i, 1));
4197     }
4198
4199   bounds = ensure_lval (bounds);
4200
4201   modify_field (value_type (descriptor),
4202                 value_contents_writeable (descriptor),
4203                 value_pointer (ensure_lval (arr),
4204                                TYPE_FIELD_TYPE (desc_type, 0)),
4205                 fat_pntr_data_bitpos (desc_type),
4206                 fat_pntr_data_bitsize (desc_type));
4207
4208   modify_field (value_type (descriptor),
4209                 value_contents_writeable (descriptor),
4210                 value_pointer (bounds,
4211                                TYPE_FIELD_TYPE (desc_type, 1)),
4212                 fat_pntr_bounds_bitpos (desc_type),
4213                 fat_pntr_bounds_bitsize (desc_type));
4214
4215   descriptor = ensure_lval (descriptor);
4216
4217   if (TYPE_CODE (type) == TYPE_CODE_PTR)
4218     return value_addr (descriptor);
4219   else
4220     return descriptor;
4221 }
4222 \f
4223 /* Dummy definitions for an experimental caching module that is not
4224  * used in the public sources.  */
4225
4226 static int
4227 lookup_cached_symbol (const char *name, domain_enum namespace,
4228                       struct symbol **sym, struct block **block)
4229 {
4230   return 0;
4231 }
4232
4233 static void
4234 cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
4235               const struct block *block)
4236 {
4237 }
4238 \f
4239                                 /* Symbol Lookup */
4240
4241 /* Return nonzero if wild matching should be used when searching for
4242    all symbols matching LOOKUP_NAME.
4243
4244    LOOKUP_NAME is expected to be a symbol name after transformation
4245    for Ada lookups (see ada_name_for_lookup).  */
4246
4247 static int
4248 should_use_wild_match (const char *lookup_name)
4249 {
4250   return (strstr (lookup_name, "__") == NULL);
4251 }
4252
4253 /* Return the result of a standard (literal, C-like) lookup of NAME in
4254    given DOMAIN, visible from lexical block BLOCK.  */
4255
4256 static struct symbol *
4257 standard_lookup (const char *name, const struct block *block,
4258                  domain_enum domain)
4259 {
4260   /* Initialize it just to avoid a GCC false warning.  */
4261   struct symbol *sym = NULL;
4262
4263   if (lookup_cached_symbol (name, domain, &sym, NULL))
4264     return sym;
4265   sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4266   cache_symbol (name, domain, sym, block_found);
4267   return sym;
4268 }
4269
4270
4271 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4272    in the symbol fields of SYMS[0..N-1].  We treat enumerals as functions, 
4273    since they contend in overloading in the same way.  */
4274 static int
4275 is_nonfunction (struct ada_symbol_info syms[], int n)
4276 {
4277   int i;
4278
4279   for (i = 0; i < n; i += 1)