gdb/ada-lang.c

   1 /* Ada language support routines for GDB, the GNU debugger.  Copyright (C)
   2
   3    1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004, 2005, 2007, 2008,
   4    2009 Free Software Foundation, Inc.
   5
   6    This file is part of GDB.
   7
   8    This program is free software; you can redistribute it and/or modify
   9    it under the terms of the GNU General Public License as published by
  10    the Free Software Foundation; either version 3 of the License, or
  11    (at your option) any later version.
  12
  13    This program is distributed in the hope that it will be useful,
  14    but WITHOUT ANY WARRANTY; without even the implied warranty of
  15    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16    GNU General Public License for more details.
  17
  18    You should have received a copy of the GNU General Public License
  19    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  20
  21
  22 #include "defs.h"
  23 #include <stdio.h>
  24 #include "gdb_string.h"
  25 #include <ctype.h>
  26 #include <stdarg.h>
  27 #include "demangle.h"
  28 #include "gdb_regex.h"
  29 #include "frame.h"
  30 #include "symtab.h"
  31 #include "gdbtypes.h"
  32 #include "gdbcmd.h"
  33 #include "expression.h"
  34 #include "parser-defs.h"
  35 #include "language.h"
  36 #include "c-lang.h"
  37 #include "inferior.h"
  38 #include "symfile.h"
  39 #include "objfiles.h"
  40 #include "breakpoint.h"
  41 #include "gdbcore.h"
  42 #include "hashtab.h"
  43 #include "gdb_obstack.h"
  44 #include "ada-lang.h"
  45 #include "completer.h"
  46 #include "gdb_stat.h"
  47 #ifdef UI_OUT
  48 #include "ui-out.h"
  49 #endif
  50 #include "block.h"
  51 #include "infcall.h"
  52 #include "dictionary.h"
  53 #include "exceptions.h"
  54 #include "annotate.h"
  55 #include "valprint.h"
  56 #include "source.h"
  57 #include "observer.h"
  58 #include "vec.h"
  59 #include "stack.h"
  60
  61 #include "psymtab.h"
  62
  63 /* Define whether or not the C operator '/' truncates towards zero for
  64    differently signed operands (truncation direction is undefined in C).
  65    Copied from valarith.c.  */
  66
  67 #ifndef TRUNCATION_TOWARDS_ZERO
  68 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
  69 #endif
  70
  71 static void modify_general_field (struct type *, char *, LONGEST, int, int);
  72
  73 static struct type *desc_base_type (struct type *);
  74
  75 static struct type *desc_bounds_type (struct type *);
  76
  77 static struct value *desc_bounds (struct value *);
  78
  79 static int fat_pntr_bounds_bitpos (struct type *);
  80
  81 static int fat_pntr_bounds_bitsize (struct type *);
  82
  83 static struct type *desc_data_target_type (struct type *);
  84
  85 static struct value *desc_data (struct value *);
  86
  87 static int fat_pntr_data_bitpos (struct type *);
  88
  89 static int fat_pntr_data_bitsize (struct type *);
  90
  91 static struct value *desc_one_bound (struct value *, int, int);
  92
  93 static int desc_bound_bitpos (struct type *, int, int);
  94
  95 static int desc_bound_bitsize (struct type *, int, int);
  96
  97 static struct type *desc_index_type (struct type *, int);
  98
  99 static int desc_arity (struct type *);
 100
 101 static int ada_type_match (struct type *, struct type *, int);
 102
 103 static int ada_args_match (struct symbol *, struct value **, int);
 104
 105 static struct value *ensure_lval (struct value *,
 106                                   struct gdbarch *, CORE_ADDR *);
 107
 108 static struct value *make_array_descriptor (struct type *, struct value *,
 109                                             struct gdbarch *, CORE_ADDR *);
 110
 111 static void ada_add_block_symbols (struct obstack *,
 112                                    struct block *, const char *,
 113                                    domain_enum, struct objfile *, int);
 114
 115 static int is_nonfunction (struct ada_symbol_info *, int);
 116
 117 static void add_defn_to_vec (struct obstack *, struct symbol *,
 118                              struct block *);
 119
 120 static int num_defns_collected (struct obstack *);
 121
 122 static struct ada_symbol_info *defns_collected (struct obstack *, int);
 123
 124 static struct value *resolve_subexp (struct expression **, int *, int,
 125                                      struct type *);
 126
 127 static void replace_operator_with_call (struct expression **, int, int, int,
 128                                         struct symbol *, struct block *);
 129
 130 static int possible_user_operator_p (enum exp_opcode, struct value **);
 131
 132 static char *ada_op_name (enum exp_opcode);
 133
 134 static const char *ada_decoded_op_name (enum exp_opcode);
 135
 136 static int numeric_type_p (struct type *);
 137
 138 static int integer_type_p (struct type *);
 139
 140 static int scalar_type_p (struct type *);
 141
 142 static int discrete_type_p (struct type *);
 143
 144 static enum ada_renaming_category parse_old_style_renaming (struct type *,
 145                                                             const char **,
 146                                                             int *,
 147                                                             const char **);
 148
 149 static struct symbol *find_old_style_renaming_symbol (const char *,
 150                                                       struct block *);
 151
 152 static struct type *ada_lookup_struct_elt_type (struct type *, char *,
 153                                                 int, int, int *);
 154
 155 static struct value *evaluate_subexp_type (struct expression *, int *);
 156
 157 static struct type *ada_find_parallel_type_with_name (struct type *,
 158                                                       const char *);
 159
 160 static int is_dynamic_field (struct type *, int);
 161
 162 static struct type *to_fixed_variant_branch_type (struct type *,
 163                                                   const gdb_byte *,
 164                                                   CORE_ADDR, struct value *);
 165
 166 static struct type *to_fixed_array_type (struct type *, struct value *, int);
 167
 168 static struct type *to_fixed_range_type (struct type *, struct value *);
 169
 170 static struct type *to_static_fixed_type (struct type *);
 171 static struct type *static_unwrap_type (struct type *type);
 172
 173 static struct value *unwrap_value (struct value *);
 174
 175 static struct type *constrained_packed_array_type (struct type *, long *);
 176
 177 static struct type *decode_constrained_packed_array_type (struct type *);
 178
 179 static long decode_packed_array_bitsize (struct type *);
 180
 181 static struct value *decode_constrained_packed_array (struct value *);
 182
 183 static int ada_is_packed_array_type  (struct type *);
 184
 185 static int ada_is_unconstrained_packed_array_type (struct type *);
 186
 187 static struct value *value_subscript_packed (struct value *, int,
 188                                              struct value **);
 189
 190 static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
 191
 192 static struct value *coerce_unspec_val_to_type (struct value *,
 193                                                 struct type *);
 194
 195 static struct value *get_var_value (char *, char *);
 196
 197 static int lesseq_defined_than (struct symbol *, struct symbol *);
 198
 199 static int equiv_types (struct type *, struct type *);
 200
 201 static int is_name_suffix (const char *);
 202
 203 static int wild_match (const char *, int, const char *);
 204
 205 static struct value *ada_coerce_ref (struct value *);
 206
 207 static LONGEST pos_atr (struct value *);
 208
 209 static struct value *value_pos_atr (struct type *, struct value *);
 210
 211 static struct value *value_val_atr (struct type *, struct value *);
 212
 213 static struct symbol *standard_lookup (const char *, const struct block *,
 214                                        domain_enum);
 215
 216 static struct value *ada_search_struct_field (char *, struct value *, int,
 217                                               struct type *);
 218
 219 static struct value *ada_value_primitive_field (struct value *, int, int,
 220                                                 struct type *);
 221
 222 static int find_struct_field (char *, struct type *, int,
 223                               struct type **, int *, int *, int *, int *);
 224
 225 static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
 226                                                 struct value *);
 227
 228 static int ada_resolve_function (struct ada_symbol_info *, int,
 229                                  struct value **, int, const char *,
 230                                  struct type *);
 231
 232 static struct value *ada_coerce_to_simple_array (struct value *);
 233
 234 static int ada_is_direct_array_type (struct type *);
 235
 236 static void ada_language_arch_info (struct gdbarch *,
 237                                     struct language_arch_info *);
 238
 239 static void check_size (const struct type *);
 240
 241 static struct value *ada_index_struct_field (int, struct value *, int,
 242                                              struct type *);
 243
 244 static struct value *assign_aggregate (struct value *, struct value *,
 245                                        struct expression *, int *, enum noside);
 246
 247 static void aggregate_assign_from_choices (struct value *, struct value *,
 248                                            struct expression *,
 249                                            int *, LONGEST *, int *,
 250                                            int, LONGEST, LONGEST);
 251
 252 static void aggregate_assign_positional (struct value *, struct value *,
 253                                          struct expression *,
 254                                          int *, LONGEST *, int *, int,
 255                                          LONGEST, LONGEST);
 256
 257
 258 static void aggregate_assign_others (struct value *, struct value *,
 259                                      struct expression *,
 260                                      int *, LONGEST *, int, LONGEST, LONGEST);
 261
 262
 263 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
 264
 265
 266 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
 267                                           int *, enum noside);
 268
 269 static void ada_forward_operator_length (struct expression *, int, int *,
 270                                          int *);
 271 \f
 272
 273
 274 /* Maximum-sized dynamic type.  */
 275 static unsigned int varsize_limit;
 276
 277 /* FIXME: brobecker/2003-09-17: No longer a const because it is
 278    returned by a function that does not return a const char *.  */
 279 static char *ada_completer_word_break_characters =
 280 #ifdef VMS
 281   " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
 282 #else
 283   " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
 284 #endif
 285
 286 /* The name of the symbol to use to get the name of the main subprogram.  */
 287 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
 288   = "__gnat_ada_main_program_name";
 289
 290 /* Limit on the number of warnings to raise per expression evaluation.  */
 291 static int warning_limit = 2;
 292
 293 /* Number of warning messages issued; reset to 0 by cleanups after
 294    expression evaluation.  */
 295 static int warnings_issued = 0;
 296
 297 static const char *known_runtime_file_name_patterns[] = {
 298   ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
 299 };
 300
 301 static const char *known_auxiliary_function_name_patterns[] = {
 302   ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
 303 };
 304
 305 /* Space for allocating results of ada_lookup_symbol_list.  */
 306 static struct obstack symbol_list_obstack;
 307
 308                         /* Utilities */
 309
 310 /* Given DECODED_NAME a string holding a symbol name in its
 311    decoded form (ie using the Ada dotted notation), returns
 312    its unqualified name.  */
 313
 314 static const char *
 315 ada_unqualified_name (const char *decoded_name)
 316 {
 317   const char *result = strrchr (decoded_name, '.');
 318
 319   if (result != NULL)
 320     result++;                   /* Skip the dot...  */
 321   else
 322     result = decoded_name;
 323
 324   return result;
 325 }
 326
 327 /* Return a string starting with '<', followed by STR, and '>'.
 328    The result is good until the next call.  */
 329
 330 static char *
 331 add_angle_brackets (const char *str)
 332 {
 333   static char *result = NULL;
 334
 335   xfree (result);
 336   result = xstrprintf ("<%s>", str);
 337   return result;
 338 }
 339
 340 static char *
 341 ada_get_gdb_completer_word_break_characters (void)
 342 {
 343   return ada_completer_word_break_characters;
 344 }
 345
 346 /* Print an array element index using the Ada syntax.  */
 347
 348 static void
 349 ada_print_array_index (struct value *index_value, struct ui_file *stream,
 350                        const struct value_print_options *options)
 351 {
 352   LA_VALUE_PRINT (index_value, stream, options);
 353   fprintf_filtered (stream, " => ");
 354 }
 355
 356 /* Assuming VECT points to an array of *SIZE objects of size
 357    ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
 358    updating *SIZE as necessary and returning the (new) array.  */
 359
 360 void *
 361 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
 362 {
 363   if (*size < min_size)
 364     {
 365       *size *= 2;
 366       if (*size < min_size)
 367         *size = min_size;
 368       vect = xrealloc (vect, *size * element_size);
 369     }
 370   return vect;
 371 }
 372
 373 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
 374    suffix of FIELD_NAME beginning "___".  */
 375
 376 static int
 377 field_name_match (const char *field_name, const char *target)
 378 {
 379   int len = strlen (target);
 380   return
 381     (strncmp (field_name, target, len) == 0
 382      && (field_name[len] == '\0'
 383          || (strncmp (field_name + len, "___", 3) == 0
 384              && strcmp (field_name + strlen (field_name) - 6,
 385                         "___XVN") != 0)));
 386 }
 387
 388
 389 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
 390    a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
 391    and return its index.  This function also handles fields whose name
 392    have ___ suffixes because the compiler sometimes alters their name
 393    by adding such a suffix to represent fields with certain constraints.
 394    If the field could not be found, return a negative number if
 395    MAYBE_MISSING is set.  Otherwise raise an error.  */
 396
 397 int
 398 ada_get_field_index (const struct type *type, const char *field_name,
 399                      int maybe_missing)
 400 {
 401   int fieldno;
 402   struct type *struct_type = check_typedef ((struct type *) type);
 403
 404   for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
 405     if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
 406       return fieldno;
 407
 408   if (!maybe_missing)
 409     error (_("Unable to find field %s in struct %s.  Aborting"),
 410            field_name, TYPE_NAME (struct_type));
 411
 412   return -1;
 413 }
 414
 415 /* The length of the prefix of NAME prior to any "___" suffix.  */
 416
 417 int
 418 ada_name_prefix_len (const char *name)
 419 {
 420   if (name == NULL)
 421     return 0;
 422   else
 423     {
 424       const char *p = strstr (name, "___");
 425       if (p == NULL)
 426         return strlen (name);
 427       else
 428         return p - name;
 429     }
 430 }
 431
 432 /* Return non-zero if SUFFIX is a suffix of STR.
 433    Return zero if STR is null.  */
 434
 435 static int
 436 is_suffix (const char *str, const char *suffix)
 437 {
 438   int len1, len2;
 439   if (str == NULL)
 440     return 0;
 441   len1 = strlen (str);
 442   len2 = strlen (suffix);
 443   return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
 444 }
 445
 446 /* The contents of value VAL, treated as a value of type TYPE.  The
 447    result is an lval in memory if VAL is.  */
 448
 449 static struct value *
 450 coerce_unspec_val_to_type (struct value *val, struct type *type)
 451 {
 452   type = ada_check_typedef (type);
 453   if (value_type (val) == type)
 454     return val;
 455   else
 456     {
 457       struct value *result;
 458
 459       /* Make sure that the object size is not unreasonable before
 460          trying to allocate some memory for it.  */
 461       check_size (type);
 462
 463       result = allocate_value (type);
 464       set_value_component_location (result, val);
 465       set_value_bitsize (result, value_bitsize (val));
 466       set_value_bitpos (result, value_bitpos (val));
 467       set_value_address (result, value_address (val));
 468       if (value_lazy (val)
 469           || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
 470         set_value_lazy (result, 1);
 471       else
 472         memcpy (value_contents_raw (result), value_contents (val),
 473                 TYPE_LENGTH (type));
 474       return result;
 475     }
 476 }
 477
 478 static const gdb_byte *
 479 cond_offset_host (const gdb_byte *valaddr, long offset)
 480 {
 481   if (valaddr == NULL)
 482     return NULL;
 483   else
 484     return valaddr + offset;
 485 }
 486
 487 static CORE_ADDR
 488 cond_offset_target (CORE_ADDR address, long offset)
 489 {
 490   if (address == 0)
 491     return 0;
 492   else
 493     return address + offset;
 494 }
 495
 496 /* Issue a warning (as for the definition of warning in utils.c, but
 497    with exactly one argument rather than ...), unless the limit on the
 498    number of warnings has passed during the evaluation of the current
 499    expression.  */
 500
 501 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
 502    provided by "complaint".  */
 503 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
 504
 505 static void
 506 lim_warning (const char *format, ...)
 507 {
 508   va_list args;
 509   va_start (args, format);
 510
 511   warnings_issued += 1;
 512   if (warnings_issued <= warning_limit)
 513     vwarning (format, args);
 514
 515   va_end (args);
 516 }
 517
 518 /* Issue an error if the size of an object of type T is unreasonable,
 519    i.e. if it would be a bad idea to allocate a value of this type in
 520    GDB.  */
 521
 522 static void
 523 check_size (const struct type *type)
 524 {
 525   if (TYPE_LENGTH (type) > varsize_limit)
 526     error (_("object size is larger than varsize-limit"));
 527 }
 528
 529 /* Maximum value of a SIZE-byte signed integer type. */
 530 static LONGEST
 531 max_of_size (int size)
 532 {
 533   LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
 534   return top_bit | (top_bit - 1);
 535 }
 536
 537 /* Minimum value of a SIZE-byte signed integer type. */
 538 static LONGEST
 539 min_of_size (int size)
 540 {
 541   return -max_of_size (size) - 1;
 542 }
 543
 544 /* Maximum value of a SIZE-byte unsigned integer type. */
 545 static ULONGEST
 546 umax_of_size (int size)
 547 {
 548   ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
 549   return top_bit | (top_bit - 1);
 550 }
 551
 552 /* Maximum value of integral type T, as a signed quantity. */
 553 static LONGEST
 554 max_of_type (struct type *t)
 555 {
 556   if (TYPE_UNSIGNED (t))
 557     return (LONGEST) umax_of_size (TYPE_LENGTH (t));
 558   else
 559     return max_of_size (TYPE_LENGTH (t));
 560 }
 561
 562 /* Minimum value of integral type T, as a signed quantity. */
 563 static LONGEST
 564 min_of_type (struct type *t)
 565 {
 566   if (TYPE_UNSIGNED (t))
 567     return 0;
 568   else
 569     return min_of_size (TYPE_LENGTH (t));
 570 }
 571
 572 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
 573 LONGEST
 574 ada_discrete_type_high_bound (struct type *type)
 575 {
 576   switch (TYPE_CODE (type))
 577     {
 578     case TYPE_CODE_RANGE:
 579       return TYPE_HIGH_BOUND (type);
 580     case TYPE_CODE_ENUM:
 581       return TYPE_FIELD_BITPOS (type, TYPE_NFIELDS (type) - 1);
 582     case TYPE_CODE_BOOL:
 583       return 1;
 584     case TYPE_CODE_CHAR:
 585     case TYPE_CODE_INT:
 586       return max_of_type (type);
 587     default:
 588       error (_("Unexpected type in ada_discrete_type_high_bound."));
 589     }
 590 }
 591
 592 /* The largest value in the domain of TYPE, a discrete type, as an integer.  */
 593 LONGEST
 594 ada_discrete_type_low_bound (struct type *type)
 595 {
 596   switch (TYPE_CODE (type))
 597     {
 598     case TYPE_CODE_RANGE:
 599       return TYPE_LOW_BOUND (type);
 600     case TYPE_CODE_ENUM:
 601       return TYPE_FIELD_BITPOS (type, 0);
 602     case TYPE_CODE_BOOL:
 603       return 0;
 604     case TYPE_CODE_CHAR:
 605     case TYPE_CODE_INT:
 606       return min_of_type (type);
 607     default:
 608       error (_("Unexpected type in ada_discrete_type_low_bound."));
 609     }
 610 }
 611
 612 /* The identity on non-range types.  For range types, the underlying
 613    non-range scalar type.  */
 614
 615 static struct type *
 616 base_type (struct type *type)
 617 {
 618   while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
 619     {
 620       if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
 621         return type;
 622       type = TYPE_TARGET_TYPE (type);
 623     }
 624   return type;
 625 }
 626 \f
 627
 628                                 /* Language Selection */
 629
 630 /* If the main program is in Ada, return language_ada, otherwise return LANG
 631    (the main program is in Ada iif the adainit symbol is found).  */
 632
 633 enum language
 634 ada_update_initial_language (enum language lang)
 635 {
 636   if (lookup_minimal_symbol ("adainit", (const char *) NULL,
 637                              (struct objfile *) NULL) != NULL)
 638     return language_ada;
 639
 640   return lang;
 641 }
 642
 643 /* If the main procedure is written in Ada, then return its name.
 644    The result is good until the next call.  Return NULL if the main
 645    procedure doesn't appear to be in Ada.  */
 646
 647 char *
 648 ada_main_name (void)
 649 {
 650   struct minimal_symbol *msym;
 651   static char *main_program_name = NULL;
 652
 653   /* For Ada, the name of the main procedure is stored in a specific
 654      string constant, generated by the binder.  Look for that symbol,
 655      extract its address, and then read that string.  If we didn't find
 656      that string, then most probably the main procedure is not written
 657      in Ada.  */
 658   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
 659
 660   if (msym != NULL)
 661     {
 662       CORE_ADDR main_program_name_addr;
 663       int err_code;
 664
 665       main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
 666       if (main_program_name_addr == 0)
 667         error (_("Invalid address for Ada main program name."));
 668
 669       xfree (main_program_name);
 670       target_read_string (main_program_name_addr, &main_program_name,
 671                           1024, &err_code);
 672
 673       if (err_code != 0)
 674         return NULL;
 675       return main_program_name;
 676     }
 677
 678   /* The main procedure doesn't seem to be in Ada.  */
 679   return NULL;
 680 }
 681 \f
 682                                 /* Symbols */
 683
 684 /* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
 685    of NULLs.  */
 686
 687 const struct ada_opname_map ada_opname_table[] = {
 688   {"Oadd", "\"+\"", BINOP_ADD},
 689   {"Osubtract", "\"-\"", BINOP_SUB},
 690   {"Omultiply", "\"*\"", BINOP_MUL},
 691   {"Odivide", "\"/\"", BINOP_DIV},
 692   {"Omod", "\"mod\"", BINOP_MOD},
 693   {"Orem", "\"rem\"", BINOP_REM},
 694   {"Oexpon", "\"**\"", BINOP_EXP},
 695   {"Olt", "\"<\"", BINOP_LESS},
 696   {"Ole", "\"<=\"", BINOP_LEQ},
 697   {"Ogt", "\">\"", BINOP_GTR},
 698   {"Oge", "\">=\"", BINOP_GEQ},
 699   {"Oeq", "\"=\"", BINOP_EQUAL},
 700   {"One", "\"/=\"", BINOP_NOTEQUAL},
 701   {"Oand", "\"and\"", BINOP_BITWISE_AND},
 702   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
 703   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
 704   {"Oconcat", "\"&\"", BINOP_CONCAT},
 705   {"Oabs", "\"abs\"", UNOP_ABS},
 706   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
 707   {"Oadd", "\"+\"", UNOP_PLUS},
 708   {"Osubtract", "\"-\"", UNOP_NEG},
 709   {NULL, NULL}
 710 };
 711
 712 /* The "encoded" form of DECODED, according to GNAT conventions.
 713    The result is valid until the next call to ada_encode.  */
 714
 715 char *
 716 ada_encode (const char *decoded)
 717 {
 718   static char *encoding_buffer = NULL;
 719   static size_t encoding_buffer_size = 0;
 720   const char *p;
 721   int k;
 722
 723   if (decoded == NULL)
 724     return NULL;
 725
 726   GROW_VECT (encoding_buffer, encoding_buffer_size,
 727              2 * strlen (decoded) + 10);
 728
 729   k = 0;
 730   for (p = decoded; *p != '\0'; p += 1)
 731     {
 732       if (*p == '.')
 733         {
 734           encoding_buffer[k] = encoding_buffer[k + 1] = '_';
 735           k += 2;
 736         }
 737       else if (*p == '"')
 738         {
 739           const struct ada_opname_map *mapping;
 740
 741           for (mapping = ada_opname_table;
 742                mapping->encoded != NULL
 743                && strncmp (mapping->decoded, p,
 744                            strlen (mapping->decoded)) != 0; mapping += 1)
 745             ;
 746           if (mapping->encoded == NULL)
 747             error (_("invalid Ada operator name: %s"), p);
 748           strcpy (encoding_buffer + k, mapping->encoded);
 749           k += strlen (mapping->encoded);
 750           break;
 751         }
 752       else
 753         {
 754           encoding_buffer[k] = *p;
 755           k += 1;
 756         }
 757     }
 758
 759   encoding_buffer[k] = '\0';
 760   return encoding_buffer;
 761 }
 762
 763 /* Return NAME folded to lower case, or, if surrounded by single
 764    quotes, unfolded, but with the quotes stripped away.  Result good
 765    to next call.  */
 766
 767 char *
 768 ada_fold_name (const char *name)
 769 {
 770   static char *fold_buffer = NULL;
 771   static size_t fold_buffer_size = 0;
 772
 773   int len = strlen (name);
 774   GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
 775
 776   if (name[0] == '\'')
 777     {
 778       strncpy (fold_buffer, name + 1, len - 2);
 779       fold_buffer[len - 2] = '\000';
 780     }
 781   else
 782     {
 783       int i;
 784       for (i = 0; i <= len; i += 1)
 785         fold_buffer[i] = tolower (name[i]);
 786     }
 787
 788   return fold_buffer;
 789 }
 790
 791 /* Return nonzero if C is either a digit or a lowercase alphabet character.  */
 792
 793 static int
 794 is_lower_alphanum (const char c)
 795 {
 796   return (isdigit (c) || (isalpha (c) && islower (c)));
 797 }
 798
 799 /* Remove either of these suffixes:
 800      . .{DIGIT}+
 801      . ${DIGIT}+
 802      . ___{DIGIT}+
 803      . __{DIGIT}+.
 804    These are suffixes introduced by the compiler for entities such as
 805    nested subprogram for instance, in order to avoid name clashes.
 806    They do not serve any purpose for the debugger.  */
 807
 808 static void
 809 ada_remove_trailing_digits (const char *encoded, int *len)
 810 {
 811   if (*len > 1 && isdigit (encoded[*len - 1]))
 812     {
 813       int i = *len - 2;
 814       while (i > 0 && isdigit (encoded[i]))
 815         i--;
 816       if (i >= 0 && encoded[i] == '.')
 817         *len = i;
 818       else if (i >= 0 && encoded[i] == '$')
 819         *len = i;
 820       else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
 821         *len = i - 2;
 822       else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
 823         *len = i - 1;
 824     }
 825 }
 826
 827 /* Remove the suffix introduced by the compiler for protected object
 828    subprograms.  */
 829
 830 static void
 831 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
 832 {
 833   /* Remove trailing N.  */
 834
 835   /* Protected entry subprograms are broken into two
 836      separate subprograms: The first one is unprotected, and has
 837      a 'N' suffix; the second is the protected version, and has
 838      the 'P' suffix. The second calls the first one after handling
 839      the protection.  Since the P subprograms are internally generated,
 840      we leave these names undecoded, giving the user a clue that this
 841      entity is internal.  */
 842
 843   if (*len > 1
 844       && encoded[*len - 1] == 'N'
 845       && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
 846     *len = *len - 1;
 847 }
 848
 849 /* Remove trailing X[bn]* suffixes (indicating names in package bodies).  */
 850
 851 static void
 852 ada_remove_Xbn_suffix (const char *encoded, int *len)
 853 {
 854   int i = *len - 1;
 855
 856   while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
 857     i--;
 858
 859   if (encoded[i] != 'X')
 860     return;
 861
 862   if (i == 0)
 863     return;
 864
 865   if (isalnum (encoded[i-1]))
 866     *len = i;
 867 }
 868
 869 /* If ENCODED follows the GNAT entity encoding conventions, then return
 870    the decoded form of ENCODED.  Otherwise, return "<%s>" where "%s" is
 871    replaced by ENCODED.
 872
 873    The resulting string is valid until the next call of ada_decode.
 874    If the string is unchanged by decoding, the original string pointer
 875    is returned.  */
 876
 877 const char *
 878 ada_decode (const char *encoded)
 879 {
 880   int i, j;
 881   int len0;
 882   const char *p;
 883   char *decoded;
 884   int at_start_name;
 885   static char *decoding_buffer = NULL;
 886   static size_t decoding_buffer_size = 0;
 887
 888   /* The name of the Ada main procedure starts with "_ada_".
 889      This prefix is not part of the decoded name, so skip this part
 890      if we see this prefix.  */
 891   if (strncmp (encoded, "_ada_", 5) == 0)
 892     encoded += 5;
 893
 894   /* If the name starts with '_', then it is not a properly encoded
 895      name, so do not attempt to decode it.  Similarly, if the name
 896      starts with '<', the name should not be decoded.  */
 897   if (encoded[0] == '_' || encoded[0] == '<')
 898     goto Suppress;
 899
 900   len0 = strlen (encoded);
 901
 902   ada_remove_trailing_digits (encoded, &len0);
 903   ada_remove_po_subprogram_suffix (encoded, &len0);
 904
 905   /* Remove the ___X.* suffix if present.  Do not forget to verify that
 906      the suffix is located before the current "end" of ENCODED.  We want
 907      to avoid re-matching parts of ENCODED that have previously been
 908      marked as discarded (by decrementing LEN0).  */
 909   p = strstr (encoded, "___");
 910   if (p != NULL && p - encoded < len0 - 3)
 911     {
 912       if (p[3] == 'X')
 913         len0 = p - encoded;
 914       else
 915         goto Suppress;
 916     }
 917
 918   /* Remove any trailing TKB suffix.  It tells us that this symbol
 919      is for the body of a task, but that information does not actually
 920      appear in the decoded name.  */
 921
 922   if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
 923     len0 -= 3;
 924
 925   /* Remove any trailing TB suffix.  The TB suffix is slightly different
 926      from the TKB suffix because it is used for non-anonymous task
 927      bodies.  */
 928
 929   if (len0 > 2 && strncmp (encoded + len0 - 2, "TB", 2) == 0)
 930     len0 -= 2;
 931
 932   /* Remove trailing "B" suffixes.  */
 933   /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */
 934
 935   if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
 936     len0 -= 1;
 937
 938   /* Make decoded big enough for possible expansion by operator name.  */
 939
 940   GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
 941   decoded = decoding_buffer;
 942
 943   /* Remove trailing __{digit}+ or trailing ${digit}+.  */
 944
 945   if (len0 > 1 && isdigit (encoded[len0 - 1]))
 946     {
 947       i = len0 - 2;
 948       while ((i >= 0 && isdigit (encoded[i]))
 949              || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
 950         i -= 1;
 951       if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
 952         len0 = i - 1;
 953       else if (encoded[i] == '$')
 954         len0 = i;
 955     }
 956
 957   /* The first few characters that are not alphabetic are not part
 958      of any encoding we use, so we can copy them over verbatim.  */
 959
 960   for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
 961     decoded[j] = encoded[i];
 962
 963   at_start_name = 1;
 964   while (i < len0)
 965     {
 966       /* Is this a symbol function?  */
 967       if (at_start_name && encoded[i] == 'O')
 968         {
 969           int k;
 970           for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
 971             {
 972               int op_len = strlen (ada_opname_table[k].encoded);
 973               if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
 974                             op_len - 1) == 0)
 975                   && !isalnum (encoded[i + op_len]))
 976                 {
 977                   strcpy (decoded + j, ada_opname_table[k].decoded);
 978                   at_start_name = 0;
 979                   i += op_len;
 980                   j += strlen (ada_opname_table[k].decoded);
 981                   break;
 982                 }
 983             }
 984           if (ada_opname_table[k].encoded != NULL)
 985             continue;
 986         }
 987       at_start_name = 0;
 988
 989       /* Replace "TK__" with "__", which will eventually be translated
 990          into "." (just below).  */
 991
 992       if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
 993         i += 2;
 994
 995       /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
 996          be translated into "." (just below).  These are internal names
 997          generated for anonymous blocks inside which our symbol is nested.  */
 998
 999       if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1000           && encoded [i+2] == 'B' && encoded [i+3] == '_'
1001           && isdigit (encoded [i+4]))
1002         {
1003           int k = i + 5;
1004
1005           while (k < len0 && isdigit (encoded[k]))
1006             k++;  /* Skip any extra digit.  */
1007
1008           /* Double-check that the "__B_{DIGITS}+" sequence we found
1009              is indeed followed by "__".  */
1010           if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1011             i = k;
1012         }
1013
1014       /* Remove _E{DIGITS}+[sb] */
1015
1016       /* Just as for protected object subprograms, there are 2 categories
1017          of subprograms created by the compiler for each entry. The first
1018          one implements the actual entry code, and has a suffix following
1019          the convention above; the second one implements the barrier and
1020          uses the same convention as above, except that the 'E' is replaced
1021          by a 'B'.
1022
1023          Just as above, we do not decode the name of barrier functions
1024          to give the user a clue that the code he is debugging has been
1025          internally generated.  */
1026
1027       if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1028           && isdigit (encoded[i+2]))
1029         {
1030           int k = i + 3;
1031
1032           while (k < len0 && isdigit (encoded[k]))
1033             k++;
1034
1035           if (k < len0
1036               && (encoded[k] == 'b' || encoded[k] == 's'))
1037             {
1038               k++;
1039               /* Just as an extra precaution, make sure that if this
1040                  suffix is followed by anything else, it is a '_'.
1041                  Otherwise, we matched this sequence by accident.  */
1042               if (k == len0
1043                   || (k < len0 && encoded[k] == '_'))
1044                 i = k;
1045             }
1046         }
1047
1048       /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
1049          the GNAT front-end in protected object subprograms.  */
1050
1051       if (i < len0 + 3
1052           && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1053         {
1054           /* Backtrack a bit up until we reach either the begining of
1055              the encoded name, or "__".  Make sure that we only find
1056              digits or lowercase characters.  */
1057           const char *ptr = encoded + i - 1;
1058
1059           while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1060             ptr--;
1061           if (ptr < encoded
1062               || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1063             i++;
1064         }
1065
1066       if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1067         {
1068           /* This is a X[bn]* sequence not separated from the previous
1069              part of the name with a non-alpha-numeric character (in other
1070              words, immediately following an alpha-numeric character), then
1071              verify that it is placed at the end of the encoded name.  If
1072              not, then the encoding is not valid and we should abort the
1073              decoding.  Otherwise, just skip it, it is used in body-nested
1074              package names.  */
1075           do
1076             i += 1;
1077           while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1078           if (i < len0)
1079             goto Suppress;
1080         }
1081       else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1082         {
1083          /* Replace '__' by '.'.  */
1084           decoded[j] = '.';
1085           at_start_name = 1;
1086           i += 2;
1087           j += 1;
1088         }
1089       else
1090         {
1091           /* It's a character part of the decoded name, so just copy it
1092              over.  */
1093           decoded[j] = encoded[i];
1094           i += 1;
1095           j += 1;
1096         }
1097     }
1098   decoded[j] = '\000';
1099
1100   /* Decoded names should never contain any uppercase character.
1101      Double-check this, and abort the decoding if we find one.  */
1102
1103   for (i = 0; decoded[i] != '\0'; i += 1)
1104     if (isupper (decoded[i]) || decoded[i] == ' ')
1105       goto Suppress;
1106
1107   if (strcmp (decoded, encoded) == 0)
1108     return encoded;
1109   else
1110     return decoded;
1111
1112 Suppress:
1113   GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1114   decoded = decoding_buffer;
1115   if (encoded[0] == '<')
1116     strcpy (decoded, encoded);
1117   else
1118     xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
1119   return decoded;
1120
1121 }
1122
1123 /* Table for keeping permanent unique copies of decoded names.  Once
1124    allocated, names in this table are never released.  While this is a
1125    storage leak, it should not be significant unless there are massive
1126    changes in the set of decoded names in successive versions of a
1127    symbol table loaded during a single session.  */
1128 static struct htab *decoded_names_store;
1129
1130 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1131    in the language-specific part of GSYMBOL, if it has not been
1132    previously computed.  Tries to save the decoded name in the same
1133    obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1134    in any case, the decoded symbol has a lifetime at least that of
1135    GSYMBOL).
1136    The GSYMBOL parameter is "mutable" in the C++ sense: logically
1137    const, but nevertheless modified to a semantically equivalent form
1138    when a decoded name is cached in it.
1139 */
1140
1141 char *
1142 ada_decode_symbol (const struct general_symbol_info *gsymbol)
1143 {
1144   char **resultp =
1145     (char **) &gsymbol->language_specific.cplus_specific.demangled_name;
1146   if (*resultp == NULL)
1147     {
1148       const char *decoded = ada_decode (gsymbol->name);
1149       if (gsymbol->obj_section != NULL)
1150         {
1151           struct objfile *objf = gsymbol->obj_section->objfile;
1152           *resultp = obsavestring (decoded, strlen (decoded),
1153                                    &objf->objfile_obstack);
1154         }
1155       /* Sometimes, we can't find a corresponding objfile, in which
1156          case, we put the result on the heap.  Since we only decode
1157          when needed, we hope this usually does not cause a
1158          significant memory leak (FIXME).  */
1159       if (*resultp == NULL)
1160         {
1161           char **slot = (char **) htab_find_slot (decoded_names_store,
1162                                                   decoded, INSERT);
1163           if (*slot == NULL)
1164             *slot = xstrdup (decoded);
1165           *resultp = *slot;
1166         }
1167     }
1168
1169   return *resultp;
1170 }
1171
1172 static char *
1173 ada_la_decode (const char *encoded, int options)
1174 {
1175   return xstrdup (ada_decode (encoded));
1176 }
1177
1178 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1179    suffixes that encode debugging information or leading _ada_ on
1180    SYM_NAME (see is_name_suffix commentary for the debugging
1181    information that is ignored).  If WILD, then NAME need only match a
1182    suffix of SYM_NAME minus the same suffixes.  Also returns 0 if
1183    either argument is NULL.  */
1184
1185 static int
1186 ada_match_name (const char *sym_name, const char *name, int wild)
1187 {
1188   if (sym_name == NULL || name == NULL)
1189     return 0;
1190   else if (wild)
1191     return wild_match (name, strlen (name), sym_name);
1192   else
1193     {
1194       int len_name = strlen (name);
1195       return (strncmp (sym_name, name, len_name) == 0
1196               && is_name_suffix (sym_name + len_name))
1197         || (strncmp (sym_name, "_ada_", 5) == 0
1198             && strncmp (sym_name + 5, name, len_name) == 0
1199             && is_name_suffix (sym_name + len_name + 5));
1200     }
1201 }
1202 \f
1203
1204                                 /* Arrays */
1205
1206 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1207    generated by the GNAT compiler to describe the index type used
1208    for each dimension of an array, check whether it follows the latest
1209    known encoding.  If not, fix it up to conform to the latest encoding.
1210    Otherwise, do nothing.  This function also does nothing if
1211    INDEX_DESC_TYPE is NULL.
1212
1213    The GNAT encoding used to describle the array index type evolved a bit.
1214    Initially, the information would be provided through the name of each
1215    field of the structure type only, while the type of these fields was
1216    described as unspecified and irrelevant.  The debugger was then expected
1217    to perform a global type lookup using the name of that field in order
1218    to get access to the full index type description.  Because these global
1219    lookups can be very expensive, the encoding was later enhanced to make
1220    the global lookup unnecessary by defining the field type as being
1221    the full index type description.
1222
1223    The purpose of this routine is to allow us to support older versions
1224    of the compiler by detecting the use of the older encoding, and by
1225    fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1226    we essentially replace each field's meaningless type by the associated
1227    index subtype).  */
1228
1229 void
1230 ada_fixup_array_indexes_type (struct type *index_desc_type)
1231 {
1232   int i;
1233
1234   if (index_desc_type == NULL)
1235     return;
1236   gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1237
1238   /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1239      to check one field only, no need to check them all).  If not, return
1240      now.
1241
1242      If our INDEX_DESC_TYPE was generated using the older encoding,
1243      the field type should be a meaningless integer type whose name
1244      is not equal to the field name.  */
1245   if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1246       && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1247                  TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1248     return;
1249
1250   /* Fixup each field of INDEX_DESC_TYPE.  */
1251   for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1252    {
1253      char *name = TYPE_FIELD_NAME (index_desc_type, i);
1254      struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1255
1256      if (raw_type)
1257        TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1258    }
1259 }
1260
1261 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors.  */
1262
1263 static char *bound_name[] = {
1264   "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1265   "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1266 };
1267
1268 /* Maximum number of array dimensions we are prepared to handle.  */
1269
1270 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1271
1272 /* Like modify_field, but allows bitpos > wordlength.  */
1273
1274 static void
1275 modify_general_field (struct type *type, char *addr,
1276                       LONGEST fieldval, int bitpos, int bitsize)
1277 {
1278   modify_field (type, addr + bitpos / 8, fieldval, bitpos % 8, bitsize);
1279 }
1280
1281
1282 /* The desc_* routines return primitive portions of array descriptors
1283    (fat pointers).  */
1284
1285 /* The descriptor or array type, if any, indicated by TYPE; removes
1286    level of indirection, if needed.  */
1287
1288 static struct type *
1289 desc_base_type (struct type *type)
1290 {
1291   if (type == NULL)
1292     return NULL;
1293   type = ada_check_typedef (type);
1294   if (type != NULL
1295       && (TYPE_CODE (type) == TYPE_CODE_PTR
1296           || TYPE_CODE (type) == TYPE_CODE_REF))
1297     return ada_check_typedef (TYPE_TARGET_TYPE (type));
1298   else
1299     return type;
1300 }
1301
1302 /* True iff TYPE indicates a "thin" array pointer type.  */
1303
1304 static int
1305 is_thin_pntr (struct type *type)
1306 {
1307   return
1308     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1309     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1310 }
1311
1312 /* The descriptor type for thin pointer type TYPE.  */
1313
1314 static struct type *
1315 thin_descriptor_type (struct type *type)
1316 {
1317   struct type *base_type = desc_base_type (type);
1318   if (base_type == NULL)
1319     return NULL;
1320   if (is_suffix (ada_type_name (base_type), "___XVE"))
1321     return base_type;
1322   else
1323     {
1324       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1325       if (alt_type == NULL)
1326         return base_type;
1327       else
1328         return alt_type;
1329     }
1330 }
1331
1332 /* A pointer to the array data for thin-pointer value VAL.  */
1333
1334 static struct value *
1335 thin_data_pntr (struct value *val)
1336 {
1337   struct type *type = value_type (val);
1338   struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1339   data_type = lookup_pointer_type (data_type);
1340
1341   if (TYPE_CODE (type) == TYPE_CODE_PTR)
1342     return value_cast (data_type, value_copy (val));
1343   else
1344     return value_from_longest (data_type, value_address (val));
1345 }
1346
1347 /* True iff TYPE indicates a "thick" array pointer type.  */
1348
1349 static int
1350 is_thick_pntr (struct type *type)
1351 {
1352   type = desc_base_type (type);
1353   return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1354           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1355 }
1356
1357 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1358    pointer to one, the type of its bounds data; otherwise, NULL.  */
1359
1360 static struct type *
1361 desc_bounds_type (struct type *type)
1362 {
1363   struct type *r;
1364
1365   type = desc_base_type (type);
1366
1367   if (type == NULL)
1368     return NULL;
1369   else if (is_thin_pntr (type))
1370     {
1371       type = thin_descriptor_type (type);
1372       if (type == NULL)
1373         return NULL;
1374       r = lookup_struct_elt_type (type, "BOUNDS", 1);
1375       if (r != NULL)
1376         return ada_check_typedef (r);
1377     }
1378   else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1379     {
1380       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1381       if (r != NULL)
1382         return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1383     }
1384   return NULL;
1385 }
1386
1387 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1388    one, a pointer to its bounds data.   Otherwise NULL.  */
1389
1390 static struct value *
1391 desc_bounds (struct value *arr)
1392 {
1393   struct type *type = ada_check_typedef (value_type (arr));
1394   if (is_thin_pntr (type))
1395     {
1396       struct type *bounds_type =
1397         desc_bounds_type (thin_descriptor_type (type));
1398       LONGEST addr;
1399
1400       if (bounds_type == NULL)
1401         error (_("Bad GNAT array descriptor"));
1402
1403       /* NOTE: The following calculation is not really kosher, but
1404          since desc_type is an XVE-encoded type (and shouldn't be),
1405          the correct calculation is a real pain.  FIXME (and fix GCC).  */
1406       if (TYPE_CODE (type) == TYPE_CODE_PTR)
1407         addr = value_as_long (arr);
1408       else
1409         addr = value_address (arr);
1410
1411       return
1412         value_from_longest (lookup_pointer_type (bounds_type),
1413                             addr - TYPE_LENGTH (bounds_type));
1414     }
1415
1416   else if (is_thick_pntr (type))
1417     return value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1418                              _("Bad GNAT array descriptor"));
1419   else
1420     return NULL;
1421 }
1422
1423 /* If TYPE is the type of an array-descriptor (fat pointer),  the bit
1424    position of the field containing the address of the bounds data.  */
1425
1426 static int
1427 fat_pntr_bounds_bitpos (struct type *type)
1428 {
1429   return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1430 }
1431
1432 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1433    size of the field containing the address of the bounds data.  */
1434
1435 static int
1436 fat_pntr_bounds_bitsize (struct type *type)
1437 {
1438   type = desc_base_type (type);
1439
1440   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1441     return TYPE_FIELD_BITSIZE (type, 1);
1442   else
1443     return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1444 }
1445
1446 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1447    pointer to one, the type of its array data (a array-with-no-bounds type);
1448    otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
1449    data.  */
1450
1451 static struct type *
1452 desc_data_target_type (struct type *type)
1453 {
1454   type = desc_base_type (type);
1455
1456   /* NOTE: The following is bogus; see comment in desc_bounds.  */
1457   if (is_thin_pntr (type))
1458     return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
1459   else if (is_thick_pntr (type))
1460     {
1461       struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1462
1463       if (data_type
1464           && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
1465         return TYPE_TARGET_TYPE (data_type);
1466     }
1467
1468   return NULL;
1469 }
1470
1471 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1472    its array data.  */
1473
1474 static struct value *
1475 desc_data (struct value *arr)
1476 {
1477   struct type *type = value_type (arr);
1478   if (is_thin_pntr (type))
1479     return thin_data_pntr (arr);
1480   else if (is_thick_pntr (type))
1481     return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1482                              _("Bad GNAT array descriptor"));
1483   else
1484     return NULL;
1485 }
1486
1487
1488 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1489    position of the field containing the address of the data.  */
1490
1491 static int
1492 fat_pntr_data_bitpos (struct type *type)
1493 {
1494   return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1495 }
1496
1497 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1498    size of the field containing the address of the data.  */
1499
1500 static int
1501 fat_pntr_data_bitsize (struct type *type)
1502 {
1503   type = desc_base_type (type);
1504
1505   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1506     return TYPE_FIELD_BITSIZE (type, 0);
1507   else
1508     return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1509 }
1510
1511 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1512    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1513    bound, if WHICH is 1.  The first bound is I=1.  */
1514
1515 static struct value *
1516 desc_one_bound (struct value *bounds, int i, int which)
1517 {
1518   return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1519                            _("Bad GNAT array descriptor bounds"));
1520 }
1521
1522 /* If BOUNDS is an array-bounds structure type, return the bit position
1523    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1524    bound, if WHICH is 1.  The first bound is I=1.  */
1525
1526 static int
1527 desc_bound_bitpos (struct type *type, int i, int which)
1528 {
1529   return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1530 }
1531
1532 /* If BOUNDS is an array-bounds structure type, return the bit field size
1533    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1534    bound, if WHICH is 1.  The first bound is I=1.  */
1535
1536 static int
1537 desc_bound_bitsize (struct type *type, int i, int which)
1538 {
1539   type = desc_base_type (type);
1540
1541   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1542     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1543   else
1544     return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1545 }
1546
1547 /* If TYPE is the type of an array-bounds structure, the type of its
1548    Ith bound (numbering from 1).  Otherwise, NULL.  */
1549
1550 static struct type *
1551 desc_index_type (struct type *type, int i)
1552 {
1553   type = desc_base_type (type);
1554
1555   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1556     return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1557   else
1558     return NULL;
1559 }
1560
1561 /* The number of index positions in the array-bounds type TYPE.
1562    Return 0 if TYPE is NULL.  */
1563
1564 static int
1565 desc_arity (struct type *type)
1566 {
1567   type = desc_base_type (type);
1568
1569   if (type != NULL)
1570     return TYPE_NFIELDS (type) / 2;
1571   return 0;
1572 }
1573
1574 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1575    an array descriptor type (representing an unconstrained array
1576    type).  */
1577
1578 static int
1579 ada_is_direct_array_type (struct type *type)
1580 {
1581   if (type == NULL)
1582     return 0;
1583   type = ada_check_typedef (type);
1584   return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1585           || ada_is_array_descriptor_type (type));
1586 }
1587
1588 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1589  * to one. */
1590
1591 static int
1592 ada_is_array_type (struct type *type)
1593 {
1594   while (type != NULL
1595          && (TYPE_CODE (type) == TYPE_CODE_PTR
1596              || TYPE_CODE (type) == TYPE_CODE_REF))
1597     type = TYPE_TARGET_TYPE (type);
1598   return ada_is_direct_array_type (type);
1599 }
1600
1601 /* Non-zero iff TYPE is a simple array type or pointer to one.  */
1602
1603 int
1604 ada_is_simple_array_type (struct type *type)
1605 {
1606   if (type == NULL)
1607     return 0;
1608   type = ada_check_typedef (type);
1609   return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1610           || (TYPE_CODE (type) == TYPE_CODE_PTR
1611               && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY));
1612 }
1613
1614 /* Non-zero iff TYPE belongs to a GNAT array descriptor.  */
1615
1616 int
1617 ada_is_array_descriptor_type (struct type *type)
1618 {
1619   struct type *data_type = desc_data_target_type (type);
1620
1621   if (type == NULL)
1622     return 0;
1623   type = ada_check_typedef (type);
1624   return (data_type != NULL
1625           && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1626           && desc_arity (desc_bounds_type (type)) > 0);
1627 }
1628
1629 /* Non-zero iff type is a partially mal-formed GNAT array
1630    descriptor.  FIXME: This is to compensate for some problems with
1631    debugging output from GNAT.  Re-examine periodically to see if it
1632    is still needed.  */
1633
1634 int
1635 ada_is_bogus_array_descriptor (struct type *type)
1636 {
1637   return
1638     type != NULL
1639     && TYPE_CODE (type) == TYPE_CODE_STRUCT
1640     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1641         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1642     && !ada_is_array_descriptor_type (type);
1643 }
1644
1645
1646 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1647    (fat pointer) returns the type of the array data described---specifically,
1648    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
1649    in from the descriptor; otherwise, they are left unspecified.  If
1650    the ARR denotes a null array descriptor and BOUNDS is non-zero,
1651    returns NULL.  The result is simply the type of ARR if ARR is not
1652    a descriptor.  */
1653 struct type *
1654 ada_type_of_array (struct value *arr, int bounds)
1655 {
1656   if (ada_is_constrained_packed_array_type (value_type (arr)))
1657     return decode_constrained_packed_array_type (value_type (arr));
1658
1659   if (!ada_is_array_descriptor_type (value_type (arr)))
1660     return value_type (arr);
1661
1662   if (!bounds)
1663     {
1664       struct type *array_type =
1665         ada_check_typedef (desc_data_target_type (value_type (arr)));
1666
1667       if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1668         TYPE_FIELD_BITSIZE (array_type, 0) =
1669           decode_packed_array_bitsize (value_type (arr));
1670
1671       return array_type;
1672     }
1673   else
1674     {
1675       struct type *elt_type;
1676       int arity;
1677       struct value *descriptor;
1678
1679       elt_type = ada_array_element_type (value_type (arr), -1);
1680       arity = ada_array_arity (value_type (arr));
1681
1682       if (elt_type == NULL || arity == 0)
1683         return ada_check_typedef (value_type (arr));
1684
1685       descriptor = desc_bounds (arr);
1686       if (value_as_long (descriptor) == 0)
1687         return NULL;
1688       while (arity > 0)
1689         {
1690           struct type *range_type = alloc_type_copy (value_type (arr));
1691           struct type *array_type = alloc_type_copy (value_type (arr));
1692           struct value *low = desc_one_bound (descriptor, arity, 0);
1693           struct value *high = desc_one_bound (descriptor, arity, 1);
1694           arity -= 1;
1695
1696           create_range_type (range_type, value_type (low),
1697                              longest_to_int (value_as_long (low)),
1698                              longest_to_int (value_as_long (high)));
1699           elt_type = create_array_type (array_type, elt_type, range_type);
1700
1701           if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1702             TYPE_FIELD_BITSIZE (elt_type, 0) =
1703               decode_packed_array_bitsize (value_type (arr));
1704         }
1705
1706       return lookup_pointer_type (elt_type);
1707     }
1708 }
1709
1710 /* If ARR does not represent an array, returns ARR unchanged.
1711    Otherwise, returns either a standard GDB array with bounds set
1712    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1713    GDB array.  Returns NULL if ARR is a null fat pointer.  */
1714
1715 struct value *
1716 ada_coerce_to_simple_array_ptr (struct value *arr)
1717 {
1718   if (ada_is_array_descriptor_type (value_type (arr)))
1719     {
1720       struct type *arrType = ada_type_of_array (arr, 1);
1721       if (arrType == NULL)
1722         return NULL;
1723       return value_cast (arrType, value_copy (desc_data (arr)));
1724     }
1725   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1726     return decode_constrained_packed_array (arr);
1727   else
1728     return arr;
1729 }
1730
1731 /* If ARR does not represent an array, returns ARR unchanged.
1732    Otherwise, returns a standard GDB array describing ARR (which may
1733    be ARR itself if it already is in the proper form).  */
1734
1735 static struct value *
1736 ada_coerce_to_simple_array (struct value *arr)
1737 {
1738   if (ada_is_array_descriptor_type (value_type (arr)))
1739     {
1740       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1741       if (arrVal == NULL)
1742         error (_("Bounds unavailable for null array pointer."));
1743       check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
1744       return value_ind (arrVal);
1745     }
1746   else if (ada_is_constrained_packed_array_type (value_type (arr)))
1747     return decode_constrained_packed_array (arr);
1748   else
1749     return arr;
1750 }
1751
1752 /* If TYPE represents a GNAT array type, return it translated to an
1753    ordinary GDB array type (possibly with BITSIZE fields indicating
1754    packing).  For other types, is the identity.  */
1755
1756 struct type *
1757 ada_coerce_to_simple_array_type (struct type *type)
1758 {
1759   if (ada_is_constrained_packed_array_type (type))
1760     return decode_constrained_packed_array_type (type);
1761
1762   if (ada_is_array_descriptor_type (type))
1763     return ada_check_typedef (desc_data_target_type (type));
1764
1765   return type;
1766 }
1767
1768 /* Non-zero iff TYPE represents a standard GNAT packed-array type.  */
1769
1770 static int
1771 ada_is_packed_array_type  (struct type *type)
1772 {
1773   if (type == NULL)
1774     return 0;
1775   type = desc_base_type (type);
1776   type = ada_check_typedef (type);
1777   return
1778     ada_type_name (type) != NULL
1779     && strstr (ada_type_name (type), "___XP") != NULL;
1780 }
1781
1782 /* Non-zero iff TYPE represents a standard GNAT constrained
1783    packed-array type.  */
1784
1785 int
1786 ada_is_constrained_packed_array_type (struct type *type)
1787 {
1788   return ada_is_packed_array_type (type)
1789     && !ada_is_array_descriptor_type (type);
1790 }
1791
1792 /* Non-zero iff TYPE represents an array descriptor for a
1793    unconstrained packed-array type.  */
1794
1795 static int
1796 ada_is_unconstrained_packed_array_type (struct type *type)
1797 {
1798   return ada_is_packed_array_type (type)
1799     && ada_is_array_descriptor_type (type);
1800 }
1801
1802 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
1803    return the size of its elements in bits.  */
1804
1805 static long
1806 decode_packed_array_bitsize (struct type *type)
1807 {
1808   char *raw_name = ada_type_name (ada_check_typedef (type));
1809   char *tail;
1810   long bits;
1811
1812   if (!raw_name)
1813     raw_name = ada_type_name (desc_base_type (type));
1814
1815   if (!raw_name)
1816     return 0;
1817
1818   tail = strstr (raw_name, "___XP");
1819
1820   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1821     {
1822       lim_warning
1823         (_("could not understand bit size information on packed array"));
1824       return 0;
1825     }
1826
1827   return bits;
1828 }
1829
1830 /* Given that TYPE is a standard GDB array type with all bounds filled
1831    in, and that the element size of its ultimate scalar constituents
1832    (that is, either its elements, or, if it is an array of arrays, its
1833    elements' elements, etc.) is *ELT_BITS, return an identical type,
1834    but with the bit sizes of its elements (and those of any
1835    constituent arrays) recorded in the BITSIZE components of its
1836    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1837    in bits.  */
1838
1839 static struct type *
1840 constrained_packed_array_type (struct type *type, long *elt_bits)
1841 {
1842   struct type *new_elt_type;
1843   struct type *new_type;
1844   LONGEST low_bound, high_bound;
1845
1846   type = ada_check_typedef (type);
1847   if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1848     return type;
1849
1850   new_type = alloc_type_copy (type);
1851   new_elt_type =
1852     constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
1853                                    elt_bits);
1854   create_array_type (new_type, new_elt_type, TYPE_INDEX_TYPE (type));
1855   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
1856   TYPE_NAME (new_type) = ada_type_name (type);
1857
1858   if (get_discrete_bounds (TYPE_INDEX_TYPE (type),
1859                            &low_bound, &high_bound) < 0)
1860     low_bound = high_bound = 0;
1861   if (high_bound < low_bound)
1862     *elt_bits = TYPE_LENGTH (new_type) = 0;
1863   else
1864     {
1865       *elt_bits *= (high_bound - low_bound + 1);
1866       TYPE_LENGTH (new_type) =
1867         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
1868     }
1869
1870   TYPE_FIXED_INSTANCE (new_type) = 1;
1871   return new_type;
1872 }
1873
1874 /* The array type encoded by TYPE, where
1875    ada_is_constrained_packed_array_type (TYPE).  */
1876
1877 static struct type *
1878 decode_constrained_packed_array_type (struct type *type)
1879 {
1880   char *raw_name = ada_type_name (ada_check_typedef (type));
1881   char *name;
1882   char *tail;
1883   struct type *shadow_type;
1884   long bits;
1885
1886   if (!raw_name)
1887     raw_name = ada_type_name (desc_base_type (type));
1888
1889   if (!raw_name)
1890     return NULL;
1891
1892   name = (char *) alloca (strlen (raw_name) + 1);
1893   tail = strstr (raw_name, "___XP");
1894   type = desc_base_type (type);
1895
1896   memcpy (name, raw_name, tail - raw_name);
1897   name[tail - raw_name] = '\000';
1898
1899   shadow_type = ada_find_parallel_type_with_name (type, name);
1900
1901   if (shadow_type == NULL)
1902     {
1903       lim_warning (_("could not find bounds information on packed array"));
1904       return NULL;
1905     }
1906   CHECK_TYPEDEF (shadow_type);
1907
1908   if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
1909     {
1910       lim_warning (_("could not understand bounds information on packed array"));
1911       return NULL;
1912     }
1913
1914   bits = decode_packed_array_bitsize (type);
1915   return constrained_packed_array_type (shadow_type, &bits);
1916 }
1917
1918 /* Given that ARR is a struct value *indicating a GNAT constrained packed
1919    array, returns a simple array that denotes that array.  Its type is a
1920    standard GDB array type except that the BITSIZEs of the array
1921    target types are set to the number of bits in each element, and the
1922    type length is set appropriately.  */
1923
1924 static struct value *
1925 decode_constrained_packed_array (struct value *arr)
1926 {
1927   struct type *type;
1928
1929   arr = ada_coerce_ref (arr);
1930
1931   /* If our value is a pointer, then dererence it.  Make sure that
1932      this operation does not cause the target type to be fixed, as
1933      this would indirectly cause this array to be decoded.  The rest
1934      of the routine assumes that the array hasn't been decoded yet,
1935      so we use the basic "value_ind" routine to perform the dereferencing,
1936      as opposed to using "ada_value_ind".  */
1937   if (TYPE_CODE (value_type (arr)) == TYPE_CODE_PTR)
1938     arr = value_ind (arr);
1939
1940   type = decode_constrained_packed_array_type (value_type (arr));
1941   if (type == NULL)
1942     {
1943       error (_("can't unpack array"));
1944       return NULL;
1945     }
1946
1947   if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
1948       && ada_is_modular_type (value_type (arr)))
1949     {
1950        /* This is a (right-justified) modular type representing a packed
1951          array with no wrapper.  In order to interpret the value through
1952          the (left-justified) packed array type we just built, we must
1953          first left-justify it.  */
1954       int bit_size, bit_pos;
1955       ULONGEST mod;
1956
1957       mod = ada_modulus (value_type (arr)) - 1;
1958       bit_size = 0;
1959       while (mod > 0)
1960         {
1961           bit_size += 1;
1962           mod >>= 1;
1963         }
1964       bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
1965       arr = ada_value_primitive_packed_val (arr, NULL,
1966                                             bit_pos / HOST_CHAR_BIT,
1967                                             bit_pos % HOST_CHAR_BIT,
1968                                             bit_size,
1969                                             type);
1970     }
1971
1972   return coerce_unspec_val_to_type (arr, type);
1973 }
1974
1975
1976 /* The value of the element of packed array ARR at the ARITY indices
1977    given in IND.   ARR must be a simple array.  */
1978
1979 static struct value *
1980 value_subscript_packed (struct value *arr, int arity, struct value **ind)
1981 {
1982   int i;
1983   int bits, elt_off, bit_off;
1984   long elt_total_bit_offset;
1985   struct type *elt_type;
1986   struct value *v;
1987
1988   bits = 0;
1989   elt_total_bit_offset = 0;
1990   elt_type = ada_check_typedef (value_type (arr));
1991   for (i = 0; i < arity; i += 1)
1992     {
1993       if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
1994           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
1995         error
1996           (_("attempt to do packed indexing of something other than a packed array"));
1997       else
1998         {
1999           struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2000           LONGEST lowerbound, upperbound;
2001           LONGEST idx;
2002
2003           if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2004             {
2005               lim_warning (_("don't know bounds of array"));
2006               lowerbound = upperbound = 0;
2007             }
2008
2009           idx = pos_atr (ind[i]);
2010           if (idx < lowerbound || idx > upperbound)
2011             lim_warning (_("packed array index %ld out of bounds"), (long) idx);
2012           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2013           elt_total_bit_offset += (idx - lowerbound) * bits;
2014           elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2015         }
2016     }
2017   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2018   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2019
2020   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2021                                       bits, elt_type);
2022   return v;
2023 }
2024
2025 /* Non-zero iff TYPE includes negative integer values.  */
2026
2027 static int
2028 has_negatives (struct type *type)
2029 {
2030   switch (TYPE_CODE (type))
2031     {
2032     default:
2033       return 0;
2034     case TYPE_CODE_INT:
2035       return !TYPE_UNSIGNED (type);
2036     case TYPE_CODE_RANGE:
2037       return TYPE_LOW_BOUND (type) < 0;
2038     }
2039 }
2040
2041
2042 /* Create a new value of type TYPE from the contents of OBJ starting
2043    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2044    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
2045    assigning through the result will set the field fetched from.
2046    VALADDR is ignored unless OBJ is NULL, in which case,
2047    VALADDR+OFFSET must address the start of storage containing the
2048    packed value.  The value returned  in this case is never an lval.
2049    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */
2050
2051 struct value *
2052 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2053                                 long offset, int bit_offset, int bit_size,
2054                                 struct type *type)
2055 {
2056   struct value *v;
2057   int src,                      /* Index into the source area */
2058     targ,                       /* Index into the target area */
2059     srcBitsLeft,                /* Number of source bits left to move */
2060     nsrc, ntarg,                /* Number of source and target bytes */
2061     unusedLS,                   /* Number of bits in next significant
2062                                    byte of source that are unused */
2063     accumSize;                  /* Number of meaningful bits in accum */
2064   unsigned char *bytes;         /* First byte containing data to unpack */
2065   unsigned char *unpacked;
2066   unsigned long accum;          /* Staging area for bits being transferred */
2067   unsigned char sign;
2068   int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2069   /* Transmit bytes from least to most significant; delta is the direction
2070      the indices move.  */
2071   int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1;
2072
2073   type = ada_check_typedef (type);
2074
2075   if (obj == NULL)
2076     {
2077       v = allocate_value (type);
2078       bytes = (unsigned char *) (valaddr + offset);
2079     }
2080   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2081     {
2082       v = value_at (type,
2083                     value_address (obj) + offset);
2084       bytes = (unsigned char *) alloca (len);
2085       read_memory (value_address (v), bytes, len);
2086     }
2087   else
2088     {
2089       v = allocate_value (type);
2090       bytes = (unsigned char *) value_contents (obj) + offset;
2091     }
2092
2093   if (obj != NULL)
2094     {
2095       CORE_ADDR new_addr;
2096       set_value_component_location (v, obj);
2097       new_addr = value_address (obj) + offset;
2098       set_value_bitpos (v, bit_offset + value_bitpos (obj));
2099       set_value_bitsize (v, bit_size);
2100       if (value_bitpos (v) >= HOST_CHAR_BIT)
2101         {
2102           ++new_addr;
2103           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2104         }
2105       set_value_address (v, new_addr);
2106     }
2107   else
2108     set_value_bitsize (v, bit_size);
2109   unpacked = (unsigned char *) value_contents (v);
2110
2111   srcBitsLeft = bit_size;
2112   nsrc = len;
2113   ntarg = TYPE_LENGTH (type);
2114   sign = 0;
2115   if (bit_size == 0)
2116     {
2117       memset (unpacked, 0, TYPE_LENGTH (type));
2118       return v;
2119     }
2120   else if (gdbarch_bits_big_endian (get_type_arch (type)))
2121     {
2122       src = len - 1;
2123       if (has_negatives (type)
2124           && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2125         sign = ~0;
2126
2127       unusedLS =
2128         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2129         % HOST_CHAR_BIT;
2130
2131       switch (TYPE_CODE (type))
2132         {
2133         case TYPE_CODE_ARRAY:
2134         case TYPE_CODE_UNION:
2135         case TYPE_CODE_STRUCT:
2136           /* Non-scalar values must be aligned at a byte boundary...  */
2137           accumSize =
2138             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2139           /* ... And are placed at the beginning (most-significant) bytes
2140              of the target.  */
2141           targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2142           ntarg = targ + 1;
2143           break;
2144         default:
2145           accumSize = 0;
2146           targ = TYPE_LENGTH (type) - 1;
2147           break;
2148         }
2149     }
2150   else
2151     {
2152       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2153
2154       src = targ = 0;
2155       unusedLS = bit_offset;
2156       accumSize = 0;
2157
2158       if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
2159         sign = ~0;
2160     }
2161
2162   accum = 0;
2163   while (nsrc > 0)
2164     {
2165       /* Mask for removing bits of the next source byte that are not
2166          part of the value.  */
2167       unsigned int unusedMSMask =
2168         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2169         1;
2170       /* Sign-extend bits for this byte.  */
2171       unsigned int signMask = sign & ~unusedMSMask;
2172       accum |=
2173         (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2174       accumSize += HOST_CHAR_BIT - unusedLS;
2175       if (accumSize >= HOST_CHAR_BIT)
2176         {
2177           unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2178           accumSize -= HOST_CHAR_BIT;
2179           accum >>= HOST_CHAR_BIT;
2180           ntarg -= 1;
2181           targ += delta;
2182         }
2183       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2184       unusedLS = 0;
2185       nsrc -= 1;
2186       src += delta;
2187     }
2188   while (ntarg > 0)
2189     {
2190       accum |= sign << accumSize;
2191       unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2192       accumSize -= HOST_CHAR_BIT;
2193       accum >>= HOST_CHAR_BIT;
2194       ntarg -= 1;
2195       targ += delta;
2196     }
2197
2198   return v;
2199 }
2200
2201 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2202    TARGET, starting at bit offset TARG_OFFSET.  SOURCE and TARGET must
2203    not overlap.  */
2204 static void
2205 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
2206            int src_offset, int n, int bits_big_endian_p)
2207 {
2208   unsigned int accum, mask;
2209   int accum_bits, chunk_size;
2210
2211   target += targ_offset / HOST_CHAR_BIT;
2212   targ_offset %= HOST_CHAR_BIT;
2213   source += src_offset / HOST_CHAR_BIT;
2214   src_offset %= HOST_CHAR_BIT;
2215   if (bits_big_endian_p)
2216     {
2217       accum = (unsigned char) *source;
2218       source += 1;
2219       accum_bits = HOST_CHAR_BIT - src_offset;
2220
2221       while (n > 0)
2222         {
2223           int unused_right;
2224           accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2225           accum_bits += HOST_CHAR_BIT;
2226           source += 1;
2227           chunk_size = HOST_CHAR_BIT - targ_offset;
2228           if (chunk_size > n)
2229             chunk_size = n;
2230           unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2231           mask = ((1 << chunk_size) - 1) << unused_right;
2232           *target =
2233             (*target & ~mask)
2234             | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2235           n -= chunk_size;
2236           accum_bits -= chunk_size;
2237           target += 1;
2238           targ_offset = 0;
2239         }
2240     }
2241   else
2242     {
2243       accum = (unsigned char) *source >> src_offset;
2244       source += 1;
2245       accum_bits = HOST_CHAR_BIT - src_offset;
2246
2247       while (n > 0)
2248         {
2249           accum = accum + ((unsigned char) *source << accum_bits);
2250           accum_bits += HOST_CHAR_BIT;
2251           source += 1;
2252           chunk_size = HOST_CHAR_BIT - targ_offset;
2253           if (chunk_size > n)
2254             chunk_size = n;
2255           mask = ((1 << chunk_size) - 1) << targ_offset;
2256           *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2257           n -= chunk_size;
2258           accum_bits -= chunk_size;
2259           accum >>= chunk_size;
2260           target += 1;
2261           targ_offset = 0;
2262         }
2263     }
2264 }
2265
2266 /* Store the contents of FROMVAL into the location of TOVAL.
2267    Return a new value with the location of TOVAL and contents of
2268    FROMVAL.   Handles assignment into packed fields that have
2269    floating-point or non-scalar types.  */
2270
2271 static struct value *
2272 ada_value_assign (struct value *toval, struct value *fromval)
2273 {
2274   struct type *type = value_type (toval);
2275   int bits = value_bitsize (toval);
2276
2277   toval = ada_coerce_ref (toval);
2278   fromval = ada_coerce_ref (fromval);
2279
2280   if (ada_is_direct_array_type (value_type (toval)))
2281     toval = ada_coerce_to_simple_array (toval);
2282   if (ada_is_direct_array_type (value_type (fromval)))
2283     fromval = ada_coerce_to_simple_array (fromval);
2284
2285   if (!deprecated_value_modifiable (toval))
2286     error (_("Left operand of assignment is not a modifiable lvalue."));
2287
2288   if (VALUE_LVAL (toval) == lval_memory
2289       && bits > 0
2290       && (TYPE_CODE (type) == TYPE_CODE_FLT
2291           || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2292     {
2293       int len = (value_bitpos (toval)
2294                  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2295       int from_size;
2296       char *buffer = (char *) alloca (len);
2297       struct value *val;
2298       CORE_ADDR to_addr = value_address (toval);
2299
2300       if (TYPE_CODE (type) == TYPE_CODE_FLT)
2301         fromval = value_cast (type, fromval);
2302
2303       read_memory (to_addr, buffer, len);
2304       from_size = value_bitsize (fromval);
2305       if (from_size == 0)
2306         from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2307       if (gdbarch_bits_big_endian (get_type_arch (type)))
2308         move_bits (buffer, value_bitpos (toval),
2309                    value_contents (fromval), from_size - bits, bits, 1);
2310       else
2311         move_bits (buffer, value_bitpos (toval),
2312                    value_contents (fromval), 0, bits, 0);
2313       write_memory (to_addr, buffer, len);
2314       observer_notify_memory_changed (to_addr, len, buffer);
2315
2316       val = value_copy (toval);
2317       memcpy (value_contents_raw (val), value_contents (fromval),
2318               TYPE_LENGTH (type));
2319       deprecated_set_value_type (val, type);
2320
2321       return val;
2322     }
2323
2324   return value_assign (toval, fromval);
2325 }
2326
2327
2328 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2329  * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2330  * CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
2331  * COMPONENT, and not the inferior's memory.  The current contents
2332  * of COMPONENT are ignored.  */
2333 static void
2334 value_assign_to_component (struct value *container, struct value *component,
2335                            struct value *val)
2336 {
2337   LONGEST offset_in_container =
2338     (LONGEST)  (value_address (component) - value_address (container));
2339   int bit_offset_in_container =
2340     value_bitpos (component) - value_bitpos (container);
2341   int bits;
2342
2343   val = value_cast (value_type (component), val);
2344
2345   if (value_bitsize (component) == 0)
2346     bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2347   else
2348     bits = value_bitsize (component);
2349
2350   if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2351     move_bits (value_contents_writeable (container) + offset_in_container,
2352                value_bitpos (container) + bit_offset_in_container,
2353                value_contents (val),
2354                TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2355                bits, 1);
2356   else
2357     move_bits (value_contents_writeable (container) + offset_in_container,
2358                value_bitpos (container) + bit_offset_in_container,
2359                value_contents (val), 0, bits, 0);
2360 }
2361
2362 /* The value of the element of array ARR at the ARITY indices given in IND.
2363    ARR may be either a simple array, GNAT array descriptor, or pointer
2364    thereto.  */
2365
2366 struct value *
2367 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2368 {
2369   int k;
2370   struct value *elt;
2371   struct type *elt_type;
2372
2373   elt = ada_coerce_to_simple_array (arr);
2374
2375   elt_type = ada_check_typedef (value_type (elt));
2376   if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2377       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2378     return value_subscript_packed (elt, arity, ind);
2379
2380   for (k = 0; k < arity; k += 1)
2381     {
2382       if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2383         error (_("too many subscripts (%d expected)"), k);
2384       elt = value_subscript (elt, pos_atr (ind[k]));
2385     }
2386   return elt;
2387 }
2388
2389 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2390    value of the element of *ARR at the ARITY indices given in
2391    IND.  Does not read the entire array into memory.  */
2392
2393 static struct value *
2394 ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
2395                          struct value **ind)
2396 {
2397   int k;
2398
2399   for (k = 0; k < arity; k += 1)
2400     {
2401       LONGEST lwb, upb;
2402
2403       if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2404         error (_("too many subscripts (%d expected)"), k);
2405       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2406                         value_copy (arr));
2407       get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2408       arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
2409       type = TYPE_TARGET_TYPE (type);
2410     }
2411
2412   return value_ind (arr);
2413 }
2414
2415 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2416    actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2417    elements starting at index LOW.  The lower bound of this array is LOW, as
2418    per Ada rules. */
2419 static struct value *
2420 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2421                           int low, int high)
2422 {
2423   CORE_ADDR base = value_as_address (array_ptr)
2424     + ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type)))
2425        * TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
2426   struct type *index_type =
2427     create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type)),
2428                        low, high);
2429   struct type *slice_type =
2430     create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2431   return value_at_lazy (slice_type, base);
2432 }
2433
2434
2435 static struct value *
2436 ada_value_slice (struct value *array, int low, int high)
2437 {
2438   struct type *type = value_type (array);
2439   struct type *index_type =
2440     create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2441   struct type *slice_type =
2442     create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2443   return value_cast (slice_type, value_slice (array, low, high - low + 1));
2444 }
2445
2446 /* If type is a record type in the form of a standard GNAT array
2447    descriptor, returns the number of dimensions for type.  If arr is a
2448    simple array, returns the number of "array of"s that prefix its
2449    type designation.  Otherwise, returns 0.  */
2450
2451 int
2452 ada_array_arity (struct type *type)
2453 {
2454   int arity;
2455
2456   if (type == NULL)
2457     return 0;
2458
2459   type = desc_base_type (type);
2460
2461   arity = 0;
2462   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2463     return desc_arity (desc_bounds_type (type));
2464   else
2465     while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2466       {
2467         arity += 1;
2468         type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2469       }
2470
2471   return arity;
2472 }
2473
2474 /* If TYPE is a record type in the form of a standard GNAT array
2475    descriptor or a simple array type, returns the element type for
2476    TYPE after indexing by NINDICES indices, or by all indices if
2477    NINDICES is -1.  Otherwise, returns NULL.  */
2478
2479 struct type *
2480 ada_array_element_type (struct type *type, int nindices)
2481 {
2482   type = desc_base_type (type);
2483
2484   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2485     {
2486       int k;
2487       struct type *p_array_type;
2488
2489       p_array_type = desc_data_target_type (type);
2490
2491       k = ada_array_arity (type);
2492       if (k == 0)
2493         return NULL;
2494
2495       /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
2496       if (nindices >= 0 && k > nindices)
2497         k = nindices;
2498       while (k > 0 && p_array_type != NULL)
2499         {
2500           p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2501           k -= 1;
2502         }
2503       return p_array_type;
2504     }
2505   else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2506     {
2507       while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
2508         {
2509           type = TYPE_TARGET_TYPE (type);
2510           nindices -= 1;
2511         }
2512       return type;
2513     }
2514
2515   return NULL;
2516 }
2517
2518 /* The type of nth index in arrays of given type (n numbering from 1).
2519    Does not examine memory.  Throws an error if N is invalid or TYPE
2520    is not an array type.  NAME is the name of the Ada attribute being
2521    evaluated ('range, 'first, 'last, or 'length); it is used in building
2522    the error message.  */
2523
2524 static struct type *
2525 ada_index_type (struct type *type, int n, const char *name)
2526 {
2527   struct type *result_type;
2528
2529   type = desc_base_type (type);
2530
2531   if (n < 0 || n > ada_array_arity (type))
2532     error (_("invalid dimension number to '%s"), name);
2533
2534   if (ada_is_simple_array_type (type))
2535     {
2536       int i;
2537
2538       for (i = 1; i < n; i += 1)
2539         type = TYPE_TARGET_TYPE (type);
2540       result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2541       /* FIXME: The stabs type r(0,0);bound;bound in an array type
2542          has a target type of TYPE_CODE_UNDEF.  We compensate here, but
2543          perhaps stabsread.c would make more sense.  */
2544       if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2545         result_type = NULL;
2546     }
2547   else
2548     {
2549       result_type = desc_index_type (desc_bounds_type (type), n);
2550       if (result_type == NULL)
2551         error (_("attempt to take bound of something that is not an array"));
2552     }
2553
2554   return result_type;
2555 }
2556
2557 /* Given that arr is an array type, returns the lower bound of the
2558    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2559    WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
2560    array-descriptor type.  It works for other arrays with bounds supplied
2561    by run-time quantities other than discriminants.  */
2562
2563 static LONGEST
2564 ada_array_bound_from_type (struct type * arr_type, int n, int which)
2565 {
2566   struct type *type, *elt_type, *index_type_desc, *index_type;
2567   int i;
2568
2569   gdb_assert (which == 0 || which == 1);
2570
2571   if (ada_is_constrained_packed_array_type (arr_type))
2572     arr_type = decode_constrained_packed_array_type (arr_type);
2573
2574   if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2575     return (LONGEST) - which;
2576
2577   if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2578     type = TYPE_TARGET_TYPE (arr_type);
2579   else
2580     type = arr_type;
2581
2582   elt_type = type;
2583   for (i = n; i > 1; i--)
2584     elt_type = TYPE_TARGET_TYPE (type);
2585
2586   index_type_desc = ada_find_parallel_type (type, "___XA");
2587   ada_fixup_array_indexes_type (index_type_desc);
2588   if (index_type_desc != NULL)
2589     index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2590                                       NULL);
2591   else
2592     index_type = TYPE_INDEX_TYPE (elt_type);
2593
2594   return
2595     (LONGEST) (which == 0
2596                ? ada_discrete_type_low_bound (index_type)
2597                : ada_discrete_type_high_bound (index_type));
2598 }
2599
2600 /* Given that arr is an array value, returns the lower bound of the
2601    nth index (numbering from 1) if WHICH is 0, and the upper bound if
2602    WHICH is 1.  This routine will also work for arrays with bounds
2603    supplied by run-time quantities other than discriminants.  */
2604
2605 static LONGEST
2606 ada_array_bound (struct value *arr, int n, int which)
2607 {
2608   struct type *arr_type = value_type (arr);
2609
2610   if (ada_is_constrained_packed_array_type (arr_type))
2611     return ada_array_bound (decode_constrained_packed_array (arr), n, which);
2612   else if (ada_is_simple_array_type (arr_type))
2613     return ada_array_bound_from_type (arr_type, n, which);
2614   else
2615     return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
2616 }
2617
2618 /* Given that arr is an array value, returns the length of the
2619    nth index.  This routine will also work for arrays with bounds
2620    supplied by run-time quantities other than discriminants.
2621    Does not work for arrays indexed by enumeration types with representation
2622    clauses at the moment.  */
2623
2624 static LONGEST
2625 ada_array_length (struct value *arr, int n)
2626 {
2627   struct type *arr_type = ada_check_typedef (value_type (arr));
2628
2629   if (ada_is_constrained_packed_array_type (arr_type))
2630     return ada_array_length (decode_constrained_packed_array (arr), n);
2631
2632   if (ada_is_simple_array_type (arr_type))
2633     return (ada_array_bound_from_type (arr_type, n, 1)
2634             - ada_array_bound_from_type (arr_type, n, 0) + 1);
2635   else
2636     return (value_as_long (desc_one_bound (desc_bounds (arr), n, 1))
2637             - value_as_long (desc_one_bound (desc_bounds (arr), n, 0)) + 1);
2638 }
2639
2640 /* An empty array whose type is that of ARR_TYPE (an array type),
2641    with bounds LOW to LOW-1.  */
2642
2643 static struct value *
2644 empty_array (struct type *arr_type, int low)
2645 {
2646   struct type *index_type =
2647     create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type)),
2648                        low, low - 1);
2649   struct type *elt_type = ada_array_element_type (arr_type, 1);
2650   return allocate_value (create_array_type (NULL, elt_type, index_type));
2651 }
2652 \f
2653
2654                                 /* Name resolution */
2655
2656 /* The "decoded" name for the user-definable Ada operator corresponding
2657    to OP.  */
2658
2659 static const char *
2660 ada_decoded_op_name (enum exp_opcode op)
2661 {
2662   int i;
2663
2664   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
2665     {
2666       if (ada_opname_table[i].op == op)
2667         return ada_opname_table[i].decoded;
2668     }
2669   error (_("Could not find operator name for opcode"));
2670 }
2671
2672
2673 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2674    references (marked by OP_VAR_VALUE nodes in which the symbol has an
2675    undefined namespace) and converts operators that are
2676    user-defined into appropriate function calls.  If CONTEXT_TYPE is
2677    non-null, it provides a preferred result type [at the moment, only
2678    type void has any effect---causing procedures to be preferred over
2679    functions in calls].  A null CONTEXT_TYPE indicates that a non-void
2680    return type is preferred.  May change (expand) *EXP.  */
2681
2682 static void
2683 resolve (struct expression **expp, int void_context_p)
2684 {
2685   struct type *context_type = NULL;
2686   int pc = 0;
2687
2688   if (void_context_p)
2689     context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
2690
2691   resolve_subexp (expp, &pc, 1, context_type);
2692 }
2693
2694 /* Resolve the operator of the subexpression beginning at
2695    position *POS of *EXPP.  "Resolving" consists of replacing
2696    the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2697    with their resolutions, replacing built-in operators with
2698    function calls to user-defined operators, where appropriate, and,
2699    when DEPROCEDURE_P is non-zero, converting function-valued variables
2700    into parameterless calls.  May expand *EXPP.  The CONTEXT_TYPE functions
2701    are as in ada_resolve, above.  */
2702
2703 static struct value *
2704 resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
2705                 struct type *context_type)
2706 {
2707   int pc = *pos;
2708   int i;
2709   struct expression *exp;       /* Convenience: == *expp.  */
2710   enum exp_opcode op = (*expp)->elts[pc].opcode;
2711   struct value **argvec;        /* Vector of operand types (alloca'ed).  */
2712   int nargs;                    /* Number of operands.  */
2713   int oplen;
2714
2715   argvec = NULL;
2716   nargs = 0;
2717   exp = *expp;
2718
2719   /* Pass one: resolve operands, saving their types and updating *pos,
2720      if needed.  */
2721   switch (op)
2722     {
2723     case OP_FUNCALL:
2724       if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
2725           && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2726         *pos += 7;
2727       else
2728         {
2729           *pos += 3;
2730           resolve_subexp (expp, pos, 0, NULL);
2731         }
2732       nargs = longest_to_int (exp->elts[pc + 1].longconst);
2733       break;
2734
2735     case UNOP_ADDR:
2736       *pos += 1;
2737       resolve_subexp (expp, pos, 0, NULL);
2738       break;
2739
2740     case UNOP_QUAL:
2741       *pos += 3;
2742       resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
2743       break;
2744
2745     case OP_ATR_MODULUS:
2746     case OP_ATR_SIZE:
2747     case OP_ATR_TAG:
2748     case OP_ATR_FIRST:
2749     case OP_ATR_LAST:
2750     case OP_ATR_LENGTH:
2751     case OP_ATR_POS:
2752     case OP_ATR_VAL:
2753     case OP_ATR_MIN:
2754     case OP_ATR_MAX:
2755     case TERNOP_IN_RANGE:
2756     case BINOP_IN_BOUNDS:
2757     case UNOP_IN_RANGE:
2758     case OP_AGGREGATE:
2759     case OP_OTHERS:
2760     case OP_CHOICES:
2761     case OP_POSITIONAL:
2762     case OP_DISCRETE_RANGE:
2763     case OP_NAME:
2764       ada_forward_operator_length (exp, pc, &oplen, &nargs);
2765       *pos += oplen;
2766       break;
2767
2768     case BINOP_ASSIGN:
2769       {
2770         struct value *arg1;
2771
2772         *pos += 1;
2773         arg1 = resolve_subexp (expp, pos, 0, NULL);
2774         if (arg1 == NULL)
2775           resolve_subexp (expp, pos, 1, NULL);
2776         else
2777           resolve_subexp (expp, pos, 1, value_type (arg1));
2778         break;
2779       }
2780
2781     case UNOP_CAST:
2782       *pos += 3;
2783       nargs = 1;
2784       break;
2785
2786     case BINOP_ADD:
2787     case BINOP_SUB:
2788     case BINOP_MUL:
2789     case BINOP_DIV:
2790     case BINOP_REM:
2791     case BINOP_MOD:
2792     case BINOP_EXP:
2793     case BINOP_CONCAT:
2794     case BINOP_LOGICAL_AND:
2795     case BINOP_LOGICAL_OR:
2796     case BINOP_BITWISE_AND:
2797     case BINOP_BITWISE_IOR:
2798     case BINOP_BITWISE_XOR:
2799
2800     case BINOP_EQUAL:
2801     case BINOP_NOTEQUAL:
2802     case BINOP_LESS:
2803     case BINOP_GTR:
2804     case BINOP_LEQ:
2805     case BINOP_GEQ:
2806
2807     case BINOP_REPEAT:
2808     case BINOP_SUBSCRIPT:
2809     case BINOP_COMMA:
2810       *pos += 1;
2811       nargs = 2;
2812       break;
2813
2814     case UNOP_NEG:
2815     case UNOP_PLUS:
2816     case UNOP_LOGICAL_NOT:
2817     case UNOP_ABS:
2818     case UNOP_IND:
2819       *pos += 1;
2820       nargs = 1;
2821       break;
2822
2823     case OP_LONG:
2824     case OP_DOUBLE:
2825     case OP_VAR_VALUE:
2826       *pos += 4;
2827       break;
2828
2829     case OP_TYPE:
2830     case OP_BOOL:
2831     case OP_LAST:
2832     case OP_INTERNALVAR:
2833       *pos += 3;
2834       break;
2835
2836     case UNOP_MEMVAL:
2837       *pos += 3;
2838       nargs = 1;
2839       break;
2840
2841     case OP_REGISTER:
2842       *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2843       break;
2844
2845     case STRUCTOP_STRUCT:
2846       *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2847       nargs = 1;
2848       break;
2849
2850     case TERNOP_SLICE:
2851       *pos += 1;
2852       nargs = 3;
2853       break;
2854
2855     case OP_STRING:
2856       break;
2857
2858     default:
2859       error (_("Unexpected operator during name resolution"));
2860     }
2861
2862   argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
2863   for (i = 0; i < nargs; i += 1)
2864     argvec[i] = resolve_subexp (expp, pos, 1, NULL);
2865   argvec[i] = NULL;
2866   exp = *expp;
2867
2868   /* Pass two: perform any resolution on principal operator.  */
2869   switch (op)
2870     {
2871     default:
2872       break;
2873
2874     case OP_VAR_VALUE:
2875       if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
2876         {
2877           struct ada_symbol_info *candidates;
2878           int n_candidates;
2879
2880           n_candidates =
2881             ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2882                                     (exp->elts[pc + 2].symbol),
2883                                     exp->elts[pc + 1].block, VAR_DOMAIN,
2884                                     &candidates);
2885
2886           if (n_candidates > 1)
2887             {
2888               /* Types tend to get re-introduced locally, so if there
2889                  are any local symbols that are not types, first filter
2890                  out all types.  */
2891               int j;
2892               for (j = 0; j < n_candidates; j += 1)
2893                 switch (SYMBOL_CLASS (candidates[j].sym))
2894                   {
2895                   case LOC_REGISTER:
2896                   case LOC_ARG:
2897                   case LOC_REF_ARG:
2898                   case LOC_REGPARM_ADDR:
2899                   case LOC_LOCAL:
2900                   case LOC_COMPUTED:
2901                     goto FoundNonType;
2902                   default:
2903                     break;
2904                   }
2905             FoundNonType:
2906               if (j < n_candidates)
2907                 {
2908                   j = 0;
2909                   while (j < n_candidates)
2910                     {
2911                       if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
2912                         {
2913                           candidates[j] = candidates[n_candidates - 1];
2914                           n_candidates -= 1;
2915                         }
2916                       else
2917                         j += 1;
2918                     }
2919                 }
2920             }
2921
2922           if (n_candidates == 0)
2923             error (_("No definition found for %s"),
2924                    SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2925           else if (n_candidates == 1)
2926             i = 0;
2927           else if (deprocedure_p
2928                    && !is_nonfunction (candidates, n_candidates))
2929             {
2930               i = ada_resolve_function
2931                 (candidates, n_candidates, NULL, 0,
2932                  SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
2933                  context_type);
2934               if (i < 0)
2935                 error (_("Could not find a match for %s"),
2936                        SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2937             }
2938           else
2939             {
2940               printf_filtered (_("Multiple matches for %s\n"),
2941                                SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2942               user_select_syms (candidates, n_candidates, 1);
2943               i = 0;
2944             }
2945
2946           exp->elts[pc + 1].block = candidates[i].block;
2947           exp->elts[pc + 2].symbol = candidates[i].sym;
2948           if (innermost_block == NULL
2949               || contained_in (candidates[i].block, innermost_block))
2950             innermost_block = candidates[i].block;
2951         }
2952
2953       if (deprocedure_p
2954           && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
2955               == TYPE_CODE_FUNC))
2956         {
2957           replace_operator_with_call (expp, pc, 0, 0,
2958                                       exp->elts[pc + 2].symbol,
2959                                       exp->elts[pc + 1].block);
2960           exp = *expp;
2961         }
2962       break;
2963
2964     case OP_FUNCALL:
2965       {
2966         if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
2967             && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2968           {
2969             struct ada_symbol_info *candidates;
2970             int n_candidates;
2971
2972             n_candidates =
2973               ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2974                                       (exp->elts[pc + 5].symbol),
2975                                       exp->elts[pc + 4].block, VAR_DOMAIN,
2976                                       &candidates);
2977             if (n_candidates == 1)
2978               i = 0;
2979             else
2980               {
2981                 i = ada_resolve_function
2982                   (candidates, n_candidates,
2983                    argvec, nargs,
2984                    SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
2985                    context_type);
2986                 if (i < 0)
2987                   error (_("Could not find a match for %s"),
2988                          SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
2989               }
2990
2991             exp->elts[pc + 4].block = candidates[i].block;
2992             exp->elts[pc + 5].symbol = candidates[i].sym;
2993             if (innermost_block == NULL
2994                 || contained_in (candidates[i].block, innermost_block))
2995               innermost_block = candidates[i].block;
2996           }
2997       }
2998       break;
2999     case BINOP_ADD:
3000     case BINOP_SUB:
3001     case BINOP_MUL:
3002     case BINOP_DIV:
3003     case BINOP_REM:
3004     case BINOP_MOD:
3005     case BINOP_CONCAT:
3006     case BINOP_BITWISE_AND:
3007     case BINOP_BITWISE_IOR:
3008     case BINOP_BITWISE_XOR:
3009     case BINOP_EQUAL:
3010     case BINOP_NOTEQUAL:
3011     case BINOP_LESS:
3012     case BINOP_GTR:
3013     case BINOP_LEQ:
3014     case BINOP_GEQ:
3015     case BINOP_EXP:
3016     case UNOP_NEG:
3017     case UNOP_PLUS:
3018     case UNOP_LOGICAL_NOT:
3019     case UNOP_ABS:
3020       if (possible_user_operator_p (op, argvec))
3021         {
3022           struct ada_symbol_info *candidates;
3023           int n_candidates;
3024
3025           n_candidates =
3026             ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3027                                     (struct block *) NULL, VAR_DOMAIN,
3028                                     &candidates);
3029           i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
3030                                     ada_decoded_op_name (op), NULL);
3031           if (i < 0)
3032             break;
3033
3034           replace_operator_with_call (expp, pc, nargs, 1,
3035                                       candidates[i].sym, candidates[i].block);
3036           exp = *expp;
3037         }
3038       break;
3039
3040     case OP_TYPE:
3041     case OP_REGISTER:
3042       return NULL;
3043     }
3044
3045   *pos = pc;
3046   return evaluate_subexp_type (exp, pos);
3047 }
3048
3049 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  If
3050    MAY_DEREF is non-zero, the formal may be a pointer and the actual
3051    a non-pointer.  */
3052 /* The term "match" here is rather loose.  The match is heuristic and
3053    liberal.  */
3054
3055 static int
3056 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3057 {
3058   ftype = ada_check_typedef (ftype);
3059   atype = ada_check_typedef (atype);
3060
3061   if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3062     ftype = TYPE_TARGET_TYPE (ftype);
3063   if (TYPE_CODE (atype) == TYPE_CODE_REF)
3064     atype = TYPE_TARGET_TYPE (atype);
3065
3066   switch (TYPE_CODE (ftype))
3067     {
3068     default:
3069       return TYPE_CODE (ftype) == TYPE_CODE (atype);
3070     case TYPE_CODE_PTR:
3071       if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3072         return ada_type_match (TYPE_TARGET_TYPE (ftype),
3073                                TYPE_TARGET_TYPE (atype), 0);
3074       else
3075         return (may_deref
3076                 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3077     case TYPE_CODE_INT:
3078     case TYPE_CODE_ENUM:
3079     case TYPE_CODE_RANGE:
3080       switch (TYPE_CODE (atype))
3081         {
3082         case TYPE_CODE_INT:
3083         case TYPE_CODE_ENUM:
3084         case TYPE_CODE_RANGE:
3085           return 1;
3086         default:
3087           return 0;
3088         }
3089
3090     case TYPE_CODE_ARRAY:
3091       return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3092               || ada_is_array_descriptor_type (atype));
3093
3094     case TYPE_CODE_STRUCT:
3095       if (ada_is_array_descriptor_type (ftype))
3096         return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3097                 || ada_is_array_descriptor_type (atype));
3098       else
3099         return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3100                 && !ada_is_array_descriptor_type (atype));
3101
3102     case TYPE_CODE_UNION:
3103     case TYPE_CODE_FLT:
3104       return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3105     }
3106 }
3107
3108 /* Return non-zero if the formals of FUNC "sufficiently match" the
3109    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
3110    may also be an enumeral, in which case it is treated as a 0-
3111    argument function.  */
3112
3113 static int
3114 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3115 {
3116   int i;
3117   struct type *func_type = SYMBOL_TYPE (func);
3118
3119   if (SYMBOL_CLASS (func) == LOC_CONST
3120       && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3121     return (n_actuals == 0);
3122   else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3123     return 0;
3124
3125   if (TYPE_NFIELDS (func_type) != n_actuals)
3126     return 0;
3127
3128   for (i = 0; i < n_actuals; i += 1)
3129     {
3130       if (actuals[i] == NULL)
3131         return 0;
3132       else
3133         {
3134           struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type, i));
3135           struct type *atype = ada_check_typedef (value_type (actuals[i]));
3136
3137           if (!ada_type_match (ftype, atype, 1))
3138             return 0;
3139         }
3140     }
3141   return 1;
3142 }
3143
3144 /* False iff function type FUNC_TYPE definitely does not produce a value
3145    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
3146    FUNC_TYPE is not a valid function type with a non-null return type
3147    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
3148
3149 static int
3150 return_match (struct type *func_type, struct type *context_type)
3151 {
3152   struct type *return_type;
3153
3154   if (func_type == NULL)
3155     return 1;
3156
3157   if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3158     return_type = base_type (TYPE_TARGET_TYPE (func_type));
3159   else
3160     return_type = base_type (func_type);
3161   if (return_type == NULL)
3162     return 1;
3163
3164   context_type = base_type (context_type);
3165
3166   if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3167     return context_type == NULL || return_type == context_type;
3168   else if (context_type == NULL)
3169     return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3170   else
3171     return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3172 }
3173
3174
3175 /* Returns the index in SYMS[0..NSYMS-1] that contains  the symbol for the
3176    function (if any) that matches the types of the NARGS arguments in
3177    ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
3178    that returns that type, then eliminate matches that don't.  If
3179    CONTEXT_TYPE is void and there is at least one match that does not
3180    return void, eliminate all matches that do.
3181
3182    Asks the user if there is more than one match remaining.  Returns -1
3183    if there is no such symbol or none is selected.  NAME is used
3184    solely for messages.  May re-arrange and modify SYMS in
3185    the process; the index returned is for the modified vector.  */
3186
3187 static int
3188 ada_resolve_function (struct ada_symbol_info syms[],
3189                       int nsyms, struct value **args, int nargs,
3190                       const char *name, struct type *context_type)
3191 {
3192   int fallback;
3193   int k;
3194   int m;                        /* Number of hits */
3195
3196   m = 0;
3197   /* In the first pass of the loop, we only accept functions matching
3198      context_type.  If none are found, we add a second pass of the loop
3199      where every function is accepted.  */
3200   for (fallback = 0; m == 0 && fallback < 2; fallback++)
3201     {
3202       for (k = 0; k < nsyms; k += 1)
3203         {
3204           struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
3205
3206           if (ada_args_match (syms[k].sym, args, nargs)
3207               && (fallback || return_match (type, context_type)))
3208             {
3209               syms[m] = syms[k];
3210               m += 1;
3211             }
3212         }
3213     }
3214
3215   if (m == 0)
3216     return -1;
3217   else if (m > 1)
3218     {
3219       printf_filtered (_("Multiple matches for %s\n"), name);
3220       user_select_syms (syms, m, 1);
3221       return 0;
3222     }
3223   return 0;
3224 }
3225
3226 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3227    in a listing of choices during disambiguation (see sort_choices, below).
3228    The idea is that overloadings of a subprogram name from the
3229    same package should sort in their source order.  We settle for ordering
3230    such symbols by their trailing number (__N  or $N).  */
3231
3232 static int
3233 encoded_ordered_before (char *N0, char *N1)
3234 {
3235   if (N1 == NULL)
3236     return 0;
3237   else if (N0 == NULL)
3238     return 1;
3239   else
3240     {
3241       int k0, k1;
3242       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3243         ;
3244       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3245         ;
3246       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3247           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3248         {
3249           int n0, n1;
3250           n0 = k0;
3251           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3252             n0 -= 1;
3253           n1 = k1;
3254           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3255             n1 -= 1;
3256           if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3257             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3258         }
3259       return (strcmp (N0, N1) < 0);
3260     }
3261 }
3262
3263 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3264    encoded names.  */
3265
3266 static void
3267 sort_choices (struct ada_symbol_info syms[], int nsyms)
3268 {
3269   int i;
3270   for (i = 1; i < nsyms; i += 1)
3271     {
3272       struct ada_symbol_info sym = syms[i];
3273       int j;
3274
3275       for (j = i - 1; j >= 0; j -= 1)
3276         {
3277           if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3278                                       SYMBOL_LINKAGE_NAME (sym.sym)))
3279             break;
3280           syms[j + 1] = syms[j];
3281         }
3282       syms[j + 1] = sym;
3283     }
3284 }
3285
3286 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3287    by asking the user (if necessary), returning the number selected,
3288    and setting the first elements of SYMS items.  Error if no symbols
3289    selected.  */
3290
3291 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3292    to be re-integrated one of these days.  */
3293
3294 int
3295 user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
3296 {
3297   int i;
3298   int *chosen = (int *) alloca (sizeof (int) * nsyms);
3299   int n_chosen;
3300   int first_choice = (max_results == 1) ? 1 : 2;
3301   const char *select_mode = multiple_symbols_select_mode ();
3302
3303   if (max_results < 1)
3304     error (_("Request to select 0 symbols!"));
3305   if (nsyms <= 1)
3306     return nsyms;
3307
3308   if (select_mode == multiple_symbols_cancel)
3309     error (_("\
3310 canceled because the command is ambiguous\n\
3311 See set/show multiple-symbol."));
3312
3313   /* If select_mode is "all", then return all possible symbols.
3314      Only do that if more than one symbol can be selected, of course.
3315      Otherwise, display the menu as usual.  */
3316   if (select_mode == multiple_symbols_all && max_results > 1)
3317     return nsyms;
3318
3319   printf_unfiltered (_("[0] cancel\n"));
3320   if (max_results > 1)
3321     printf_unfiltered (_("[1] all\n"));
3322
3323   sort_choices (syms, nsyms);
3324
3325   for (i = 0; i < nsyms; i += 1)
3326     {
3327       if (syms[i].sym == NULL)
3328         continue;
3329
3330       if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3331         {
3332           struct symtab_and_line sal =
3333             find_function_start_sal (syms[i].sym, 1);
3334           if (sal.symtab == NULL)
3335             printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3336                                i + first_choice,
3337                                SYMBOL_PRINT_NAME (syms[i].sym),
3338                                sal.line);
3339           else
3340             printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3341                                SYMBOL_PRINT_NAME (syms[i].sym),
3342                                sal.symtab->filename, sal.line);
3343           continue;
3344         }
3345       else
3346         {
3347           int is_enumeral =
3348             (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3349              && SYMBOL_TYPE (syms[i].sym) != NULL
3350              && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
3351           struct symtab *symtab = syms[i].sym->symtab;
3352
3353           if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
3354             printf_unfiltered (_("[%d] %s at %s:%d\n"),
3355                                i + first_choice,
3356                                SYMBOL_PRINT_NAME (syms[i].sym),
3357                                symtab->filename, SYMBOL_LINE (syms[i].sym));
3358           else if (is_enumeral
3359                    && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
3360             {
3361               printf_unfiltered (("[%d] "), i + first_choice);
3362               ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
3363                               gdb_stdout, -1, 0);
3364               printf_unfiltered (_("'(%s) (enumeral)\n"),
3365                                  SYMBOL_PRINT_NAME (syms[i].sym));
3366             }
3367           else if (symtab != NULL)
3368             printf_unfiltered (is_enumeral
3369                                ? _("[%d] %s in %s (enumeral)\n")
3370                                : _("[%d] %s at %s:?\n"),
3371                                i + first_choice,
3372                                SYMBOL_PRINT_NAME (syms[i].sym),
3373                                symtab->filename);
3374           else
3375             printf_unfiltered (is_enumeral
3376                                ? _("[%d] %s (enumeral)\n")
3377                                : _("[%d] %s at ?\n"),
3378                                i + first_choice,
3379                                SYMBOL_PRINT_NAME (syms[i].sym));
3380         }
3381     }
3382
3383   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3384                              "overload-choice");
3385
3386   for (i = 0; i < n_chosen; i += 1)
3387     syms[i] = syms[chosen[i]];
3388
3389   return n_chosen;
3390 }
3391
3392 /* Read and validate a set of numeric choices from the user in the
3393    range 0 .. N_CHOICES-1.  Place the results in increasing
3394    order in CHOICES[0 .. N-1], and return N.
3395
3396    The user types choices as a sequence of numbers on one line
3397    separated by blanks, encoding them as follows:
3398
3399      + A choice of 0 means to cancel the selection, throwing an error.
3400      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3401      + The user chooses k by typing k+IS_ALL_CHOICE+1.
3402
3403    The user is not allowed to choose more than MAX_RESULTS values.
3404
3405    ANNOTATION_SUFFIX, if present, is used to annotate the input
3406    prompts (for use with the -f switch).  */
3407
3408 int
3409 get_selections (int *choices, int n_choices, int max_results,
3410                 int is_all_choice, char *annotation_suffix)
3411 {
3412   char *args;
3413   char *prompt;
3414   int n_chosen;
3415   int first_choice = is_all_choice ? 2 : 1;
3416
3417   prompt = getenv ("PS2");
3418   if (prompt == NULL)
3419     prompt = "> ";
3420
3421   args = command_line_input (prompt, 0, annotation_suffix);
3422
3423   if (args == NULL)
3424     error_no_arg (_("one or more choice numbers"));
3425
3426   n_chosen = 0;
3427
3428   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3429      order, as given in args.  Choices are validated.  */
3430   while (1)
3431     {
3432       char *args2;
3433       int choice, j;
3434
3435       while (isspace (*args))
3436         args += 1;
3437       if (*args == '\0' && n_chosen == 0)
3438         error_no_arg (_("one or more choice numbers"));
3439       else if (*args == '\0')
3440         break;
3441
3442       choice = strtol (args, &args2, 10);
3443       if (args == args2 || choice < 0
3444           || choice > n_choices + first_choice - 1)
3445         error (_("Argument must be choice number"));
3446       args = args2;
3447
3448       if (choice == 0)
3449         error (_("cancelled"));
3450
3451       if (choice < first_choice)
3452         {
3453           n_chosen = n_choices;
3454           for (j = 0; j < n_choices; j += 1)
3455             choices[j] = j;
3456           break;
3457         }
3458       choice -= first_choice;
3459
3460       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3461         {
3462         }
3463
3464       if (j < 0 || choice != choices[j])
3465         {
3466           int k;
3467           for (k = n_chosen - 1; k > j; k -= 1)
3468             choices[k + 1] = choices[k];
3469           choices[j + 1] = choice;
3470           n_chosen += 1;
3471         }
3472     }
3473
3474   if (n_chosen > max_results)
3475     error (_("Select no more than %d of the above"), max_results);
3476
3477   return n_chosen;
3478 }
3479
3480 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3481    on the function identified by SYM and BLOCK, and taking NARGS
3482    arguments.  Update *EXPP as needed to hold more space.  */
3483
3484 static void
3485 replace_operator_with_call (struct expression **expp, int pc, int nargs,
3486                             int oplen, struct symbol *sym,
3487                             struct block *block)
3488 {
3489   /* A new expression, with 6 more elements (3 for funcall, 4 for function
3490      symbol, -oplen for operator being replaced).  */
3491   struct expression *newexp = (struct expression *)
3492     xmalloc (sizeof (struct expression)
3493              + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
3494   struct expression *exp = *expp;
3495
3496   newexp->nelts = exp->nelts + 7 - oplen;
3497   newexp->language_defn = exp->language_defn;
3498   memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
3499   memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
3500           EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
3501
3502   newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3503   newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3504
3505   newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3506   newexp->elts[pc + 4].block = block;
3507   newexp->elts[pc + 5].symbol = sym;
3508
3509   *expp = newexp;
3510   xfree (exp);
3511 }
3512
3513 /* Type-class predicates */
3514
3515 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3516    or FLOAT).  */
3517
3518 static int
3519 numeric_type_p (struct type *type)
3520 {
3521   if (type == NULL)
3522     return 0;
3523   else
3524     {
3525       switch (TYPE_CODE (type))
3526         {
3527         case TYPE_CODE_INT:
3528         case TYPE_CODE_FLT:
3529           return 1;
3530         case TYPE_CODE_RANGE:
3531           return (type == TYPE_TARGET_TYPE (type)
3532                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
3533         default:
3534           return 0;
3535         }
3536     }
3537 }
3538
3539 /* True iff TYPE is integral (an INT or RANGE of INTs).  */
3540
3541 static int
3542 integer_type_p (struct type *type)
3543 {
3544   if (type == NULL)
3545     return 0;
3546   else
3547     {
3548       switch (TYPE_CODE (type))
3549         {
3550         case TYPE_CODE_INT:
3551           return 1;
3552         case TYPE_CODE_RANGE:
3553           return (type == TYPE_TARGET_TYPE (type)
3554                   || integer_type_p (TYPE_TARGET_TYPE (type)));
3555         default:
3556           return 0;
3557         }
3558     }
3559 }
3560
3561 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */
3562
3563 static int
3564 scalar_type_p (struct type *type)
3565 {
3566   if (type == NULL)
3567     return 0;
3568   else
3569     {
3570       switch (TYPE_CODE (type))
3571         {
3572         case TYPE_CODE_INT:
3573         case TYPE_CODE_RANGE:
3574         case TYPE_CODE_ENUM:
3575         case TYPE_CODE_FLT:
3576           return 1;
3577         default:
3578           return 0;
3579         }
3580     }
3581 }
3582
3583 /* True iff TYPE is discrete (INT, RANGE, ENUM).  */
3584
3585 static int
3586 discrete_type_p (struct type *type)
3587 {
3588   if (type == NULL)
3589     return 0;
3590   else
3591     {
3592       switch (TYPE_CODE (type))
3593         {
3594         case TYPE_CODE_INT:
3595         case TYPE_CODE_RANGE:
3596         case TYPE_CODE_ENUM:
3597         case TYPE_CODE_BOOL:
3598           return 1;
3599         default:
3600           return 0;
3601         }
3602     }
3603 }
3604
3605 /* Returns non-zero if OP with operands in the vector ARGS could be
3606    a user-defined function.  Errs on the side of pre-defined operators
3607    (i.e., result 0).  */
3608
3609 static int
3610 possible_user_operator_p (enum exp_opcode op, struct value *args[])
3611 {
3612   struct type *type0 =
3613     (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
3614   struct type *type1 =
3615     (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
3616
3617   if (type0 == NULL)
3618     return 0;
3619
3620   switch (op)
3621     {
3622     default:
3623       return 0;
3624
3625     case BINOP_ADD:
3626     case BINOP_SUB:
3627     case BINOP_MUL:
3628     case BINOP_DIV:
3629       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
3630
3631     case BINOP_REM:
3632     case BINOP_MOD:
3633     case BINOP_BITWISE_AND:
3634     case BINOP_BITWISE_IOR:
3635     case BINOP_BITWISE_XOR:
3636       return (!(integer_type_p (type0) && integer_type_p (type1)));
3637
3638     case BINOP_EQUAL:
3639     case BINOP_NOTEQUAL:
3640     case BINOP_LESS:
3641     case BINOP_GTR:
3642     case BINOP_LEQ:
3643     case BINOP_GEQ:
3644       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
3645
3646     case BINOP_CONCAT:
3647       return !ada_is_array_type (type0) || !ada_is_array_type (type1);
3648
3649     case BINOP_EXP:
3650       return (!(numeric_type_p (type0) && integer_type_p (type1)));
3651
3652     case UNOP_NEG:
3653     case UNOP_PLUS:
3654     case UNOP_LOGICAL_NOT:
3655     case UNOP_ABS:
3656       return (!numeric_type_p (type0));
3657
3658     }
3659 }
3660 \f
3661                                 /* Renaming */
3662
3663 /* NOTES:
3664
3665    1. In the following, we assume that a renaming type's name may
3666       have an ___XD suffix.  It would be nice if this went away at some
3667       point.
3668    2. We handle both the (old) purely type-based representation of
3669       renamings and the (new) variable-based encoding.  At some point,
3670       it is devoutly to be hoped that the former goes away
3671       (FIXME: hilfinger-2007-07-09).
3672    3. Subprogram renamings are not implemented, although the XRS
3673       suffix is recognized (FIXME: hilfinger-2007-07-09).  */
3674
3675 /* If SYM encodes a renaming,
3676
3677        <renaming> renames <renamed entity>,
3678
3679    sets *LEN to the length of the renamed entity's name,
3680    *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3681    the string describing the subcomponent selected from the renamed
3682    entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3683    (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3684    are undefined).  Otherwise, returns a value indicating the category
3685    of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3686    (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3687    subprogram (ADA_SUBPROGRAM_RENAMING).  Does no allocation; the
3688    strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3689    deallocated.  The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3690    may be NULL, in which case they are not assigned.
3691
3692    [Currently, however, GCC does not generate subprogram renamings.]  */
3693
3694 enum ada_renaming_category
3695 ada_parse_renaming (struct symbol *sym,
3696                     const char **renamed_entity, int *len,
3697                     const char **renaming_expr)
3698 {
3699   enum ada_renaming_category kind;
3700   const char *info;
3701   const char *suffix;
3702
3703   if (sym == NULL)
3704     return ADA_NOT_RENAMING;
3705   switch (SYMBOL_CLASS (sym))
3706     {
3707     default:
3708       return ADA_NOT_RENAMING;
3709     case LOC_TYPEDEF:
3710       return parse_old_style_renaming (SYMBOL_TYPE (sym),
3711                                        renamed_entity, len, renaming_expr);
3712     case LOC_LOCAL:
3713     case LOC_STATIC:
3714     case LOC_COMPUTED:
3715     case LOC_OPTIMIZED_OUT:
3716       info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
3717       if (info == NULL)
3718         return ADA_NOT_RENAMING;
3719       switch (info[5])
3720         {
3721         case '_':
3722           kind = ADA_OBJECT_RENAMING;
3723           info += 6;
3724           break;
3725         case 'E':
3726           kind = ADA_EXCEPTION_RENAMING;
3727           info += 7;
3728           break;
3729         case 'P':
3730           kind = ADA_PACKAGE_RENAMING;
3731           info += 7;
3732           break;
3733         case 'S':
3734           kind = ADA_SUBPROGRAM_RENAMING;
3735           info += 7;
3736           break;
3737         default:
3738           return ADA_NOT_RENAMING;
3739         }
3740     }
3741
3742   if (renamed_entity != NULL)
3743     *renamed_entity = info;
3744   suffix = strstr (info, "___XE");
3745   if (suffix == NULL || suffix == info)
3746     return ADA_NOT_RENAMING;
3747   if (len != NULL)
3748     *len = strlen (info) - strlen (suffix);
3749   suffix += 5;
3750   if (renaming_expr != NULL)
3751     *renaming_expr = suffix;
3752   return kind;
3753 }
3754
3755 /* Assuming TYPE encodes a renaming according to the old encoding in
3756    exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3757    *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above.  Returns
3758    ADA_NOT_RENAMING otherwise.  */
3759 static enum ada_renaming_category
3760 parse_old_style_renaming (struct type *type,
3761                           const char **renamed_entity, int *len,
3762                           const char **renaming_expr)
3763 {
3764   enum ada_renaming_category kind;
3765   const char *name;
3766   const char *info;
3767   const char *suffix;
3768
3769   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
3770       || TYPE_NFIELDS (type) != 1)
3771     return ADA_NOT_RENAMING;
3772
3773   name = type_name_no_tag (type);
3774   if (name == NULL)
3775     return ADA_NOT_RENAMING;
3776
3777   name = strstr (name, "___XR");
3778   if (name == NULL)
3779     return ADA_NOT_RENAMING;
3780   switch (name[5])
3781     {
3782     case '\0':
3783     case '_':
3784       kind = ADA_OBJECT_RENAMING;
3785       break;
3786     case 'E':
3787       kind = ADA_EXCEPTION_RENAMING;
3788       break;
3789     case 'P':
3790       kind = ADA_PACKAGE_RENAMING;
3791       break;
3792     case 'S':
3793       kind = ADA_SUBPROGRAM_RENAMING;
3794       break;
3795     default:
3796       return ADA_NOT_RENAMING;
3797     }
3798
3799   info = TYPE_FIELD_NAME (type, 0);
3800   if (info == NULL)
3801     return ADA_NOT_RENAMING;
3802   if (renamed_entity != NULL)
3803     *renamed_entity = info;
3804   suffix = strstr (info, "___XE");
3805   if (renaming_expr != NULL)
3806     *renaming_expr = suffix + 5;
3807   if (suffix == NULL || suffix == info)
3808     return ADA_NOT_RENAMING;
3809   if (len != NULL)
3810     *len = suffix - info;
3811   return kind;
3812 }
3813
3814 \f
3815
3816                                 /* Evaluation: Function Calls */
3817
3818 /* Return an lvalue containing the value VAL.  This is the identity on
3819    lvalues, and otherwise has the side-effect of pushing a copy of VAL
3820    on the stack, using and updating *SP as the stack pointer, and
3821    returning an lvalue whose value_address points to the copy.  */
3822
3823 static struct value *
3824 ensure_lval (struct value *val, struct gdbarch *gdbarch, CORE_ADDR *sp)
3825 {
3826   if (! VALUE_LVAL (val))
3827     {
3828       int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
3829
3830       /* The following is taken from the structure-return code in
3831          call_function_by_hand. FIXME: Therefore, some refactoring seems
3832          indicated. */
3833       if (gdbarch_inner_than (gdbarch, 1, 2))
3834         {
3835           /* Stack grows downward.  Align SP and value_address (val) after
3836              reserving sufficient space. */
3837           *sp -= len;
3838           if (gdbarch_frame_align_p (gdbarch))
3839             *sp = gdbarch_frame_align (gdbarch, *sp);
3840           set_value_address (val, *sp);
3841         }
3842       else
3843         {
3844           /* Stack grows upward.  Align the frame, allocate space, and
3845              then again, re-align the frame. */
3846           if (gdbarch_frame_align_p (gdbarch))
3847             *sp = gdbarch_frame_align (gdbarch, *sp);
3848           set_value_address (val, *sp);
3849           *sp += len;
3850           if (gdbarch_frame_align_p (gdbarch))
3851             *sp = gdbarch_frame_align (gdbarch, *sp);
3852         }
3853       VALUE_LVAL (val) = lval_memory;
3854
3855       write_memory (value_address (val), value_contents_raw (val), len);
3856     }
3857
3858   return val;
3859 }
3860
3861 /* Return the value ACTUAL, converted to be an appropriate value for a
3862    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
3863    allocating any necessary descriptors (fat pointers), or copies of
3864    values not residing in memory, updating it as needed.  */
3865
3866 struct value *
3867 ada_convert_actual (struct value *actual, struct type *formal_type0,
3868                     struct gdbarch *gdbarch, CORE_ADDR *sp)
3869 {
3870   struct type *actual_type = ada_check_typedef (value_type (actual));
3871   struct type *formal_type = ada_check_typedef (formal_type0);
3872   struct type *formal_target =
3873     TYPE_CODE (formal_type) == TYPE_CODE_PTR
3874     ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
3875   struct type *actual_target =
3876     TYPE_CODE (actual_type) == TYPE_CODE_PTR
3877     ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
3878
3879   if (ada_is_array_descriptor_type (formal_target)
3880       && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
3881     return make_array_descriptor (formal_type, actual, gdbarch, sp);
3882   else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
3883            || TYPE_CODE (formal_type) == TYPE_CODE_REF)
3884     {
3885       struct value *result;
3886       if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
3887           && ada_is_array_descriptor_type (actual_target))
3888         result = desc_data (actual);
3889       else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
3890         {
3891           if (VALUE_LVAL (actual) != lval_memory)
3892             {
3893               struct value *val;
3894               actual_type = ada_check_typedef (value_type (actual));
3895               val = allocate_value (actual_type);
3896               memcpy ((char *) value_contents_raw (val),
3897                       (char *) value_contents (actual),
3898                       TYPE_LENGTH (actual_type));
3899               actual = ensure_lval (val, gdbarch, sp);
3900             }
3901           result = value_addr (actual);
3902         }
3903       else
3904         return actual;
3905       return value_cast_pointers (formal_type, result);
3906     }
3907   else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
3908     return ada_value_ind (actual);
3909
3910   return actual;
3911 }
3912
3913 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
3914    type TYPE.  This is usually an inefficient no-op except on some targets
3915    (such as AVR) where the representation of a pointer and an address
3916    differs.  */
3917
3918 static CORE_ADDR
3919 value_pointer (struct value *value, struct type *type)
3920 {
3921   struct gdbarch *gdbarch = get_type_arch (type);
3922   unsigned len = TYPE_LENGTH (type);
3923   gdb_byte *buf = alloca (len);
3924   CORE_ADDR addr;
3925
3926   addr = value_address (value);
3927   gdbarch_address_to_pointer (gdbarch, type, buf, addr);
3928   addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
3929   return addr;
3930 }
3931
3932
3933 /* Push a descriptor of type TYPE for array value ARR on the stack at
3934    *SP, updating *SP to reflect the new descriptor.  Return either
3935    an lvalue representing the new descriptor, or (if TYPE is a pointer-
3936    to-descriptor type rather than a descriptor type), a struct value *
3937    representing a pointer to this descriptor.  */
3938
3939 static struct value *
3940 make_array_descriptor (struct type *type, struct value *arr,
3941                        struct gdbarch *gdbarch, CORE_ADDR *sp)
3942 {
3943   struct type *bounds_type = desc_bounds_type (type);
3944   struct type *desc_type = desc_base_type (type);
3945   struct value *descriptor = allocate_value (desc_type);
3946   struct value *bounds = allocate_value (bounds_type);
3947   int i;
3948
3949   for (i = ada_array_arity (ada_check_typedef (value_type (arr))); i > 0; i -= 1)
3950     {
3951       modify_general_field (value_type (bounds),
3952                             value_contents_writeable (bounds),
3953                             ada_array_bound (arr, i, 0),
3954                             desc_bound_bitpos (bounds_type, i, 0),
3955                             desc_bound_bitsize (bounds_type, i, 0));
3956       modify_general_field (value_type (bounds),
3957                             value_contents_writeable (bounds),
3958                             ada_array_bound (arr, i, 1),
3959                             desc_bound_bitpos (bounds_type, i, 1),
3960                             desc_bound_bitsize (bounds_type, i, 1));
3961     }
3962
3963   bounds = ensure_lval (bounds, gdbarch, sp);
3964
3965   modify_general_field (value_type (descriptor),
3966                         value_contents_writeable (descriptor),
3967                         value_pointer (ensure_lval (arr, gdbarch, sp),
3968                                        TYPE_FIELD_TYPE (desc_type, 0)),
3969                         fat_pntr_data_bitpos (desc_type),
3970                         fat_pntr_data_bitsize (desc_type));
3971
3972   modify_general_field (value_type (descriptor),
3973                         value_contents_writeable (descriptor),
3974                         value_pointer (bounds,
3975                                        TYPE_FIELD_TYPE (desc_type, 1)),
3976                         fat_pntr_bounds_bitpos (desc_type),
3977                         fat_pntr_bounds_bitsize (desc_type));
3978
3979   descriptor = ensure_lval (descriptor, gdbarch, sp);
3980
3981   if (TYPE_CODE (type) == TYPE_CODE_PTR)
3982     return value_addr (descriptor);
3983   else
3984     return descriptor;
3985 }
3986 \f
3987 /* Dummy definitions for an experimental caching module that is not
3988  * used in the public sources. */
3989
3990 static int
3991 lookup_cached_symbol (const char *name, domain_enum namespace,
3992                       struct symbol **sym, struct block **block)
3993 {
3994   return 0;
3995 }
3996
3997 static void
3998 cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
3999               struct block *block)
4000 {
4001 }
4002 \f
4003                                 /* Symbol Lookup */
4004
4005 /* Return the result of a standard (literal, C-like) lookup of NAME in
4006    given DOMAIN, visible from lexical block BLOCK.  */
4007
4008 static struct symbol *
4009 standard_lookup (const char *name, const struct block *block,
4010                  domain_enum domain)
4011 {
4012   struct symbol *sym;
4013
4014   if (lookup_cached_symbol (name, domain, &sym, NULL))
4015     return sym;
4016   sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4017   cache_symbol (name, domain, sym, block_found);
4018   return sym;
4019 }
4020
4021
4022 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4023    in the symbol fields of SYMS[0..N-1].  We treat enumerals as functions,
4024    since they contend in overloading in the same way.  */
4025 static int
4026 is_nonfunction (struct ada_symbol_info syms[], int n)
4027 {
4028   int i;
4029
4030   for (i = 0; i < n; i += 1)
4031     if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
4032         && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
4033             || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
4034       return 1;
4035
4036   return 0;
4037 }
4038
4039 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4040    struct types.  Otherwise, they may not.  */
4041
4042 static int
4043 equiv_types (struct type *type0, struct type *type1)
4044 {
4045   if (type0 == type1)
4046     return 1;
4047   if (type0 == NULL || type1 == NULL
4048       || TYPE_CODE (type0) != TYPE_CODE (type1))
4049     return 0;
4050   if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
4051        || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4052       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4053       && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4054     return 1;
4055
4056   return 0;
4057 }
4058
4059 /* True iff SYM0 represents the same entity as SYM1, or one that is
4060    no more defined than that of SYM1.  */
4061
4062 static int
4063 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4064 {
4065   if (sym0 == sym1)
4066     return 1;
4067   if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4068       || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4069     return 0;
4070
4071   switch (SYMBOL_CLASS (sym0))
4072     {
4073     case LOC_UNDEF:
4074       return 1;
4075     case LOC_TYPEDEF:
4076       {
4077         struct type *type0 = SYMBOL_TYPE (sym0);
4078         struct type *type1 = SYMBOL_TYPE (sym1);
4079         char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4080         char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4081         int len0 = strlen (name0);
4082         return
4083           TYPE_CODE (type0) == TYPE_CODE (type1)
4084           && (equiv_types (type0, type1)
4085               || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4086                   && strncmp (name1 + len0, "___XV", 5) == 0));
4087       }
4088     case LOC_CONST:
4089       return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4090         && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4091     default:
4092       return 0;
4093     }
4094 }
4095
4096 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4097    records in OBSTACKP.  Do nothing if SYM is a duplicate.  */
4098
4099 static void
4100 add_defn_to_vec (struct obstack *obstackp,
4101                  struct symbol *sym,
4102                  struct block *block)
4103 {
4104   int i;
4105   struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
4106
4107   /* Do not try to complete stub types, as the debugger is probably
4108      already scanning all symbols matching a certain name at the
4109      time when this function is called.  Trying to replace the stub
4110      type by its associated full type will cause us to restart a scan
4111      which may lead to an infinite recursion.  Instead, the client
4112      collecting the matching symbols will end up collecting several
4113      matches, with at least one of them complete.  It can then filter
4114      out the stub ones if needed.  */
4115
4116   for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4117     {
4118       if (lesseq_defined_than (sym, prevDefns[i].sym))
4119         return;
4120       else if (lesseq_defined_than (prevDefns[i].sym, sym))
4121         {
4122           prevDefns[i].sym = sym;
4123           prevDefns[i].block = block;
4124           return;
4125         }
4126     }
4127
4128   {
4129     struct ada_symbol_info info;
4130
4131     info.sym = sym;
4132     info.block = block;
4133     obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4134   }
4135 }
4136
4137 /* Number of ada_symbol_info structures currently collected in
4138    current vector in *OBSTACKP.  */
4139
4140 static int
4141 num_defns_collected (struct obstack *obstackp)
4142 {
4143   return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4144 }
4145
4146 /* Vector of ada_symbol_info structures currently collected in current
4147    vector in *OBSTACKP.  If FINISH, close off the vector and return
4148    its final address.  */
4149
4150 static struct ada_symbol_info *
4151 defns_collected (struct obstack *obstackp, int finish)
4152 {
4153   if (finish)
4154     return obstack_finish (obstackp);
4155   else
4156     return (struct ada_symbol_info *) obstack_base (obstackp);
4157 }
4158
4159 /* Return a minimal symbol matching NAME according to Ada decoding
4160    rules.  Returns NULL if there is no such minimal symbol.  Names
4161    prefixed with "standard__" are handled specially: "standard__" is
4162    first stripped off, and only static and global symbols are searched.  */
4163
4164 struct minimal_symbol *
4165 ada_lookup_simple_minsym (const char *name)
4166 {
4167   struct objfile *objfile;
4168   struct minimal_symbol *msymbol;
4169   int wild_match;
4170
4171   if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
4172     {
4173       name += sizeof ("standard__") - 1;
4174       wild_match = 0;
4175     }
4176   else
4177     wild_match = (strstr (name, "__") == NULL);
4178
4179   ALL_MSYMBOLS (objfile, msymbol)
4180   {
4181     if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match)
4182         && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4183       return msymbol;
4184   }
4185
4186   return NULL;
4187 }
4188
4189 /* For all subprograms that statically enclose the subprogram of the
4190    selected frame, add symbols matching identifier NAME in DOMAIN
4191    and their blocks to the list of data in OBSTACKP, as for
4192    ada_add_block_symbols (q.v.).   If WILD, treat as NAME with a
4193    wildcard prefix.  */
4194
4195 static void
4196 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4197                                   const char *name, domain_enum namespace,
4198                                   int wild_match)
4199 {
4200 }
4201
4202 /* True if TYPE is definitely an artificial type supplied to a symbol
4203    for which no debugging information was given in the symbol file.  */
4204
4205 static int
4206 is_nondebugging_type (struct type *type)
4207 {
4208   char *name = ada_type_name (type);
4209   return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4210 }
4211
4212 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4213    duplicate other symbols in the list (The only case I know of where
4214    this happens is when object files containing stabs-in-ecoff are
4215    linked with files containing ordinary ecoff debugging symbols (or no
4216    debugging symbols)).  Modifies SYMS to squeeze out deleted entries.
4217    Returns the number of items in the modified list.  */
4218
4219 static int
4220 remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4221 {
4222   int i, j;
4223
4224   i = 0;
4225   while (i < nsyms)
4226     {
4227       int remove = 0;
4228
4229       /* If two symbols have the same name and one of them is a stub type,
4230          the get rid of the stub.  */
4231
4232       if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
4233           && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
4234         {
4235           for (j = 0; j < nsyms; j++)
4236             {
4237               if (j != i
4238                   && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
4239                   && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4240                   && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4241                              SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
4242                 remove = 1;
4243             }
4244         }
4245
4246       /* Two symbols with the same name, same class and same address
4247          should be identical.  */
4248
4249       else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
4250           && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4251           && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4252         {
4253           for (j = 0; j < nsyms; j += 1)
4254             {
4255               if (i != j
4256                   && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4257                   && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4258                              SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
4259                   && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4260                   && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4261                   == SYMBOL_VALUE_ADDRESS (syms[j].sym))
4262                 remove = 1;
4263             }
4264         }
4265
4266       if (remove)
4267         {
4268           for (j = i + 1; j < nsyms; j += 1)
4269             syms[j - 1] = syms[j];
4270           nsyms -= 1;
4271         }
4272
4273       i += 1;
4274     }
4275   return nsyms;
4276 }
4277
4278 /* Given a type that corresponds to a renaming entity, use the type name
4279    to extract the scope (package name or function name, fully qualified,
4280    and following the GNAT encoding convention) where this renaming has been
4281    defined.  The string returned needs to be deallocated after use.  */
4282
4283 static char *
4284 xget_renaming_scope (struct type *renaming_type)
4285 {
4286   /* The renaming types adhere to the following convention:
4287      <scope>__<rename>___<XR extension>.
4288      So, to extract the scope, we search for the "___XR" extension,
4289      and then backtrack until we find the first "__".  */
4290
4291   const char *name = type_name_no_tag (renaming_type);
4292   char *suffix = strstr (name, "___XR");
4293   char *last;
4294   int scope_len;
4295   char *scope;
4296
4297   /* Now, backtrack a bit until we find the first "__".  Start looking
4298      at suffix - 3, as the <rename> part is at least one character long.  */
4299
4300   for (last = suffix - 3; last > name; last--)
4301     if (last[0] == '_' && last[1] == '_')
4302       break;
4303
4304   /* Make a copy of scope and return it.  */
4305
4306   scope_len = last - name;
4307   scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
4308
4309   strncpy (scope, name, scope_len);
4310   scope[scope_len] = '\0';
4311
4312   return scope;
4313 }
4314
4315 /* Return nonzero if NAME corresponds to a package name.  */
4316
4317 static int
4318 is_package_name (const char *name)
4319 {
4320   /* Here, We take advantage of the fact that no symbols are generated
4321      for packages, while symbols are generated for each function.
4322      So the condition for NAME represent a package becomes equivalent
4323      to NAME not existing in our list of symbols.  There is only one
4324      small complication with library-level functions (see below).  */
4325
4326   char *fun_name;
4327
4328   /* If it is a function that has not been defined at library level,
4329      then we should be able to look it up in the symbols.  */
4330   if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4331     return 0;
4332
4333   /* Library-level function names start with "_ada_".  See if function
4334      "_ada_" followed by NAME can be found.  */
4335
4336   /* Do a quick check that NAME does not contain "__", since library-level
4337      functions names cannot contain "__" in them.  */
4338   if (strstr (name, "__") != NULL)
4339     return 0;
4340
4341   fun_name = xstrprintf ("_ada_%s", name);
4342
4343   return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4344 }
4345
4346 /* Return nonzero if SYM corresponds to a renaming entity that is
4347    not visible from FUNCTION_NAME.  */
4348
4349 static int
4350 old_renaming_is_invisible (const struct symbol *sym, char *function_name)
4351 {
4352   char *scope;
4353
4354   if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4355     return 0;
4356
4357   scope = xget_renaming_scope (SYMBOL_TYPE (sym));
4358
4359   make_cleanup (xfree, scope);
4360
4361   /* If the rename has been defined in a package, then it is visible.  */
4362   if (is_package_name (scope))
4363     return 0;
4364
4365   /* Check that the rename is in the current function scope by checking
4366      that its name starts with SCOPE.  */
4367
4368   /* If the function name starts with "_ada_", it means that it is
4369      a library-level function.  Strip this prefix before doing the
4370      comparison, as the encoding for the renaming does not contain
4371      this prefix.  */
4372   if (strncmp (function_name, "_ada_", 5) == 0)
4373     function_name += 5;
4374
4375   return (strncmp (function_name, scope, strlen (scope)) != 0);
4376 }
4377
4378 /* Remove entries from SYMS that corresponds to a renaming entity that
4379    is not visible from the function associated with CURRENT_BLOCK or
4380    that is superfluous due to the presence of more specific renaming
4381    information.  Places surviving symbols in the initial entries of
4382    SYMS and returns the number of surviving symbols.
4383
4384    Rationale:
4385    First, in cases where an object renaming is implemented as a
4386    reference variable, GNAT may produce both the actual reference
4387    variable and the renaming encoding.  In this case, we discard the
4388    latter.
4389
4390    Second, GNAT emits a type following a specified encoding for each renaming
4391    entity.  Unfortunately, STABS currently does not support the definition
4392    of types that are local to a given lexical block, so all renamings types
4393    are emitted at library level.  As a consequence, if an application
4394    contains two renaming entities using the same name, and a user tries to
4395    print the value of one of these entities, the result of the ada symbol
4396    lookup will also contain the wrong renaming type.
4397
4398    This function partially covers for this limitation by attempting to
4399    remove from the SYMS list renaming symbols that should be visible
4400    from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
4401    method with the current information available.  The implementation
4402    below has a couple of limitations (FIXME: brobecker-2003-05-12):
4403
4404       - When the user tries to print a rename in a function while there
4405         is another rename entity defined in a package:  Normally, the
4406         rename in the function has precedence over the rename in the
4407         package, so the latter should be removed from the list.  This is
4408         currently not the case.
4409
4410       - This function will incorrectly remove valid renames if
4411         the CURRENT_BLOCK corresponds to a function which symbol name
4412         has been changed by an "Export" pragma.  As a consequence,
4413         the user will be unable to print such rename entities.  */
4414
4415 static int
4416 remove_irrelevant_renamings (struct ada_symbol_info *syms,
4417                              int nsyms, const struct block *current_block)
4418 {
4419   struct symbol *current_function;
4420   char *current_function_name;
4421   int i;
4422   int is_new_style_renaming;
4423
4424   /* If there is both a renaming foo___XR... encoded as a variable and
4425      a simple variable foo in the same block, discard the latter.
4426      First, zero out such symbols, then compress. */
4427   is_new_style_renaming = 0;
4428   for (i = 0; i < nsyms; i += 1)
4429     {
4430       struct symbol *sym = syms[i].sym;
4431       struct block *block = syms[i].block;
4432       const char *name;
4433       const char *suffix;
4434
4435       if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4436         continue;
4437       name = SYMBOL_LINKAGE_NAME (sym);
4438       suffix = strstr (name, "___XR");
4439
4440       if (suffix != NULL)
4441         {
4442           int name_len = suffix - name;
4443           int j;
4444           is_new_style_renaming = 1;
4445           for (j = 0; j < nsyms; j += 1)
4446             if (i != j && syms[j].sym != NULL
4447                 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
4448                             name_len) == 0
4449                 && block == syms[j].block)
4450               syms[j].sym = NULL;
4451         }
4452     }
4453   if (is_new_style_renaming)
4454     {
4455       int j, k;
4456
4457       for (j = k = 0; j < nsyms; j += 1)
4458         if (syms[j].sym != NULL)
4459             {
4460               syms[k] = syms[j];
4461               k += 1;
4462             }
4463       return k;
4464     }
4465
4466   /* Extract the function name associated to CURRENT_BLOCK.
4467      Abort if unable to do so.  */
4468
4469   if (current_block == NULL)
4470     return nsyms;
4471
4472   current_function = block_linkage_function (current_block);
4473   if (current_function == NULL)
4474     return nsyms;
4475
4476   current_function_name = SYMBOL_LINKAGE_NAME (current_function);
4477   if (current_function_name == NULL)
4478     return nsyms;
4479
4480   /* Check each of the symbols, and remove it from the list if it is
4481      a type corresponding to a renaming that is out of the scope of
4482      the current block.  */
4483
4484   i = 0;
4485   while (i < nsyms)
4486     {
4487       if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
4488           == ADA_OBJECT_RENAMING
4489           && old_renaming_is_invisible (syms[i].sym, current_function_name))
4490         {
4491           int j;
4492           for (j = i + 1; j < nsyms; j += 1)
4493             syms[j - 1] = syms[j];
4494           nsyms -= 1;
4495         }
4496       else
4497         i += 1;
4498     }
4499
4500   return nsyms;
4501 }
4502
4503 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4504    whose name and domain match NAME and DOMAIN respectively.
4505    If no match was found, then extend the search to "enclosing"
4506    routines (in other words, if we're inside a nested function,
4507    search the symbols defined inside the enclosing functions).
4508
4509    Note: This function assumes that OBSTACKP has 0 (zero) element in it.  */
4510
4511 static void
4512 ada_add_local_symbols (struct obstack *obstackp, const char *name,
4513                        struct block *block, domain_enum domain,
4514                        int wild_match)
4515 {
4516   int block_depth = 0;
4517
4518   while (block != NULL)
4519     {
4520       block_depth += 1;
4521       ada_add_block_symbols (obstackp, block, name, domain, NULL, wild_match);
4522
4523       /* If we found a non-function match, assume that's the one.  */
4524       if (is_nonfunction (defns_collected (obstackp, 0),
4525                           num_defns_collected (obstackp)))
4526         return;
4527
4528       block = BLOCK_SUPERBLOCK (block);
4529     }
4530
4531   /* If no luck so far, try to find NAME as a local symbol in some lexically
4532      enclosing subprogram.  */
4533   if (num_defns_collected (obstackp) == 0 && block_depth > 2)
4534     add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match);
4535 }
4536
4537 /* An object of this type is used as the user_data argument when
4538    calling the map_ada_symtabs method.  */
4539
4540 struct ada_psym_data
4541 {
4542   struct obstack *obstackp;
4543   const char *name;
4544   domain_enum domain;
4545   int global;
4546   int wild_match;
4547 };
4548
4549 /* Callback function for map_ada_symtabs.  */
4550
4551 static void
4552 ada_add_psyms (struct objfile *objfile, struct symtab *s, void *user_data)
4553 {
4554   struct ada_psym_data *data = user_data;
4555   const int block_kind = data->global ? GLOBAL_BLOCK : STATIC_BLOCK;
4556   ada_add_block_symbols (data->obstackp,
4557                          BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), block_kind),
4558                          data->name, data->domain, objfile, data->wild_match);
4559 }
4560
4561 /* Add to OBSTACKP all non-local symbols whose name and domain match
4562    NAME and DOMAIN respectively.  The search is performed on GLOBAL_BLOCK
4563    symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise.  */
4564
4565 static void
4566 ada_add_non_local_symbols (struct obstack *obstackp, const char *name,
4567                            domain_enum domain, int global,
4568                            int is_wild_match)
4569 {
4570   struct objfile *objfile;
4571   struct ada_psym_data data;
4572
4573   data.obstackp = obstackp;
4574   data.name = name;
4575   data.domain = domain;
4576   data.global = global;
4577   data.wild_match = is_wild_match;
4578
4579   ALL_OBJFILES (objfile)
4580   {
4581     if (objfile->sf)
4582       objfile->sf->qf->map_ada_symtabs (objfile, wild_match, is_name_suffix,
4583                                         ada_add_psyms, name,
4584                                         global, domain,
4585                                         is_wild_match, &data);
4586   }
4587 }
4588
4589 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4590    scope and in global scopes, returning the number of matches.  Sets
4591    *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4592    indicating the symbols found and the blocks and symbol tables (if
4593    any) in which they were found.  This vector are transient---good only to
4594    the next call of ada_lookup_symbol_list.  Any non-function/non-enumeral
4595    symbol match within the nest of blocks whose innermost member is BLOCK0,
4596    is the one match returned (no other matches in that or
4597      enclosing blocks is returned).  If there are any matches in or
4598    surrounding BLOCK0, then these alone are returned.  Otherwise, the
4599    search extends to global and file-scope (static) symbol tables.
4600    Names prefixed with "standard__" are handled specially: "standard__"
4601    is first stripped off, and only static and global symbols are searched.  */
4602
4603 int
4604 ada_lookup_symbol_list (const char *name0, const struct block *block0,
4605                         domain_enum namespace,
4606                         struct ada_symbol_info **results)
4607 {
4608   struct symbol *sym;
4609   struct block *block;
4610   const char *name;
4611   int wild_match;
4612   int cacheIfUnique;
4613   int ndefns;
4614
4615   obstack_free (&symbol_list_obstack, NULL);
4616   obstack_init (&symbol_list_obstack);
4617
4618   cacheIfUnique = 0;
4619
4620   /* Search specified block and its superiors.  */
4621
4622   wild_match = (strstr (name0, "__") == NULL);
4623   name = name0;
4624   block = (struct block *) block0;      /* FIXME: No cast ought to be
4625                                            needed, but adding const will
4626                                            have a cascade effect.  */
4627
4628   /* Special case: If the user specifies a symbol name inside package
4629      Standard, do a non-wild matching of the symbol name without
4630      the "standard__" prefix.  This was primarily introduced in order
4631      to allow the user to specifically access the standard exceptions
4632      using, for instance, Standard.Constraint_Error when Constraint_Error
4633      is ambiguous (due to the user defining its own Constraint_Error
4634      entity inside its program).  */
4635   if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
4636     {
4637       wild_match = 0;
4638       block = NULL;
4639       name = name0 + sizeof ("standard__") - 1;
4640     }
4641
4642   /* Check the non-global symbols.  If we have ANY match, then we're done.  */
4643
4644   ada_add_local_symbols (&symbol_list_obstack, name, block, namespace,
4645                          wild_match);
4646   if (num_defns_collected (&symbol_list_obstack) > 0)
4647     goto done;
4648
4649   /* No non-global symbols found.  Check our cache to see if we have
4650      already performed this search before.  If we have, then return
4651      the same result.  */
4652
4653   cacheIfUnique = 1;
4654   if (lookup_cached_symbol (name0, namespace, &sym, &block))
4655     {
4656       if (sym != NULL)
4657         add_defn_to_vec (&symbol_list_obstack, sym, block);
4658       goto done;
4659     }
4660
4661   /* Search symbols from all global blocks.  */
4662
4663   ada_add_non_local_symbols (&symbol_list_obstack, name, namespace, 1,
4664                              wild_match);
4665
4666   /* Now add symbols from all per-file blocks if we've gotten no hits
4667      (not strictly correct, but perhaps better than an error).  */
4668
4669   if (num_defns_collected (&symbol_list_obstack) == 0)
4670     ada_add_non_local_symbols (&symbol_list_obstack, name, namespace, 0,
4671                                wild_match);
4672
4673 done:
4674   ndefns = num_defns_collected (&symbol_list_obstack);
4675   *results = defns_collected (&symbol_list_obstack, 1);
4676
4677   ndefns = remove_extra_symbols (*results, ndefns);
4678
4679   if (ndefns == 0)
4680     cache_symbol (name0, namespace, NULL, NULL);
4681
4682   if (ndefns == 1 && cacheIfUnique)
4683     cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
4684
4685   ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
4686
4687   return ndefns;
4688 }
4689
4690 struct symbol *
4691 ada_lookup_encoded_symbol (const char *name, const struct block *block0,
4692                            domain_enum namespace, struct block **block_found)
4693 {
4694   struct ada_symbol_info *candidates;
4695   int n_candidates;
4696
4697   n_candidates = ada_lookup_symbol_list (name, block0, namespace, &candidates);
4698
4699   if (n_candidates == 0)
4700     return NULL;
4701
4702   if (block_found != NULL)
4703     *block_found = candidates[0].block;
4704
4705   return fixup_symbol_section (candidates[0].sym, NULL);
4706 }
4707
4708 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4709    scope and in global scopes, or NULL if none.  NAME is folded and
4710    encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
4711    choosing the first symbol if there are multiple choices.
4712    *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4713    table in which the symbol was found (in both cases, these
4714    assignments occur only if the pointers are non-null).  */
4715 struct symbol *
4716 ada_lookup_symbol (const char *name, const struct block *block0,
4717                    domain_enum namespace, int *is_a_field_of_this)
4718 {
4719   if (is_a_field_of_this != NULL)
4720     *is_a_field_of_this = 0;
4721
4722   return
4723     ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
4724                                block0, namespace, NULL);
4725 }
4726
4727 static struct symbol *
4728 ada_lookup_symbol_nonlocal (const char *name,
4729                             const struct block *block,
4730                             const domain_enum domain)
4731 {
4732   return ada_lookup_symbol (name, block_static_block (block), domain, NULL);
4733 }
4734
4735
4736 /* True iff STR is a possible encoded suffix of a normal Ada name
4737    that is to be ignored for matching purposes.  Suffixes of parallel
4738    names (e.g., XVE) are not included here.  Currently, the possible suffixes
4739    are given by any of the regular expressions:
4740
4741    [.$][0-9]+       [nested subprogram suffix, on platforms such as GNU/Linux]
4742    ___[0-9]+        [nested subprogram suffix, on platforms such as HP/UX]
4743    _E[0-9]+[bs]$    [protected object entry suffixes]
4744    (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4745
4746    Also, any leading "__[0-9]+" sequence is skipped before the suffix
4747    match is performed.  This sequence is used to differentiate homonyms,
4748    is an optional part of a valid name suffix.  */
4749
4750 static int
4751 is_name_suffix (const char *str)
4752 {
4753   int k;
4754   const char *matching;
4755   const int len = strlen (str);
4756
4757   /* Skip optional leading __[0-9]+.  */
4758
4759   if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
4760     {
4761       str += 3;
4762       while (isdigit (str[0]))
4763         str += 1;
4764     }
4765
4766   /* [.$][0-9]+ */
4767
4768   if (str[0] == '.' || str[0] == '$')
4769     {
4770       matching = str + 1;
4771       while (isdigit (matching[0]))
4772         matching += 1;
4773       if (matching[0] == '\0')
4774         return 1;
4775     }
4776
4777   /* ___[0-9]+ */
4778
4779   if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
4780     {
4781       matching = str + 3;
4782       while (isdigit (matching[0]))
4783         matching += 1;
4784       if (matching[0] == '\0')
4785         return 1;
4786     }
4787
4788 #if 0
4789   /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4790      with a N at the end. Unfortunately, the compiler uses the same
4791      convention for other internal types it creates. So treating
4792      all entity names that end with an "N" as a name suffix causes
4793      some regressions. For instance, consider the case of an enumerated
4794      type. To support the 'Image attribute, it creates an array whose
4795      name ends with N.
4796      Having a single character like this as a suffix carrying some
4797      information is a bit risky. Perhaps we should change the encoding
4798      to be something like "_N" instead.  In the meantime, do not do
4799      the following check.  */
4800   /* Protected Object Subprograms */
4801   if (len == 1 && str [0] == 'N')
4802     return 1;
4803 #endif
4804
4805   /* _E[0-9]+[bs]$ */
4806   if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
4807     {
4808       matching = str + 3;
4809       while (isdigit (matching[0]))
4810         matching += 1;
4811       if ((matching[0] == 'b' || matching[0] == 's')
4812           && matching [1] == '\0')
4813         return 1;
4814     }
4815
4816   /* ??? We should not modify STR directly, as we are doing below.  This
4817      is fine in this case, but may become problematic later if we find
4818      that this alternative did not work, and want to try matching
4819      another one from the begining of STR.  Since we modified it, we
4820      won't be able to find the begining of the string anymore!  */
4821   if (str[0] == 'X')
4822     {
4823       str += 1;
4824       while (str[0] != '_' && str[0] != '\0')
4825         {
4826           if (str[0] != 'n' && str[0] != 'b')
4827             return 0;
4828           str += 1;
4829         }
4830     }
4831
4832   if (str[0] == '\000')
4833     return 1;
4834
4835   if (str[0] == '_')
4836     {
4837       if (str[1] != '_' || str[2] == '\000')
4838         return 0;
4839       if (str[2] == '_')
4840         {
4841           if (strcmp (str + 3, "JM") == 0)
4842             return 1;
4843           /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4844              the LJM suffix in favor of the JM one.  But we will
4845              still accept LJM as a valid suffix for a reasonable
4846              amount of time, just to allow ourselves to debug programs
4847              compiled using an older version of GNAT.  */
4848           if (strcmp (str + 3, "LJM") == 0)
4849             return 1;
4850           if (str[3] != 'X')
4851             return 0;
4852           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
4853               || str[4] == 'U' || str[4] == 'P')
4854             return 1;
4855           if (str[4] == 'R' && str[5] != 'T')
4856             return 1;
4857           return 0;
4858         }
4859       if (!isdigit (str[2]))
4860         return 0;
4861       for (k = 3; str[k] != '\0'; k += 1)
4862         if (!isdigit (str[k]) && str[k] != '_')
4863           return 0;
4864       return 1;
4865     }
4866   if (str[0] == '$' && isdigit (str[1]))
4867     {
4868       for (k = 2; str[k] != '\0'; k += 1)
4869         if (!isdigit (str[k]) && str[k] != '_')
4870           return 0;
4871       return 1;
4872     }
4873   return 0;
4874 }
4875
4876 /* Return non-zero if the string starting at NAME and ending before
4877    NAME_END contains no capital letters.  */
4878
4879 static int
4880 is_valid_name_for_wild_match (const char *name0)
4881 {
4882   const char *decoded_name = ada_decode (name0);
4883   int i;
4884
4885   /* If the decoded name starts with an angle bracket, it means that
4886      NAME0 does not follow the GNAT encoding format.  It should then
4887      not be allowed as a possible wild match.  */
4888   if (decoded_name[0] == '<')
4889     return 0;
4890
4891   for (i=0; decoded_name[i] != '\0'; i++)
4892     if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
4893       return 0;
4894
4895   return 1;
4896 }
4897
4898 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4899    PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1.  Ignores
4900    informational suffixes of NAME (i.e., for which is_name_suffix is
4901    true).  */
4902
4903 static int
4904 wild_match (const char *patn0, int patn_len, const char *name0)
4905 {
4906   char* match;
4907   const char* start;
4908   start = name0;
4909   while (1)
4910     {
4911       match = strstr (start, patn0);
4912       if (match == NULL)
4913         return 0;
4914       if ((match == name0
4915            || match[-1] == '.'
4916            || (match > name0 + 1 && match[-1] == '_' && match[-2] == '_')
4917            || (match == name0 + 5 && strncmp ("_ada_", name0, 5) == 0))
4918           && is_name_suffix (match + patn_len))
4919         return (match == name0 || is_valid_name_for_wild_match (name0));
4920       start = match + 1;
4921     }
4922 }
4923
4924 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
4925    vector *defn_symbols, updating the list of symbols in OBSTACKP
4926    (if necessary).  If WILD, treat as NAME with a wildcard prefix.
4927    OBJFILE is the section containing BLOCK.
4928    SYMTAB is recorded with each symbol added.  */
4929
4930 static void
4931 ada_add_block_symbols (struct obstack *obstackp,
4932                        struct block *block, const char *name,
4933                        domain_enum domain, struct objfile *objfile,
4934                        int wild)
4935 {
4936   struct dict_iterator iter;
4937   int name_len = strlen (name);
4938   /* A matching argument symbol, if any.  */
4939   struct symbol *arg_sym;
4940   /* Set true when we find a matching non-argument symbol.  */
4941   int found_sym;
4942   struct symbol *sym;
4943
4944   arg_sym = NULL;
4945   found_sym = 0;
4946   if (wild)
4947     {
4948       struct symbol *sym;
4949       ALL_BLOCK_SYMBOLS (block, iter, sym)
4950       {
4951         if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
4952                                    SYMBOL_DOMAIN (sym), domain)
4953             && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (sym)))
4954           {
4955             if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
4956               continue;
4957             else if (SYMBOL_IS_ARGUMENT (sym))
4958               arg_sym = sym;
4959             else
4960               {
4961                 found_sym = 1;
4962                 add_defn_to_vec (obstackp,
4963                                  fixup_symbol_section (sym, objfile),
4964                                  block);
4965               }
4966           }
4967       }
4968     }
4969   else
4970     {
4971       ALL_BLOCK_SYMBOLS (block, iter, sym)
4972       {
4973         if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
4974                                    SYMBOL_DOMAIN (sym), domain))
4975           {
4976             int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym), name_len);
4977             if (cmp == 0
4978                 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len))
4979               {
4980                 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
4981                   {
4982                     if (SYMBOL_IS_ARGUMENT (sym))
4983                       arg_sym = sym;
4984                     else
4985                       {
4986                         found_sym = 1;
4987                         add_defn_to_vec (obstackp,
4988                                          fixup_symbol_section (sym, objfile),
4989                                          block);
4990                       }
4991                   }
4992               }
4993           }
4994       }
4995     }
4996
4997   if (!found_sym && arg_sym != NULL)
4998     {
4999       add_defn_to_vec (obstackp,
5000                        fixup_symbol_section (arg_sym, objfile),
5001                        block);
5002     }
5003
5004   if (!wild)
5005     {
5006       arg_sym = NULL;
5007       found_sym = 0;
5008
5009       ALL_BLOCK_SYMBOLS (block, iter, sym)
5010       {
5011         if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5012                                    SYMBOL_DOMAIN (sym), domain))
5013           {
5014             int cmp;
5015
5016             cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5017             if (cmp == 0)
5018               {
5019                 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5020                 if (cmp == 0)
5021                   cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5022                                  name_len);
5023               }
5024
5025             if (cmp == 0
5026                 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5027               {
5028                 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5029                   {
5030                     if (SYMBOL_IS_ARGUMENT (sym))
5031                       arg_sym = sym;
5032                     else
5033                       {
5034                         found_sym = 1;
5035                         add_defn_to_vec (obstackp,
5036                                          fixup_symbol_section (sym, objfile),
5037                                          block);
5038                       }
5039                   }
5040               }
5041           }
5042       }
5043
5044       /* NOTE: This really shouldn't be needed for _ada_ symbols.
5045          They aren't parameters, right?  */
5046       if (!found_sym && arg_sym != NULL)
5047         {
5048           add_defn_to_vec (obstackp,
5049                            fixup_symbol_section (arg_sym, objfile),
5050                            block);
5051         }
5052     }
5053 }
5054 \f
5055
5056                                 /* Symbol Completion */
5057
5058 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5059    name in a form that's appropriate for the completion.  The result
5060    does not need to be deallocated, but is only good until the next call.
5061
5062    TEXT_LEN is equal to the length of TEXT.
5063    Perform a wild match if WILD_MATCH is set.
5064    ENCODED should be set if TEXT represents the start of a symbol name
5065    in its encoded form.  */
5066
5067 static const char *
5068 symbol_completion_match (const char *sym_name,
5069                          const char *text, int text_len,
5070                          int wild_match, int encoded)
5071 {
5072   const int verbatim_match = (text[0] == '<');
5073   int match = 0;
5074
5075   if (verbatim_match)
5076     {
5077       /* Strip the leading angle bracket.  */
5078       text = text + 1;
5079       text_len--;
5080     }
5081
5082   /* First, test against the fully qualified name of the symbol.  */
5083
5084   if (strncmp (sym_name, text, text_len) == 0)
5085     match = 1;
5086
5087   if (match && !encoded)
5088     {
5089       /* One needed check before declaring a positive match is to verify
5090          that iff we are doing a verbatim match, the decoded version
5091          of the symbol name starts with '<'.  Otherwise, this symbol name
5092          is not a suitable completion.  */
5093       const char *sym_name_copy = sym_name;
5094       int has_angle_bracket;
5095
5096       sym_name = ada_decode (sym_name);
5097       has_angle_bracket = (sym_name[0] == '<');
5098       match = (has_angle_bracket == verbatim_match);
5099       sym_name = sym_name_copy;
5100     }
5101
5102   if (match && !verbatim_match)
5103     {
5104       /* When doing non-verbatim match, another check that needs to
5105          be done is to verify that the potentially matching symbol name
5106          does not include capital letters, because the ada-mode would
5107          not be able to understand these symbol names without the
5108          angle bracket notation.  */
5109       const char *tmp;
5110
5111       for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5112       if (*tmp != '\0')
5113         match = 0;
5114     }
5115
5116   /* Second: Try wild matching...  */
5117
5118   if (!match && wild_match)
5119     {
5120       /* Since we are doing wild matching, this means that TEXT
5121          may represent an unqualified symbol name.  We therefore must
5122          also compare TEXT against the unqualified name of the symbol.  */
5123       sym_name = ada_unqualified_name (ada_decode (sym_name));
5124
5125       if (strncmp (sym_name, text, text_len) == 0)
5126         match = 1;
5127     }
5128
5129   /* Finally: If we found a mach, prepare the result to return.  */
5130
5131   if (!match)
5132     return NULL;
5133
5134   if (verbatim_match)
5135     sym_name = add_angle_brackets (sym_name);
5136
5137   if (!encoded)
5138     sym_name = ada_decode (sym_name);
5139
5140   return sym_name;
5141 }
5142
5143 DEF_VEC_P (char_ptr);
5144
5145 /* A companion function to ada_make_symbol_completion_list().
5146    Check if SYM_NAME represents a symbol which name would be suitable
5147    to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5148    it is appended at the end of the given string vector SV.
5149
5150    ORIG_TEXT is the string original string from the user command
5151    that needs to be completed.  WORD is the entire command on which
5152    completion should be performed.  These two parameters are used to
5153    determine which part of the symbol name should be added to the
5154    completion vector.
5155    if WILD_MATCH is set, then wild matching is performed.
5156    ENCODED should be set if TEXT represents a symbol name in its
5157    encoded formed (in which case the completion should also be
5158    encoded).  */
5159
5160 static void
5161 symbol_completion_add (VEC(char_ptr) **sv,
5162                        const char *sym_name,
5163                        const char *text, int text_len,
5164                        const char *orig_text, const char *word,
5165                        int wild_match, int encoded)
5166 {
5167   const char *match = symbol_completion_match (sym_name, text, text_len,
5168                                                wild_match, encoded);
5169   char *completion;
5170
5171   if (match == NULL)
5172     return;
5173
5174   /* We found a match, so add the appropriate completion to the given
5175      string vector.  */
5176
5177   if (word == orig_text)
5178     {
5179       completion = xmalloc (strlen (match) + 5);
5180       strcpy (completion, match);
5181     }
5182   else if (word > orig_text)
5183     {
5184       /* Return some portion of sym_name.  */
5185       completion = xmalloc (strlen (match) + 5);
5186       strcpy (completion, match + (word - orig_text));
5187     }
5188   else
5189     {
5190       /* Return some of ORIG_TEXT plus sym_name.  */
5191       completion = xmalloc (strlen (match) + (orig_text - word) + 5);
5192       strncpy (completion, word, orig_text - word);
5193       completion[orig_text - word] = '\0';
5194       strcat (completion, match);
5195     }
5196
5197   VEC_safe_push (char_ptr, *sv, completion);
5198 }
5199
5200 /* An object of this type is passed as the user_data argument to the
5201    map_partial_symbol_names method.  */
5202 struct add_partial_datum
5203 {
5204   VEC(char_ptr) **completions;
5205   char *text;
5206   int text_len;
5207   char *text0;
5208   char *word;
5209   int wild_match;
5210   int encoded;
5211 };
5212
5213 /* A callback for map_partial_symbol_names.  */
5214 static void
5215 ada_add_partial_symbol_completions (const char *name, void *user_data)
5216 {
5217   struct add_partial_datum *data = user_data;
5218   symbol_completion_add (data->completions, name,
5219                          data->text, data->text_len, data->text0, data->word,
5220                          data->wild_match, data->encoded);
5221 }
5222
5223 /* Return a list of possible symbol names completing TEXT0.  The list
5224    is NULL terminated.  WORD is the entire command on which completion
5225    is made.  */
5226
5227 static char **
5228 ada_make_symbol_completion_list (char *text0, char *word)
5229 {
5230   char *text;
5231   int text_len;
5232   int wild_match;
5233   int encoded;
5234   VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
5235   struct symbol *sym;
5236   struct symtab *s;
5237   struct minimal_symbol *msymbol;
5238   struct objfile *objfile;
5239   struct block *b, *surrounding_static_block = 0;
5240   int i;
5241   struct dict_iterator iter;
5242
5243   if (text0[0] == '<')
5244     {
5245       text = xstrdup (text0);
5246       make_cleanup (xfree, text);
5247       text_len = strlen (text);
5248       wild_match = 0;
5249       encoded = 1;
5250     }
5251   else
5252     {
5253       text = xstrdup (ada_encode (text0));
5254       make_cleanup (xfree, text);
5255       text_len = strlen (text);
5256       for (i = 0; i < text_len; i++)
5257         text[i] = tolower (text[i]);
5258
5259       encoded = (strstr (text0, "__") != NULL);
5260       /* If the name contains a ".", then the user is entering a fully
5261          qualified entity name, and the match must not be done in wild
5262          mode.  Similarly, if the user wants to complete what looks like
5263          an encoded name, the match must not be done in wild mode.  */
5264       wild_match = (strchr (text0, '.') == NULL && !encoded);
5265     }
5266
5267   /* First, look at the partial symtab symbols.  */
5268   {
5269     struct add_partial_datum data;
5270
5271     data.completions = &completions;
5272     data.text = text;
5273     data.text_len = text_len;
5274     data.text0 = text0;
5275     data.word = word;
5276     data.wild_match = wild_match;
5277     data.encoded = encoded;
5278     map_partial_symbol_names (ada_add_partial_symbol_completions, &data);
5279   }
5280
5281   /* At this point scan through the misc symbol vectors and add each
5282      symbol you find to the list.  Eventually we want to ignore
5283      anything that isn't a text symbol (everything else will be
5284      handled by the psymtab code above).  */
5285
5286   ALL_MSYMBOLS (objfile, msymbol)
5287   {
5288     QUIT;
5289     symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
5290                            text, text_len, text0, word, wild_match, encoded);
5291   }
5292
5293   /* Search upwards from currently selected frame (so that we can
5294      complete on local vars.  */
5295
5296   for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
5297     {
5298       if (!BLOCK_SUPERBLOCK (b))
5299         surrounding_static_block = b;   /* For elmin of dups */
5300
5301       ALL_BLOCK_SYMBOLS (b, iter, sym)
5302       {
5303         symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5304                                text, text_len, text0, word,
5305                                wild_match, encoded);
5306       }
5307     }
5308
5309   /* Go through the symtabs and check the externs and statics for
5310      symbols which match.  */
5311
5312   ALL_SYMTABS (objfile, s)
5313   {
5314     QUIT;
5315     b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
5316     ALL_BLOCK_SYMBOLS (b, iter, sym)
5317     {
5318       symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5319                              text, text_len, text0, word,
5320                              wild_match, encoded);
5321     }
5322   }
5323
5324   ALL_SYMTABS (objfile, s)
5325   {
5326     QUIT;
5327     b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
5328     /* Don't do this block twice.  */
5329     if (b == surrounding_static_block)
5330       continue;
5331     ALL_BLOCK_SYMBOLS (b, iter, sym)
5332     {
5333       symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5334                              text, text_len, text0, word,
5335                              wild_match, encoded);
5336     }
5337   }
5338
5339   /* Append the closing NULL entry.  */
5340   VEC_safe_push (char_ptr, completions, NULL);
5341
5342   /* Make a copy of the COMPLETIONS VEC before we free it, and then
5343      return the copy.  It's unfortunate that we have to make a copy
5344      of an array that we're about to destroy, but there is nothing much
5345      we can do about it.  Fortunately, it's typically not a very large
5346      array.  */
5347   {
5348     const size_t completions_size =
5349       VEC_length (char_ptr, completions) * sizeof (char *);
5350     char **result = malloc (completions_size);
5351
5352     memcpy (result, VEC_address (char_ptr, completions), completions_size);
5353
5354     VEC_free (char_ptr, completions);
5355     return result;
5356   }
5357 }
5358
5359                                 /* Field Access */
5360
5361 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5362    for tagged types.  */
5363
5364 static int
5365 ada_is_dispatch_table_ptr_type (struct type *type)
5366 {
5367   char *name;
5368
5369   if (TYPE_CODE (type) != TYPE_CODE_PTR)
5370     return 0;
5371
5372   name = TYPE_NAME (TYPE_TARGET_TYPE (type));
5373   if (name == NULL)
5374     return 0;
5375
5376   return (strcmp (name, "ada__tags__dispatch_table") == 0);
5377 }
5378
5379 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5380    to be invisible to users.  */
5381
5382 int
5383 ada_is_ignored_field (struct type *type, int field_num)
5384 {
5385   if (field_num < 0 || field_num > TYPE_NFIELDS (type))
5386     return 1;
5387
5388   /* Check the name of that field.  */
5389   {
5390     const char *name = TYPE_FIELD_NAME (type, field_num);
5391
5392     /* Anonymous field names should not be printed.
5393        brobecker/2007-02-20: I don't think this can actually happen
5394        but we don't want to print the value of annonymous fields anyway.  */
5395     if (name == NULL)
5396       return 1;
5397
5398     /* A field named "_parent" is internally generated by GNAT for
5399        tagged types, and should not be printed either.  */
5400     if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
5401       return 1;
5402   }
5403
5404   /* If this is the dispatch table of a tagged type, then ignore.  */
5405   if (ada_is_tagged_type (type, 1)
5406       && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num)))
5407     return 1;
5408
5409   /* Not a special field, so it should not be ignored.  */
5410   return 0;
5411 }
5412
5413 /* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
5414    pointer or reference type whose ultimate target has a tag field. */
5415
5416 int
5417 ada_is_tagged_type (struct type *type, int refok)
5418 {
5419   return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
5420 }
5421
5422 /* True iff TYPE represents the type of X'Tag */
5423
5424 int
5425 ada_is_tag_type (struct type *type)
5426 {
5427   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
5428     return 0;
5429   else
5430     {
5431       const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5432       return (name != NULL
5433               && strcmp (name, "ada__tags__dispatch_table") == 0);
5434     }
5435 }
5436
5437 /* The type of the tag on VAL.  */
5438
5439 struct type *
5440 ada_tag_type (struct value *val)
5441 {
5442   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
5443 }
5444
5445 /* The value of the tag on VAL.  */
5446
5447 struct value *
5448 ada_value_tag (struct value *val)
5449 {
5450   return ada_value_struct_elt (val, "_tag", 0);
5451 }
5452
5453 /* The value of the tag on the object of type TYPE whose contents are
5454    saved at VALADDR, if it is non-null, or is at memory address
5455    ADDRESS. */
5456
5457 static struct value *
5458 value_tag_from_contents_and_address (struct type *type,
5459                                      const gdb_byte *valaddr,
5460                                      CORE_ADDR address)
5461 {
5462   int tag_byte_offset;
5463   struct type *tag_type;
5464   if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
5465                          NULL, NULL, NULL))
5466     {
5467       const gdb_byte *valaddr1 = ((valaddr == NULL)
5468                                   ? NULL
5469                                   : valaddr + tag_byte_offset);
5470       CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
5471
5472       return value_from_contents_and_address (tag_type, valaddr1, address1);
5473     }
5474   return NULL;
5475 }
5476
5477 static struct type *
5478 type_from_tag (struct value *tag)
5479 {
5480   const char *type_name = ada_tag_name (tag);
5481   if (type_name != NULL)
5482     return ada_find_any_type (ada_encode (type_name));
5483   return NULL;
5484 }
5485
5486 struct tag_args
5487 {
5488   struct value *tag;
5489   char *name;
5490 };
5491
5492
5493 static int ada_tag_name_1 (void *);
5494 static int ada_tag_name_2 (struct tag_args *);
5495
5496 /* Wrapper function used by ada_tag_name.  Given a struct tag_args*
5497    value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5498    The value stored in ARGS->name is valid until the next call to
5499    ada_tag_name_1.  */
5500
5501 static int
5502 ada_tag_name_1 (void *args0)
5503 {
5504   struct tag_args *args = (struct tag_args *) args0;
5505   static char name[1024];
5506   char *p;
5507   struct value *val;
5508   args->name = NULL;
5509   val = ada_value_struct_elt (args->tag, "tsd", 1);
5510   if (val == NULL)
5511     return ada_tag_name_2 (args);
5512   val = ada_value_struct_elt (val, "expanded_name", 1);
5513   if (val == NULL)
5514     return 0;
5515   read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5516   for (p = name; *p != '\0'; p += 1)
5517     if (isalpha (*p))
5518       *p = tolower (*p);
5519   args->name = name;
5520   return 0;
5521 }
5522
5523 /* Utility function for ada_tag_name_1 that tries the second
5524    representation for the dispatch table (in which there is no
5525    explicit 'tsd' field in the referent of the tag pointer, and instead
5526    the tsd pointer is stored just before the dispatch table. */
5527
5528 static int
5529 ada_tag_name_2 (struct tag_args *args)
5530 {
5531   struct type *info_type;
5532   static char name[1024];
5533   char *p;
5534   struct value *val, *valp;
5535
5536   args->name = NULL;
5537   info_type = ada_find_any_type ("ada__tags__type_specific_data");
5538   if (info_type == NULL)
5539     return 0;
5540   info_type = lookup_pointer_type (lookup_pointer_type (info_type));
5541   valp = value_cast (info_type, args->tag);
5542   if (valp == NULL)
5543     return 0;
5544   val = value_ind (value_ptradd (valp, -1));
5545   if (val == NULL)
5546     return 0;
5547   val = ada_value_struct_elt (val, "expanded_name", 1);
5548   if (val == NULL)
5549     return 0;
5550   read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5551   for (p = name; *p != '\0'; p += 1)
5552     if (isalpha (*p))
5553       *p = tolower (*p);
5554   args->name = name;
5555   return 0;
5556 }
5557
5558 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5559  * a C string.  */
5560
5561 const char *
5562 ada_tag_name (struct value *tag)
5563 {
5564   struct tag_args args;
5565   if (!ada_is_tag_type (value_type (tag)))
5566     return NULL;
5567   args.tag = tag;
5568   args.name = NULL;
5569   catch_errors (ada_tag_name_1, &args, NULL, RETURN_MASK_ALL);
5570   return args.name;
5571 }
5572
5573 /* The parent type of TYPE, or NULL if none.  */
5574
5575 struct type *
5576 ada_parent_type (struct type *type)
5577 {
5578   int i;
5579
5580   type = ada_check_typedef (type);
5581
5582   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5583     return NULL;
5584
5585   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5586     if (ada_is_parent_field (type, i))
5587       {
5588         struct type *parent_type = TYPE_FIELD_TYPE (type, i);
5589
5590         /* If the _parent field is a pointer, then dereference it.  */
5591         if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
5592           parent_type = TYPE_TARGET_TYPE (parent_type);
5593         /* If there is a parallel XVS type, get the actual base type.  */
5594         parent_type = ada_get_base_type (parent_type);
5595
5596         return ada_check_typedef (parent_type);
5597       }
5598
5599   return NULL;
5600 }
5601
5602 /* True iff field number FIELD_NUM of structure type TYPE contains the
5603    parent-type (inherited) fields of a derived type.  Assumes TYPE is
5604    a structure type with at least FIELD_NUM+1 fields.  */
5605
5606 int
5607 ada_is_parent_field (struct type *type, int field_num)
5608 {
5609   const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5610   return (name != NULL
5611           && (strncmp (name, "PARENT", 6) == 0
5612               || strncmp (name, "_parent", 7) == 0));
5613 }
5614
5615 /* True iff field number FIELD_NUM of structure type TYPE is a
5616    transparent wrapper field (which should be silently traversed when doing
5617    field selection and flattened when printing).  Assumes TYPE is a
5618    structure type with at least FIELD_NUM+1 fields.  Such fields are always
5619    structures.  */
5620
5621 int
5622 ada_is_wrapper_field (struct type *type, int field_num)
5623 {
5624   const char *name = TYPE_FIELD_NAME (type, field_num);
5625   return (name != NULL
5626           && (strncmp (name, "PARENT", 6) == 0
5627               || strcmp (name, "REP") == 0
5628               || strncmp (name, "_parent", 7) == 0
5629               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
5630 }
5631
5632 /* True iff field number FIELD_NUM of structure or union type TYPE
5633    is a variant wrapper.  Assumes TYPE is a structure type with at least
5634    FIELD_NUM+1 fields.  */
5635
5636 int
5637 ada_is_variant_part (struct type *type, int field_num)
5638 {
5639   struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5640   return (TYPE_CODE (field_type) == TYPE_CODE_UNION
5641           || (is_dynamic_field (type, field_num)
5642               && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
5643                   == TYPE_CODE_UNION)));
5644 }
5645
5646 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5647    whose discriminants are contained in the record type OUTER_TYPE,
5648    returns the type of the controlling discriminant for the variant.
5649    May return NULL if the type could not be found.  */
5650
5651 struct type *
5652 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
5653 {
5654   char *name = ada_variant_discrim_name (var_type);
5655   return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
5656 }
5657
5658 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5659    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5660    represents a 'when others' clause; otherwise 0.  */
5661
5662 int
5663 ada_is_others_clause (struct type *type, int field_num)
5664 {
5665   const char *name = TYPE_FIELD_NAME (type, field_num);
5666   return (name != NULL && name[0] == 'O');
5667 }
5668
5669 /* Assuming that TYPE0 is the type of the variant part of a record,
5670    returns the name of the discriminant controlling the variant.
5671    The value is valid until the next call to ada_variant_discrim_name.  */
5672
5673 char *
5674 ada_variant_discrim_name (struct type *type0)
5675 {
5676   static char *result = NULL;
5677   static size_t result_len = 0;
5678   struct type *type;
5679   const char *name;
5680   const char *discrim_end;
5681   const char *discrim_start;
5682
5683   if (TYPE_CODE (type0) == TYPE_CODE_PTR)
5684     type = TYPE_TARGET_TYPE (type0);
5685   else
5686     type = type0;
5687
5688   name = ada_type_name (type);
5689
5690   if (name == NULL || name[0] == '\000')
5691     return "";
5692
5693   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
5694        discrim_end -= 1)
5695     {
5696       if (strncmp (discrim_end, "___XVN", 6) == 0)
5697         break;
5698     }
5699   if (discrim_end == name)
5700     return "";
5701
5702   for (discrim_start = discrim_end; discrim_start != name + 3;
5703        discrim_start -= 1)
5704     {
5705       if (discrim_start == name + 1)
5706         return "";
5707       if ((discrim_start > name + 3
5708            && strncmp (discrim_start - 3, "___", 3) == 0)
5709           || discrim_start[-1] == '.')
5710         break;
5711     }
5712
5713   GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
5714   strncpy (result, discrim_start, discrim_end - discrim_start);
5715   result[discrim_end - discrim_start] = '\0';
5716   return result;
5717 }
5718
5719 /* Scan STR for a subtype-encoded number, beginning at position K.
5720    Put the position of the character just past the number scanned in
5721    *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
5722    Return 1 if there was a valid number at the given position, and 0
5723    otherwise.  A "subtype-encoded" number consists of the absolute value
5724    in decimal, followed by the letter 'm' to indicate a negative number.
5725    Assumes 0m does not occur.  */
5726
5727 int
5728 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
5729 {
5730   ULONGEST RU;
5731
5732   if (!isdigit (str[k]))
5733     return 0;
5734
5735   /* Do it the hard way so as not to make any assumption about
5736      the relationship of unsigned long (%lu scan format code) and
5737      LONGEST.  */
5738   RU = 0;
5739   while (isdigit (str[k]))
5740     {
5741       RU = RU * 10 + (str[k] - '0');
5742       k += 1;
5743     }
5744
5745   if (str[k] == 'm')
5746     {
5747       if (R != NULL)
5748         *R = (-(LONGEST) (RU - 1)) - 1;
5749       k += 1;
5750     }
5751   else if (R != NULL)
5752     *R = (LONGEST) RU;
5753
5754   /* NOTE on the above: Technically, C does not say what the results of
5755      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5756      number representable as a LONGEST (although either would probably work
5757      in most implementations).  When RU>0, the locution in the then branch
5758      above is always equivalent to the negative of RU.  */
5759
5760   if (new_k != NULL)
5761     *new_k = k;
5762   return 1;
5763 }
5764
5765 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5766    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5767    in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */
5768
5769 int
5770 ada_in_variant (LONGEST val, struct type *type, int field_num)
5771 {
5772   const char *name = TYPE_FIELD_NAME (type, field_num);
5773   int p;
5774
5775   p = 0;
5776   while (1)
5777     {
5778       switch (name[p])
5779         {
5780         case '\0':
5781           return 0;
5782         case 'S':
5783           {
5784             LONGEST W;
5785             if (!ada_scan_number (name, p + 1, &W, &p))
5786               return 0;
5787             if (val == W)
5788               return 1;
5789             break;
5790           }
5791         case 'R':
5792           {
5793             LONGEST L, U;
5794             if (!ada_scan_number (name, p + 1, &L, &p)
5795                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
5796               return 0;
5797             if (val >= L && val <= U)
5798               return 1;
5799             break;
5800           }
5801         case 'O':
5802           return 1;
5803         default:
5804           return 0;
5805         }
5806     }
5807 }
5808
5809 /* FIXME: Lots of redundancy below.  Try to consolidate. */
5810
5811 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5812    ARG_TYPE, extract and return the value of one of its (non-static)
5813    fields.  FIELDNO says which field.   Differs from value_primitive_field
5814    only in that it can handle packed values of arbitrary type.  */
5815
5816 static struct value *
5817 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
5818                            struct type *arg_type)
5819 {
5820   struct type *type;
5821
5822   arg_type = ada_check_typedef (arg_type);
5823   type = TYPE_FIELD_TYPE (arg_type, fieldno);
5824
5825   /* Handle packed fields.  */
5826
5827   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
5828     {
5829       int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
5830       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
5831
5832       return ada_value_primitive_packed_val (arg1, value_contents (arg1),
5833                                              offset + bit_pos / 8,
5834                                              bit_pos % 8, bit_size, type);
5835     }
5836   else
5837     return value_primitive_field (arg1, offset, fieldno, arg_type);
5838 }
5839
5840 /* Find field with name NAME in object of type TYPE.  If found,
5841    set the following for each argument that is non-null:
5842     - *FIELD_TYPE_P to the field's type;
5843     - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
5844       an object of that type;
5845     - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
5846     - *BIT_SIZE_P to its size in bits if the field is packed, and
5847       0 otherwise;
5848    If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
5849    fields up to but not including the desired field, or by the total
5850    number of fields if not found.   A NULL value of NAME never
5851    matches; the function just counts visible fields in this case.
5852
5853    Returns 1 if found, 0 otherwise. */
5854
5855 static int
5856 find_struct_field (char *name, struct type *type, int offset,
5857                    struct type **field_type_p,
5858                    int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
5859                    int *index_p)
5860 {
5861   int i;
5862
5863   type = ada_check_typedef (type);
5864
5865   if (field_type_p != NULL)
5866     *field_type_p = NULL;
5867   if (byte_offset_p != NULL)
5868     *byte_offset_p = 0;
5869   if (bit_offset_p != NULL)
5870     *bit_offset_p = 0;
5871   if (bit_size_p != NULL)
5872     *bit_size_p = 0;
5873
5874   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5875     {
5876       int bit_pos = TYPE_FIELD_BITPOS (type, i);
5877       int fld_offset = offset + bit_pos / 8;
5878       char *t_field_name = TYPE_FIELD_NAME (type, i);
5879
5880       if (t_field_name == NULL)
5881         continue;
5882
5883       else if (name != NULL && field_name_match (t_field_name, name))
5884         {
5885           int bit_size = TYPE_FIELD_BITSIZE (type, i);
5886           if (field_type_p != NULL)
5887             *field_type_p = TYPE_FIELD_TYPE (type, i);
5888           if (byte_offset_p != NULL)
5889             *byte_offset_p = fld_offset;
5890           if (bit_offset_p != NULL)
5891             *bit_offset_p = bit_pos % 8;
5892           if (bit_size_p != NULL)
5893             *bit_size_p = bit_size;
5894           return 1;
5895         }
5896       else if (ada_is_wrapper_field (type, i))
5897         {
5898           if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
5899                                  field_type_p, byte_offset_p, bit_offset_p,
5900                                  bit_size_p, index_p))
5901             return 1;
5902         }
5903       else if (ada_is_variant_part (type, i))
5904         {
5905           /* PNH: Wait.  Do we ever execute this section, or is ARG always of
5906              fixed type?? */
5907           int j;
5908           struct type *field_type
5909             = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
5910
5911           for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
5912             {
5913               if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
5914                                      fld_offset
5915                                      + TYPE_FIELD_BITPOS (field_type, j) / 8,
5916                                      field_type_p, byte_offset_p,
5917                                      bit_offset_p, bit_size_p, index_p))
5918                 return 1;
5919             }
5920         }
5921       else if (index_p != NULL)
5922         *index_p += 1;
5923     }
5924   return 0;
5925 }
5926
5927 /* Number of user-visible fields in record type TYPE. */
5928
5929 static int
5930 num_visible_fields (struct type *type)
5931 {
5932   int n;
5933   n = 0;
5934   find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
5935   return n;
5936 }
5937
5938 /* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
5939    and search in it assuming it has (class) type TYPE.
5940    If found, return value, else return NULL.
5941
5942    Searches recursively through wrapper fields (e.g., '_parent').  */
5943
5944 static struct value *
5945 ada_search_struct_field (char *name, struct value *arg, int offset,
5946                          struct type *type)
5947 {
5948   int i;
5949   type = ada_check_typedef (type);
5950
5951   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5952     {
5953       char *t_field_name = TYPE_FIELD_NAME (type, i);
5954
5955       if (t_field_name == NULL)
5956         continue;
5957
5958       else if (field_name_match (t_field_name, name))
5959         return ada_value_primitive_field (arg, offset, i, type);
5960
5961       else if (ada_is_wrapper_field (type, i))
5962         {
5963           struct value *v =     /* Do not let indent join lines here. */
5964             ada_search_struct_field (name, arg,
5965                                      offset + TYPE_FIELD_BITPOS (type, i) / 8,
5966                                      TYPE_FIELD_TYPE (type, i));
5967           if (v != NULL)
5968             return v;
5969         }
5970
5971       else if (ada_is_variant_part (type, i))
5972         {
5973           /* PNH: Do we ever get here?  See find_struct_field. */
5974           int j;
5975           struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
5976           int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
5977
5978           for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
5979             {
5980               struct value *v = ada_search_struct_field /* Force line break.  */
5981                 (name, arg,
5982                  var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
5983                  TYPE_FIELD_TYPE (field_type, j));
5984               if (v != NULL)
5985                 return v;
5986             }
5987         }
5988     }
5989   return NULL;
5990 }
5991
5992 static struct value *ada_index_struct_field_1 (int *, struct value *,
5993                                                int, struct type *);
5994
5995
5996 /* Return field #INDEX in ARG, where the index is that returned by
5997  * find_struct_field through its INDEX_P argument.  Adjust the address
5998  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
5999  * If found, return value, else return NULL. */
6000
6001 static struct value *
6002 ada_index_struct_field (int index, struct value *arg, int offset,
6003                         struct type *type)
6004 {
6005   return ada_index_struct_field_1 (&index, arg, offset, type);
6006 }
6007
6008
6009 /* Auxiliary function for ada_index_struct_field.  Like
6010  * ada_index_struct_field, but takes index from *INDEX_P and modifies
6011  * *INDEX_P. */
6012
6013 static struct value *
6014 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6015                           struct type *type)
6016 {
6017   int i;
6018   type = ada_check_typedef (type);
6019
6020   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6021     {
6022       if (TYPE_FIELD_NAME (type, i) == NULL)
6023         continue;
6024       else if (ada_is_wrapper_field (type, i))
6025         {
6026           struct value *v =     /* Do not let indent join lines here. */
6027             ada_index_struct_field_1 (index_p, arg,
6028                                       offset + TYPE_FIELD_BITPOS (type, i) / 8,
6029                                       TYPE_FIELD_TYPE (type, i));
6030           if (v != NULL)
6031             return v;
6032         }
6033
6034       else if (ada_is_variant_part (type, i))
6035         {
6036           /* PNH: Do we ever get here?  See ada_search_struct_field,
6037              find_struct_field. */
6038           error (_("Cannot assign this kind of variant record"));
6039         }
6040       else if (*index_p == 0)
6041         return ada_value_primitive_field (arg, offset, i, type);
6042       else
6043         *index_p -= 1;
6044     }
6045   return NULL;
6046 }
6047
6048 /* Given ARG, a value of type (pointer or reference to a)*
6049    structure/union, extract the component named NAME from the ultimate
6050    target structure/union and return it as a value with its
6051    appropriate type.
6052
6053    The routine searches for NAME among all members of the structure itself
6054    and (recursively) among all members of any wrapper members
6055    (e.g., '_parent').
6056
6057    If NO_ERR, then simply return NULL in case of error, rather than
6058    calling error.  */
6059
6060 struct value *
6061 ada_value_struct_elt (struct value *arg, char *name, int no_err)
6062 {
6063   struct type *t, *t1;
6064   struct value *v;
6065
6066   v = NULL;
6067   t1 = t = ada_check_typedef (value_type (arg));
6068   if (TYPE_CODE (t) == TYPE_CODE_REF)
6069     {
6070       t1 = TYPE_TARGET_TYPE (t);
6071       if (t1 == NULL)
6072         goto BadValue;
6073       t1 = ada_check_typedef (t1);
6074       if (TYPE_CODE (t1) == TYPE_CODE_PTR)
6075         {
6076           arg = coerce_ref (arg);
6077           t = t1;
6078         }
6079     }
6080
6081   while (TYPE_CODE (t) == TYPE_CODE_PTR)
6082     {
6083       t1 = TYPE_TARGET_TYPE (t);
6084       if (t1 == NULL)
6085         goto BadValue;
6086       t1 = ada_check_typedef (t1);
6087       if (TYPE_CODE (t1) == TYPE_CODE_PTR)
6088         {
6089           arg = value_ind (arg);
6090           t = t1;
6091         }
6092       else
6093         break;
6094     }
6095
6096   if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
6097     goto BadValue;
6098
6099   if (t1 == t)
6100     v = ada_search_struct_field (name, arg, 0, t);
6101   else
6102     {
6103       int bit_offset, bit_size, byte_offset;
6104       struct type *field_type;
6105       CORE_ADDR address;
6106
6107       if (TYPE_CODE (t) == TYPE_CODE_PTR)
6108         address = value_as_address (arg);
6109       else
6110         address = unpack_pointer (t, value_contents (arg));
6111
6112       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
6113       if (find_struct_field (name, t1, 0,
6114                              &field_type, &byte_offset, &bit_offset,
6115                              &bit_size, NULL))
6116         {
6117           if (bit_size != 0)
6118             {
6119               if (TYPE_CODE (t) == TYPE_CODE_REF)
6120                 arg = ada_coerce_ref (arg);
6121               else
6122                 arg = ada_value_ind (arg);
6123               v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
6124                                                   bit_offset, bit_size,
6125                                                   field_type);
6126             }
6127           else
6128             v = value_at_lazy (field_type, address + byte_offset);
6129         }
6130     }
6131
6132   if (v != NULL || no_err)
6133     return v;
6134   else
6135     error (_("There is no member named %s."), name);
6136
6137  BadValue:
6138   if (no_err)
6139     return NULL;
6140   else
6141     error (_("Attempt to extract a component of a value that is not a record."));
6142 }
6143
6144 /* Given a type TYPE, look up the type of the component of type named NAME.
6145    If DISPP is non-null, add its byte displacement from the beginning of a
6146    structure (pointed to by a value) of type TYPE to *DISPP (does not
6147    work for packed fields).
6148
6149    Matches any field whose name has NAME as a prefix, possibly
6150    followed by "___".
6151
6152    TYPE can be either a struct or union. If REFOK, TYPE may also
6153    be a (pointer or reference)+ to a struct or union, and the
6154    ultimate target type will be searched.
6155
6156    Looks recursively into variant clauses and parent types.
6157
6158    If NOERR is nonzero, return NULL if NAME is not suitably defined or
6159    TYPE is not a type of the right kind.  */
6160
6161 static struct type *
6162 ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
6163                             int noerr, int *dispp)
6164 {
6165   int i;
6166
6167   if (name == NULL)
6168     goto BadName;
6169
6170   if (refok && type != NULL)
6171     while (1)
6172       {
6173         type = ada_check_typedef (type);
6174         if (TYPE_CODE (type) != TYPE_CODE_PTR
6175             && TYPE_CODE (type) != TYPE_CODE_REF)
6176           break;
6177         type = TYPE_TARGET_TYPE (type);
6178       }
6179
6180   if (type == NULL
6181       || (TYPE_CODE (type) != TYPE_CODE_STRUCT
6182           && TYPE_CODE (type) != TYPE_CODE_UNION))
6183     {
6184       if (noerr)
6185         return NULL;
6186       else
6187         {
6188           target_terminal_ours ();
6189           gdb_flush (gdb_stdout);
6190           if (type == NULL)
6191             error (_("Type (null) is not a structure or union type"));
6192           else
6193             {
6194               /* XXX: type_sprint */
6195               fprintf_unfiltered (gdb_stderr, _("Type "));
6196               type_print (type, "", gdb_stderr, -1);
6197               error (_(" is not a structure or union type"));
6198             }
6199         }
6200     }
6201
6202   type = to_static_fixed_type (type);
6203
6204   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6205     {
6206       char *t_field_name = TYPE_FIELD_NAME (type, i);
6207       struct type *t;
6208       int disp;
6209
6210       if (t_field_name == NULL)
6211         continue;
6212
6213       else if (field_name_match (t_field_name, name))
6214         {
6215           if (dispp != NULL)
6216             *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
6217           return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6218         }
6219
6220       else if (ada_is_wrapper_field (type, i))
6221         {
6222           disp = 0;
6223           t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
6224                                           0, 1, &disp);
6225           if (t != NULL)
6226             {
6227               if (dispp != NULL)
6228                 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6229               return t;
6230             }
6231         }
6232
6233       else if (ada_is_variant_part (type, i))
6234         {
6235           int j;
6236           struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6237
6238           for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
6239             {
6240               /* FIXME pnh 2008/01/26: We check for a field that is
6241                  NOT wrapped in a struct, since the compiler sometimes
6242                  generates these for unchecked variant types.  Revisit
6243                  if the compiler changes this practice. */
6244               char *v_field_name = TYPE_FIELD_NAME (field_type, j);
6245               disp = 0;
6246               if (v_field_name != NULL
6247                   && field_name_match (v_field_name, name))
6248                 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
6249               else
6250                 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
6251                                                 name, 0, 1, &disp);
6252
6253               if (t != NULL)
6254                 {
6255                   if (dispp != NULL)
6256                     *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6257                   return t;
6258                 }
6259             }
6260         }
6261
6262     }
6263
6264 BadName:
6265   if (!noerr)
6266     {
6267       target_terminal_ours ();
6268       gdb_flush (gdb_stdout);
6269       if (name == NULL)
6270         {
6271           /* XXX: type_sprint */
6272           fprintf_unfiltered (gdb_stderr, _("Type "));
6273           type_print (type, "", gdb_stderr, -1);
6274           error (_(" has no component named <null>"));
6275         }
6276       else
6277         {
6278           /* XXX: type_sprint */
6279           fprintf_unfiltered (gdb_stderr, _("Type "));
6280           type_print (type, "", gdb_stderr, -1);
6281           error (_(" has no component named %s"), name);
6282         }
6283     }
6284
6285   return NULL;
6286 }
6287
6288 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6289    within a value of type OUTER_TYPE, return true iff VAR_TYPE
6290    represents an unchecked union (that is, the variant part of a
6291    record that is named in an Unchecked_Union pragma). */
6292
6293 static int
6294 is_unchecked_variant (struct type *var_type, struct type *outer_type)
6295 {
6296   char *discrim_name = ada_variant_discrim_name (var_type);
6297   return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
6298           == NULL);
6299 }
6300
6301
6302 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6303    within a value of type OUTER_TYPE that is stored in GDB at
6304    OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6305    numbering from 0) is applicable.  Returns -1 if none are.  */
6306
6307 int
6308 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
6309                            const gdb_byte *outer_valaddr)
6310 {
6311   int others_clause;
6312   int i;
6313   char *discrim_name = ada_variant_discrim_name (var_type);
6314   struct value *outer;
6315   struct value *discrim;
6316   LONGEST discrim_val;
6317
6318   outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
6319   discrim = ada_value_struct_elt (outer, discrim_name, 1);
6320   if (discrim == NULL)
6321     return -1;
6322   discrim_val = value_as_long (discrim);
6323
6324   others_clause = -1;
6325   for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
6326     {
6327       if (ada_is_others_clause (var_type, i))
6328         others_clause = i;
6329       else if (ada_in_variant (discrim_val, var_type, i))
6330         return i;
6331     }
6332
6333   return others_clause;
6334 }
6335 \f
6336
6337
6338                                 /* Dynamic-Sized Records */
6339
6340 /* Strategy: The type ostensibly attached to a value with dynamic size
6341    (i.e., a size that is not statically recorded in the debugging
6342    data) does not accurately reflect the size or layout of the value.
6343    Our strategy is to convert these values to values with accurate,
6344    conventional types that are constructed on the fly.  */
6345
6346 /* There is a subtle and tricky problem here.  In general, we cannot
6347    determine the size of dynamic records without its data.  However,
6348    the 'struct value' data structure, which GDB uses to represent
6349    quantities in the inferior process (the target), requires the size
6350    of the type at the time of its allocation in order to reserve space
6351    for GDB's internal copy of the data.  That's why the
6352    'to_fixed_xxx_type' routines take (target) addresses as parameters,
6353    rather than struct value*s.
6354
6355    However, GDB's internal history variables ($1, $2, etc.) are
6356    struct value*s containing internal copies of the data that are not, in
6357    general, the same as the data at their corresponding addresses in
6358    the target.  Fortunately, the types we give to these values are all
6359    conventional, fixed-size types (as per the strategy described
6360    above), so that we don't usually have to perform the
6361    'to_fixed_xxx_type' conversions to look at their values.
6362    Unfortunately, there is one exception: if one of the internal
6363    history variables is an array whose elements are unconstrained
6364    records, then we will need to create distinct fixed types for each
6365    element selected.  */
6366
6367 /* The upshot of all of this is that many routines take a (type, host
6368    address, target address) triple as arguments to represent a value.
6369    The host address, if non-null, is supposed to contain an internal
6370    copy of the relevant data; otherwise, the program is to consult the
6371    target at the target address.  */
6372
6373 /* Assuming that VAL0 represents a pointer value, the result of
6374    dereferencing it.  Differs from value_ind in its treatment of
6375    dynamic-sized types.  */
6376
6377 struct value *
6378 ada_value_ind (struct value *val0)
6379 {
6380   struct value *val = unwrap_value (value_ind (val0));
6381   return ada_to_fixed_value (val);
6382 }
6383
6384 /* The value resulting from dereferencing any "reference to"
6385    qualifiers on VAL0.  */
6386
6387 static struct value *
6388 ada_coerce_ref (struct value *val0)
6389 {
6390   if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
6391     {
6392       struct value *val = val0;
6393       val = coerce_ref (val);
6394       val = unwrap_value (val);
6395       return ada_to_fixed_value (val);
6396     }
6397   else
6398     return val0;
6399 }
6400
6401 /* Return OFF rounded upward if necessary to a multiple of
6402    ALIGNMENT (a power of 2).  */
6403
6404 static unsigned int
6405 align_value (unsigned int off, unsigned int alignment)
6406 {
6407   return (off + alignment - 1) & ~(alignment - 1);
6408 }
6409
6410 /* Return the bit alignment required for field #F of template type TYPE.  */
6411
6412 static unsigned int
6413 field_alignment (struct type *type, int f)
6414 {
6415   const char *name = TYPE_FIELD_NAME (type, f);
6416   int len;
6417   int align_offset;
6418
6419   /* The field name should never be null, unless the debugging information
6420      is somehow malformed.  In this case, we assume the field does not
6421      require any alignment.  */
6422   if (name == NULL)
6423     return 1;
6424
6425   len = strlen (name);
6426
6427   if (!isdigit (name[len - 1]))
6428     return 1;
6429
6430   if (isdigit (name[len - 2]))
6431     align_offset = len - 2;
6432   else
6433     align_offset = len - 1;
6434
6435   if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
6436     return TARGET_CHAR_BIT;
6437
6438   return atoi (name + align_offset) * TARGET_CHAR_BIT;
6439 }
6440
6441 /* Find a symbol named NAME.  Ignores ambiguity.  */
6442
6443 struct symbol *
6444 ada_find_any_symbol (const char *name)
6445 {
6446   struct symbol *sym;
6447
6448   sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
6449   if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
6450     return sym;
6451
6452   sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
6453   return sym;
6454 }
6455
6456 /* Find a type named NAME.  Ignores ambiguity.  This routine will look
6457    solely for types defined by debug info, it will not search the GDB
6458    primitive types.  */
6459
6460 struct type *
6461 ada_find_any_type (const char *name)
6462 {
6463   struct symbol *sym = ada_find_any_symbol (name);
6464
6465   if (sym != NULL)
6466     return SYMBOL_TYPE (sym);
6467
6468   return NULL;
6469 }
6470
6471 /* Given NAME and an associated BLOCK, search all symbols for
6472    NAME suffixed with  "___XR", which is the ``renaming'' symbol
6473    associated to NAME.  Return this symbol if found, return
6474    NULL otherwise.  */
6475
6476 struct symbol *
6477 ada_find_renaming_symbol (const char *name, struct block *block)
6478 {
6479   struct symbol *sym;
6480
6481   sym = find_old_style_renaming_symbol (name, block);
6482
6483   if (sym != NULL)
6484     return sym;
6485
6486   /* Not right yet.  FIXME pnh 7/20/2007. */
6487   sym = ada_find_any_symbol (name);
6488   if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
6489     return sym;
6490   else
6491     return NULL;
6492 }
6493
6494 static struct symbol *
6495 find_old_style_renaming_symbol (const char *name, struct block *block)
6496 {
6497   const struct symbol *function_sym = block_linkage_function (block);
6498   char *rename;
6499
6500   if (function_sym != NULL)
6501     {
6502       /* If the symbol is defined inside a function, NAME is not fully
6503          qualified.  This means we need to prepend the function name
6504          as well as adding the ``___XR'' suffix to build the name of
6505          the associated renaming symbol.  */
6506       char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
6507       /* Function names sometimes contain suffixes used
6508          for instance to qualify nested subprograms.  When building
6509          the XR type name, we need to make sure that this suffix is
6510          not included.  So do not include any suffix in the function
6511          name length below.  */
6512       int function_name_len = ada_name_prefix_len (function_name);
6513       const int rename_len = function_name_len + 2      /*  "__" */
6514         + strlen (name) + 6 /* "___XR\0" */ ;
6515
6516       /* Strip the suffix if necessary.  */
6517       ada_remove_trailing_digits (function_name, &function_name_len);
6518       ada_remove_po_subprogram_suffix (function_name, &function_name_len);
6519       ada_remove_Xbn_suffix (function_name, &function_name_len);
6520
6521       /* Library-level functions are a special case, as GNAT adds
6522          a ``_ada_'' prefix to the function name to avoid namespace
6523          pollution.  However, the renaming symbols themselves do not
6524          have this prefix, so we need to skip this prefix if present.  */
6525       if (function_name_len > 5 /* "_ada_" */
6526           && strstr (function_name, "_ada_") == function_name)
6527         {
6528           function_name += 5;
6529           function_name_len -= 5;
6530         }
6531
6532       rename = (char *) alloca (rename_len * sizeof (char));
6533       strncpy (rename, function_name, function_name_len);
6534       xsnprintf (rename + function_name_len, rename_len - function_name_len,
6535                  "__%s___XR", name);
6536     }
6537   else
6538     {
6539       const int rename_len = strlen (name) + 6;
6540       rename = (char *) alloca (rename_len * sizeof (char));
6541       xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
6542     }
6543
6544   return ada_find_any_symbol (rename);
6545 }
6546
6547 /* Because of GNAT encoding conventions, several GDB symbols may match a
6548    given type name.  If the type denoted by TYPE0 is to be preferred to
6549    that of TYPE1 for purposes of type printing, return non-zero;
6550    otherwise return 0.  */
6551
6552 int
6553 ada_prefer_type (struct type *type0, struct type *type1)
6554 {
6555   if (type1 == NULL)
6556     return 1;
6557   else if (type0 == NULL)
6558     return 0;
6559   else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
6560     return 1;
6561   else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
6562     return 0;
6563   else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
6564     return 1;
6565   else if (ada_is_constrained_packed_array_type (type0))
6566     return 1;
6567   else if (ada_is_array_descriptor_type (type0)
6568            && !ada_is_array_descriptor_type (type1))
6569     return 1;
6570   else
6571     {
6572       const char *type0_name = type_name_no_tag (type0);
6573       const char *type1_name = type_name_no_tag (type1);
6574
6575       if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
6576           && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
6577         return 1;
6578     }
6579   return 0;
6580 }
6581
6582 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6583    null, its TYPE_TAG_NAME.  Null if TYPE is null.  */
6584
6585 char *
6586 ada_type_name (struct type *type)
6587 {
6588   if (type == NULL)
6589     return NULL;
6590   else if (TYPE_NAME (type) != NULL)
6591     return TYPE_NAME (type);
6592   else
6593     return TYPE_TAG_NAME (type);
6594 }
6595
6596 /* Search the list of "descriptive" types associated to TYPE for a type
6597    whose name is NAME.  */
6598
6599 static struct type *
6600 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
6601 {
6602   struct type *result;
6603
6604   /* If there no descriptive-type info, then there is no parallel type
6605      to be found.  */
6606   if (!HAVE_GNAT_AUX_INFO (type))
6607     return NULL;
6608
6609   result = TYPE_DESCRIPTIVE_TYPE (type);
6610   while (result != NULL)
6611     {
6612       char *result_name = ada_type_name (result);
6613
6614       if (result_name == NULL)
6615         {
6616           warning (_("unexpected null name on descriptive type"));
6617           return NULL;
6618         }
6619
6620       /* If the names match, stop.  */
6621       if (strcmp (result_name, name) == 0)
6622         break;
6623
6624       /* Otherwise, look at the next item on the list, if any.  */
6625       if (HAVE_GNAT_AUX_INFO (result))
6626         result = TYPE_DESCRIPTIVE_TYPE (result);
6627       else
6628         result = NULL;
6629     }
6630
6631   /* If we didn't find a match, see whether this is a packed array.  With
6632      older compilers, the descriptive type information is either absent or
6633      irrelevant when it comes to packed arrays so the above lookup fails.
6634      Fall back to using a parallel lookup by name in this case.  */
6635   if (result == NULL && ada_is_constrained_packed_array_type (type))
6636     return ada_find_any_type (name);
6637
6638   return result;
6639 }
6640
6641 /* Find a parallel type to TYPE with the specified NAME, using the
6642    descriptive type taken from the debugging information, if available,
6643    and otherwise using the (slower) name-based method.  */
6644
6645 static struct type *
6646 ada_find_parallel_type_with_name (struct type *type, const char *name)
6647 {
6648   struct type *result = NULL;
6649
6650   if (HAVE_GNAT_AUX_INFO (type))
6651     result = find_parallel_type_by_descriptive_type (type, name);
6652   else
6653     result = ada_find_any_type (name);
6654
6655   return result;
6656 }
6657
6658 /* Same as above, but specify the name of the parallel type by appending
6659    SUFFIX to the name of TYPE.  */
6660
6661 struct type *
6662 ada_find_parallel_type (struct type *type, const char *suffix)
6663 {
6664   char *name, *typename = ada_type_name (type);
6665   int len;
6666
6667   if (typename == NULL)
6668     return NULL;
6669
6670   len = strlen (typename);
6671
6672   name = (char *) alloca (len + strlen (suffix) + 1);
6673
6674   strcpy (name, typename);
6675   strcpy (name + len, suffix);
6676
6677   return ada_find_parallel_type_with_name (type, name);
6678 }
6679
6680 /* If TYPE is a variable-size record type, return the corresponding template
6681    type describing its fields.  Otherwise, return NULL.  */
6682
6683 static struct type *
6684 dynamic_template_type (struct type *type)
6685 {
6686   type = ada_check_typedef (type);
6687
6688   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
6689       || ada_type_name (type) == NULL)
6690     return NULL;
6691   else
6692     {
6693       int len = strlen (ada_type_name (type));
6694       if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
6695         return type;
6696       else
6697         return ada_find_parallel_type (type, "___XVE");
6698     }
6699 }
6700
6701 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6702    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */
6703
6704 static int
6705 is_dynamic_field (struct type *templ_type, int field_num)
6706 {
6707   const char *name = TYPE_FIELD_NAME (templ_type, field_num);
6708   return name != NULL
6709     && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
6710     && strstr (name, "___XVL") != NULL;
6711 }
6712
6713 /* The index of the variant field of TYPE, or -1 if TYPE does not
6714    represent a variant record type.  */
6715
6716 static int
6717 variant_field_index (struct type *type)
6718 {
6719   int f;
6720
6721   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6722     return -1;
6723
6724   for (f = 0; f < TYPE_NFIELDS (type); f += 1)
6725     {
6726       if (ada_is_variant_part (type, f))
6727         return f;
6728     }
6729   return -1;
6730 }
6731
6732 /* A record type with no fields.  */
6733
6734 static struct type *
6735 empty_record (struct type *template)
6736 {
6737   struct type *type = alloc_type_copy (template);
6738   TYPE_CODE (type) = TYPE_CODE_STRUCT;
6739   TYPE_NFIELDS (type) = 0;
6740   TYPE_FIELDS (type) = NULL;
6741   INIT_CPLUS_SPECIFIC (type);
6742   TYPE_NAME (type) = "<empty>";
6743   TYPE_TAG_NAME (type) = NULL;
6744   TYPE_LENGTH (type) = 0;
6745   return type;
6746 }
6747
6748 /* An ordinary record type (with fixed-length fields) that describes
6749    the value of type TYPE at VALADDR or ADDRESS (see comments at
6750    the beginning of this section) VAL according to GNAT conventions.
6751    DVAL0 should describe the (portion of a) record that contains any
6752    necessary discriminants.  It should be NULL if value_type (VAL) is
6753    an outer-level type (i.e., as opposed to a branch of a variant.)  A
6754    variant field (unless unchecked) is replaced by a particular branch
6755    of the variant.
6756
6757    If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6758    length are not statically known are discarded.  As a consequence,
6759    VALADDR, ADDRESS and DVAL0 are ignored.
6760
6761    NOTE: Limitations: For now, we assume that dynamic fields and
6762    variants occupy whole numbers of bytes.  However, they need not be
6763    byte-aligned.  */
6764
6765 struct type *
6766 ada_template_to_fixed_record_type_1 (struct type *type,
6767                                      const gdb_byte *valaddr,
6768                                      CORE_ADDR address, struct value *dval0,
6769                                      int keep_dynamic_fields)
6770 {
6771   struct value *mark = value_mark ();
6772   struct value *dval;
6773   struct type *rtype;
6774   int nfields, bit_len;
6775   int variant_field;
6776   long off;
6777   int fld_bit_len, bit_incr;
6778   int f;
6779
6780   /* Compute the number of fields in this record type that are going
6781      to be processed: unless keep_dynamic_fields, this includes only
6782      fields whose position and length are static will be processed.  */
6783   if (keep_dynamic_fields)
6784     nfields = TYPE_NFIELDS (type);
6785   else
6786     {
6787       nfields = 0;
6788       while (nfields < TYPE_NFIELDS (type)
6789              && !ada_is_variant_part (type, nfields)
6790              && !is_dynamic_field (type, nfields))
6791         nfields++;
6792     }
6793
6794   rtype = alloc_type_copy (type);
6795   TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6796   INIT_CPLUS_SPECIFIC (rtype);
6797   TYPE_NFIELDS (rtype) = nfields;
6798   TYPE_FIELDS (rtype) = (struct field *)
6799     TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6800   memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
6801   TYPE_NAME (rtype) = ada_type_name (type);
6802   TYPE_TAG_NAME (rtype) = NULL;
6803   TYPE_FIXED_INSTANCE (rtype) = 1;
6804
6805   off = 0;
6806   bit_len = 0;
6807   variant_field = -1;
6808
6809   for (f = 0; f < nfields; f += 1)
6810     {
6811       off = align_value (off, field_alignment (type, f))
6812         + TYPE_FIELD_BITPOS (type, f);
6813       TYPE_FIELD_BITPOS (rtype, f) = off;
6814       TYPE_FIELD_BITSIZE (rtype, f) = 0;
6815
6816       if (ada_is_variant_part (type, f))
6817         {
6818           variant_field = f;
6819           fld_bit_len = bit_incr = 0;
6820         }
6821       else if (is_dynamic_field (type, f))
6822         {
6823           const gdb_byte *field_valaddr = valaddr;
6824           CORE_ADDR field_address = address;
6825           struct type *field_type =
6826             TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
6827
6828           if (dval0 == NULL)
6829             {
6830               /* rtype's length is computed based on the run-time
6831                  value of discriminants.  If the discriminants are not
6832                  initialized, the type size may be completely bogus and
6833                  GDB may fail to allocate a value for it. So check the
6834                  size first before creating the value.  */
6835               check_size (rtype);
6836               dval = value_from_contents_and_address (rtype, valaddr, address);
6837             }
6838           else
6839             dval = dval0;
6840
6841           /* If the type referenced by this field is an aligner type, we need
6842              to unwrap that aligner type, because its size might not be set.
6843              Keeping the aligner type would cause us to compute the wrong
6844              size for this field, impacting the offset of the all the fields
6845              that follow this one.  */
6846           if (ada_is_aligner_type (field_type))
6847             {
6848               long field_offset = TYPE_FIELD_BITPOS (field_type, f);
6849
6850               field_valaddr = cond_offset_host (field_valaddr, field_offset);
6851               field_address = cond_offset_target (field_address, field_offset);
6852               field_type = ada_aligned_type (field_type);
6853             }
6854
6855           field_valaddr = cond_offset_host (field_valaddr,
6856                                             off / TARGET_CHAR_BIT);
6857           field_address = cond_offset_target (field_address,
6858                                               off / TARGET_CHAR_BIT);
6859
6860           /* Get the fixed type of the field.  Note that, in this case,
6861              we do not want to get the real type out of the tag: if
6862              the current field is the parent part of a tagged record,
6863              we will get the tag of the object.  Clearly wrong: the real
6864              type of the parent is not the real type of the child.  We
6865              would end up in an infinite loop.  */
6866           field_type = ada_get_base_type (field_type);
6867           field_type = ada_to_fixed_type (field_type, field_valaddr,
6868                                           field_address, dval, 0);
6869
6870           TYPE_FIELD_TYPE (rtype, f) = field_type;
6871           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6872           bit_incr = fld_bit_len =
6873             TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6874         }
6875       else
6876         {
6877           struct type *field_type = TYPE_FIELD_TYPE (type, f);
6878
6879           TYPE_FIELD_TYPE (rtype, f) = field_type;
6880           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6881           if (TYPE_FIELD_BITSIZE (type, f) > 0)
6882             bit_incr = fld_bit_len =
6883               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
6884           else
6885             bit_incr = fld_bit_len =
6886               TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
6887         }
6888       if (off + fld_bit_len > bit_len)
6889         bit_len = off + fld_bit_len;
6890       off += bit_incr;
6891       TYPE_LENGTH (rtype) =
6892         align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
6893     }
6894
6895   /* We handle the variant part, if any, at the end because of certain
6896      odd cases in which it is re-ordered so as NOT to be the last field of
6897      the record.  This can happen in the presence of representation
6898      clauses.  */
6899   if (variant_field >= 0)
6900     {
6901       struct type *branch_type;
6902
6903       off = TYPE_FIELD_BITPOS (rtype, variant_field);
6904
6905       if (dval0 == NULL)
6906         dval = value_from_contents_and_address (rtype, valaddr, address);
6907       else
6908         dval = dval0;
6909
6910       branch_type =
6911         to_fixed_variant_branch_type
6912         (TYPE_FIELD_TYPE (type, variant_field),
6913          cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6914          cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
6915       if (branch_type == NULL)
6916         {
6917           for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
6918             TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
6919           TYPE_NFIELDS (rtype) -= 1;
6920         }
6921       else
6922         {
6923           TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
6924           TYPE_FIELD_NAME (rtype, variant_field) = "S";
6925           fld_bit_len =
6926             TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
6927             TARGET_CHAR_BIT;
6928           if (off + fld_bit_len > bit_len)
6929             bit_len = off + fld_bit_len;
6930           TYPE_LENGTH (rtype) =
6931             align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
6932         }
6933     }
6934
6935   /* According to exp_dbug.ads, the size of TYPE for variable-size records
6936      should contain the alignment of that record, which should be a strictly
6937      positive value.  If null or negative, then something is wrong, most
6938      probably in the debug info.  In that case, we don't round up the size
6939      of the resulting type. If this record is not part of another structure,
6940      the current RTYPE length might be good enough for our purposes.  */
6941   if (TYPE_LENGTH (type) <= 0)
6942     {
6943       if (TYPE_NAME (rtype))
6944         warning (_("Invalid type size for `%s' detected: %d."),
6945                  TYPE_NAME (rtype), TYPE_LENGTH (type));
6946       else
6947         warning (_("Invalid type size for <unnamed> detected: %d."),
6948                  TYPE_LENGTH (type));
6949     }
6950   else
6951     {
6952       TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
6953                                          TYPE_LENGTH (type));
6954     }
6955
6956   value_free_to_mark (mark);
6957   if (TYPE_LENGTH (rtype) > varsize_limit)
6958     error (_("record type with dynamic size is larger than varsize-limit"));
6959   return rtype;
6960 }
6961
6962 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6963    of 1.  */
6964
6965 static struct type *
6966 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
6967                                CORE_ADDR address, struct value *dval0)
6968 {
6969   return ada_template_to_fixed_record_type_1 (type, valaddr,
6970                                               address, dval0, 1);
6971 }
6972
6973 /* An ordinary record type in which ___XVL-convention fields and
6974    ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6975    static approximations, containing all possible fields.  Uses
6976    no runtime values.  Useless for use in values, but that's OK,
6977    since the results are used only for type determinations.   Works on both
6978    structs and unions.  Representation note: to save space, we memorize
6979    the result of this function in the TYPE_TARGET_TYPE of the
6980    template type.  */
6981
6982 static struct type *
6983 template_to_static_fixed_type (struct type *type0)
6984 {
6985   struct type *type;
6986   int nfields;
6987   int f;
6988
6989   if (TYPE_TARGET_TYPE (type0) != NULL)
6990     return TYPE_TARGET_TYPE (type0);
6991
6992   nfields = TYPE_NFIELDS (type0);
6993   type = type0;
6994
6995   for (f = 0; f < nfields; f += 1)
6996     {
6997       struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
6998       struct type *new_type;
6999
7000       if (is_dynamic_field (type0, f))
7001         new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
7002       else
7003         new_type = static_unwrap_type (field_type);
7004       if (type == type0 && new_type != field_type)
7005         {
7006           TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
7007           TYPE_CODE (type) = TYPE_CODE (type0);
7008           INIT_CPLUS_SPECIFIC (type);
7009           TYPE_NFIELDS (type) = nfields;
7010           TYPE_FIELDS (type) = (struct field *)
7011             TYPE_ALLOC (type, nfields * sizeof (struct field));
7012           memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
7013                   sizeof (struct field) * nfields);
7014           TYPE_NAME (type) = ada_type_name (type0);
7015           TYPE_TAG_NAME (type) = NULL;
7016           TYPE_FIXED_INSTANCE (type) = 1;
7017           TYPE_LENGTH (type) = 0;
7018         }
7019       TYPE_FIELD_TYPE (type, f) = new_type;
7020       TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
7021     }
7022   return type;
7023 }
7024
7025 /* Given an object of type TYPE whose contents are at VALADDR and
7026    whose address in memory is ADDRESS, returns a revision of TYPE,
7027    which should be a non-dynamic-sized record, in which the variant
7028    part, if any, is replaced with the appropriate branch.  Looks
7029    for discriminant values in DVAL0, which can be NULL if the record
7030    contains the necessary discriminant values.  */
7031
7032 static struct type *
7033 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
7034                                    CORE_ADDR address, struct value *dval0)
7035 {
7036   struct value *mark = value_mark ();
7037   struct value *dval;
7038   struct type *rtype;
7039   struct type *branch_type;
7040   int nfields = TYPE_NFIELDS (type);
7041   int variant_field = variant_field_index (type);
7042
7043   if (variant_field == -1)
7044     return type;
7045
7046   if (dval0 == NULL)
7047     dval = value_from_contents_and_address (type, valaddr, address);
7048   else
7049     dval = dval0;
7050
7051   rtype = alloc_type_copy (type);
7052   TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7053   INIT_CPLUS_SPECIFIC (rtype);
7054   TYPE_NFIELDS (rtype) = nfields;
7055   TYPE_FIELDS (rtype) =
7056     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7057   memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
7058           sizeof (struct field) * nfields);
7059   TYPE_NAME (rtype) = ada_type_name (type);
7060   TYPE_TAG_NAME (rtype) = NULL;
7061   TYPE_FIXED_INSTANCE (rtype) = 1;
7062   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7063
7064   branch_type = to_fixed_variant_branch_type
7065     (TYPE_FIELD_TYPE (type, variant_field),
7066      cond_offset_host (valaddr,
7067                        TYPE_FIELD_BITPOS (type, variant_field)
7068                        / TARGET_CHAR_BIT),
7069      cond_offset_target (address,
7070                          TYPE_FIELD_BITPOS (type, variant_field)
7071                          / TARGET_CHAR_BIT), dval);
7072   if (branch_type == NULL)
7073     {
7074       int f;
7075       for (f = variant_field + 1; f < nfields; f += 1)
7076         TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7077       TYPE_NFIELDS (rtype) -= 1;
7078     }
7079   else
7080     {
7081       TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7082       TYPE_FIELD_NAME (rtype, variant_field) = "S";
7083       TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
7084       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
7085     }
7086   TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
7087
7088   value_free_to_mark (mark);
7089   return rtype;
7090 }
7091
7092 /* An ordinary record type (with fixed-length fields) that describes
7093    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7094    beginning of this section].   Any necessary discriminants' values
7095    should be in DVAL, a record value; it may be NULL if the object
7096    at ADDR itself contains any necessary discriminant values.
7097    Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7098    values from the record are needed.  Except in the case that DVAL,
7099    VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7100    unchecked) is replaced by a particular branch of the variant.
7101
7102    NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7103    is questionable and may be removed.  It can arise during the
7104    processing of an unconstrained-array-of-record type where all the
7105    variant branches have exactly the same size.  This is because in
7106    such cases, the compiler does not bother to use the XVS convention
7107    when encoding the record.  I am currently dubious of this
7108    shortcut and suspect the compiler should be altered.  FIXME.  */
7109
7110 static struct type *
7111 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
7112                       CORE_ADDR address, struct value *dval)
7113 {
7114   struct type *templ_type;
7115
7116   if (TYPE_FIXED_INSTANCE (type0))
7117     return type0;
7118
7119   templ_type = dynamic_template_type (type0);
7120
7121   if (templ_type != NULL)
7122     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
7123   else if (variant_field_index (type0) >= 0)
7124     {
7125       if (dval == NULL && valaddr == NULL && address == 0)
7126         return type0;
7127       return to_record_with_fixed_variant_part (type0, valaddr, address,
7128                                                 dval);
7129     }
7130   else
7131     {
7132       TYPE_FIXED_INSTANCE (type0) = 1;
7133       return type0;
7134     }
7135
7136 }
7137
7138 /* An ordinary record type (with fixed-length fields) that describes
7139    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7140    union type.  Any necessary discriminants' values should be in DVAL,
7141    a record value.  That is, this routine selects the appropriate
7142    branch of the union at ADDR according to the discriminant value
7143    indicated in the union's type name.  Returns VAR_TYPE0 itself if
7144    it represents a variant subject to a pragma Unchecked_Union. */
7145
7146 static struct type *
7147 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
7148                               CORE_ADDR address, struct value *dval)
7149 {
7150   int which;
7151   struct type *templ_type;
7152   struct type *var_type;
7153
7154   if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
7155     var_type = TYPE_TARGET_TYPE (var_type0);
7156   else
7157     var_type = var_type0;
7158
7159   templ_type = ada_find_parallel_type (var_type, "___XVU");
7160
7161   if (templ_type != NULL)
7162     var_type = templ_type;
7163
7164   if (is_unchecked_variant (var_type, value_type (dval)))
7165       return var_type0;
7166   which =
7167     ada_which_variant_applies (var_type,
7168                                value_type (dval), value_contents (dval));
7169
7170   if (which < 0)
7171     return empty_record (var_type);
7172   else if (is_dynamic_field (var_type, which))
7173     return to_fixed_record_type
7174       (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
7175        valaddr, address, dval);
7176   else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
7177     return
7178       to_fixed_record_type
7179       (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
7180   else
7181     return TYPE_FIELD_TYPE (var_type, which);
7182 }
7183
7184 /* Assuming that TYPE0 is an array type describing the type of a value
7185    at ADDR, and that DVAL describes a record containing any
7186    discriminants used in TYPE0, returns a type for the value that
7187    contains no dynamic components (that is, no components whose sizes
7188    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
7189    true, gives an error message if the resulting type's size is over
7190    varsize_limit.  */
7191
7192 static struct type *
7193 to_fixed_array_type (struct type *type0, struct value *dval,
7194                      int ignore_too_big)
7195 {
7196   struct type *index_type_desc;
7197   struct type *result;
7198   int constrained_packed_array_p;
7199
7200   if (TYPE_FIXED_INSTANCE (type0))
7201     return type0;
7202
7203   constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
7204   if (constrained_packed_array_p)
7205     type0 = decode_constrained_packed_array_type (type0);
7206
7207   index_type_desc = ada_find_parallel_type (type0, "___XA");
7208   ada_fixup_array_indexes_type (index_type_desc);
7209   if (index_type_desc == NULL)
7210     {
7211       struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
7212       /* NOTE: elt_type---the fixed version of elt_type0---should never
7213          depend on the contents of the array in properly constructed
7214          debugging data.  */
7215       /* Create a fixed version of the array element type.
7216          We're not providing the address of an element here,
7217          and thus the actual object value cannot be inspected to do
7218          the conversion.  This should not be a problem, since arrays of
7219          unconstrained objects are not allowed.  In particular, all
7220          the elements of an array of a tagged type should all be of
7221          the same type specified in the debugging info.  No need to
7222          consult the object tag.  */
7223       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
7224
7225       /* Make sure we always create a new array type when dealing with
7226          packed array types, since we're going to fix-up the array
7227          type length and element bitsize a little further down.  */
7228       if (elt_type0 == elt_type && !constrained_packed_array_p)
7229         result = type0;
7230       else
7231         result = create_array_type (alloc_type_copy (type0),
7232                                     elt_type, TYPE_INDEX_TYPE (type0));
7233     }
7234   else
7235     {
7236       int i;
7237       struct type *elt_type0;
7238
7239       elt_type0 = type0;
7240       for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
7241         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
7242
7243       /* NOTE: result---the fixed version of elt_type0---should never
7244          depend on the contents of the array in properly constructed
7245          debugging data.  */
7246       /* Create a fixed version of the array element type.
7247          We're not providing the address of an element here,
7248          and thus the actual object value cannot be inspected to do
7249          the conversion.  This should not be a problem, since arrays of
7250          unconstrained objects are not allowed.  In particular, all
7251          the elements of an array of a tagged type should all be of
7252          the same type specified in the debugging info.  No need to
7253          consult the object tag.  */
7254       result =
7255         ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
7256
7257       elt_type0 = type0;
7258       for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
7259         {
7260           struct type *range_type =
7261             to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
7262           result = create_array_type (alloc_type_copy (elt_type0),
7263                                       result, range_type);
7264           elt_type0 = TYPE_TARGET_TYPE (elt_type0);
7265         }
7266       if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
7267         error (_("array type with dynamic size is larger than varsize-limit"));
7268     }
7269
7270   if (constrained_packed_array_p)
7271     {
7272       /* So far, the resulting type has been created as if the original
7273          type was a regular (non-packed) array type.  As a result, the
7274          bitsize of the array elements needs to be set again, and the array
7275          length needs to be recomputed based on that bitsize.  */
7276       int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
7277       int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
7278
7279       TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
7280       TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
7281       if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
7282         TYPE_LENGTH (result)++;
7283     }
7284
7285   TYPE_FIXED_INSTANCE (result) = 1;
7286   return result;
7287 }
7288
7289
7290 /* A standard type (containing no dynamically sized components)
7291    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7292    DVAL describes a record containing any discriminants used in TYPE0,
7293    and may be NULL if there are none, or if the object of type TYPE at
7294    ADDRESS or in VALADDR contains these discriminants.
7295
7296    If CHECK_TAG is not null, in the case of tagged types, this function
7297    attempts to locate the object's tag and use it to compute the actual
7298    type.  However, when ADDRESS is null, we cannot use it to determine the
7299    location of the tag, and therefore compute the tagged type's actual type.
7300    So we return the tagged type without consulting the tag.  */
7301
7302 static struct type *
7303 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
7304                    CORE_ADDR address, struct value *dval, int check_tag)
7305 {
7306   type = ada_check_typedef (type);
7307   switch (TYPE_CODE (type))
7308     {
7309     default:
7310       return type;
7311     case TYPE_CODE_STRUCT:
7312       {
7313         struct type *static_type = to_static_fixed_type (type);
7314         struct type *fixed_record_type =
7315           to_fixed_record_type (type, valaddr, address, NULL);
7316         /* If STATIC_TYPE is a tagged type and we know the object's address,
7317            then we can determine its tag, and compute the object's actual
7318            type from there. Note that we have to use the fixed record
7319            type (the parent part of the record may have dynamic fields
7320            and the way the location of _tag is expressed may depend on
7321            them).  */
7322
7323         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
7324           {
7325             struct type *real_type =
7326               type_from_tag (value_tag_from_contents_and_address
7327                              (fixed_record_type,
7328                               valaddr,
7329                               address));
7330             if (real_type != NULL)
7331               return to_fixed_record_type (real_type, valaddr, address, NULL);
7332           }
7333
7334         /* Check to see if there is a parallel ___XVZ variable.
7335            If there is, then it provides the actual size of our type.  */
7336         else if (ada_type_name (fixed_record_type) != NULL)
7337           {
7338             char *name = ada_type_name (fixed_record_type);
7339             char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
7340             int xvz_found = 0;
7341             LONGEST size;
7342
7343             xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
7344             size = get_int_var_value (xvz_name, &xvz_found);
7345             if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
7346               {
7347                 fixed_record_type = copy_type (fixed_record_type);
7348                 TYPE_LENGTH (fixed_record_type) = size;
7349
7350                 /* The FIXED_RECORD_TYPE may have be a stub.  We have
7351                    observed this when the debugging info is STABS, and
7352                    apparently it is something that is hard to fix.
7353
7354                    In practice, we don't need the actual type definition
7355                    at all, because the presence of the XVZ variable allows us
7356                    to assume that there must be a XVS type as well, which we
7357                    should be able to use later, when we need the actual type
7358                    definition.
7359
7360                    In the meantime, pretend that the "fixed" type we are
7361                    returning is NOT a stub, because this can cause trouble
7362                    when using this type to create new types targeting it.
7363                    Indeed, the associated creation routines often check
7364                    whether the target type is a stub and will try to replace
7365                    it, thus using a type with the wrong size. This, in turn,
7366                    might cause the new type to have the wrong size too.
7367                    Consider the case of an array, for instance, where the size
7368                    of the array is computed from the number of elements in
7369                    our array multiplied by the size of its element.  */
7370                 TYPE_STUB (fixed_record_type) = 0;
7371               }
7372           }
7373         return fixed_record_type;
7374       }
7375     case TYPE_CODE_ARRAY:
7376       return to_fixed_array_type (type, dval, 1);
7377     case TYPE_CODE_UNION:
7378       if (dval == NULL)
7379         return type;
7380       else
7381         return to_fixed_variant_branch_type (type, valaddr, address, dval);
7382     }
7383 }
7384
7385 /* The same as ada_to_fixed_type_1, except that it preserves the type
7386    if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7387    ada_to_fixed_type_1 would return the type referenced by TYPE.  */
7388
7389 struct type *
7390 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
7391                    CORE_ADDR address, struct value *dval, int check_tag)
7392
7393 {
7394   struct type *fixed_type =
7395     ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
7396
7397   if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
7398       && TYPE_TARGET_TYPE (type) == fixed_type)
7399     return type;
7400
7401   return fixed_type;
7402 }
7403
7404 /* A standard (static-sized) type corresponding as well as possible to
7405    TYPE0, but based on no runtime data.  */
7406
7407 static struct type *
7408 to_static_fixed_type (struct type *type0)
7409 {
7410   struct type *type;
7411
7412   if (type0 == NULL)
7413     return NULL;
7414
7415   if (TYPE_FIXED_INSTANCE (type0))
7416     return type0;
7417
7418   type0 = ada_check_typedef (type0);
7419
7420   switch (TYPE_CODE (type0))
7421     {
7422     default:
7423       return type0;
7424     case TYPE_CODE_STRUCT:
7425       type = dynamic_template_type (type0);
7426       if (type != NULL)
7427         return template_to_static_fixed_type (type);
7428       else
7429         return template_to_static_fixed_type (type0);
7430     case TYPE_CODE_UNION:
7431       type = ada_find_parallel_type (type0, "___XVU");
7432       if (type != NULL)
7433         return template_to_static_fixed_type (type);
7434       else
7435         return template_to_static_fixed_type (type0);
7436     }
7437 }
7438
7439 /* A static approximation of TYPE with all type wrappers removed.  */
7440
7441 static struct type *
7442 static_unwrap_type (struct type *type)
7443 {
7444   if (ada_is_aligner_type (type))
7445     {
7446       struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
7447       if (ada_type_name (type1) == NULL)
7448         TYPE_NAME (type1) = ada_type_name (type);
7449
7450       return static_unwrap_type (type1);
7451     }
7452   else
7453     {
7454       struct type *raw_real_type = ada_get_base_type (type);
7455       if (raw_real_type == type)
7456         return type;
7457       else
7458         return to_static_fixed_type (raw_real_type);
7459     }
7460 }
7461
7462 /* In some cases, incomplete and private types require
7463    cross-references that are not resolved as records (for example,
7464       type Foo;
7465       type FooP is access Foo;
7466       V: FooP;
7467       type Foo is array ...;
7468    ).  In these cases, since there is no mechanism for producing
7469    cross-references to such types, we instead substitute for FooP a
7470    stub enumeration type that is nowhere resolved, and whose tag is
7471    the name of the actual type.  Call these types "non-record stubs".  */
7472
7473 /* A type equivalent to TYPE that is not a non-record stub, if one
7474    exists, otherwise TYPE.  */
7475
7476 struct type *
7477 ada_check_typedef (struct type *type)
7478 {
7479   if (type == NULL)
7480     return NULL;
7481
7482   CHECK_TYPEDEF (type);
7483   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
7484       || !TYPE_STUB (type)
7485       || TYPE_TAG_NAME (type) == NULL)
7486     return type;
7487   else
7488     {
7489       char *name = TYPE_TAG_NAME (type);
7490       struct type *type1 = ada_find_any_type (name);
7491       return (type1 == NULL) ? type : type1;
7492     }
7493 }
7494
7495 /* A value representing the data at VALADDR/ADDRESS as described by
7496    type TYPE0, but with a standard (static-sized) type that correctly
7497    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
7498    type, then return VAL0 [this feature is simply to avoid redundant
7499    creation of struct values].  */
7500
7501 static struct value *
7502 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
7503                            struct value *val0)
7504 {
7505   struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
7506   if (type == type0 && val0 != NULL)
7507     return val0;
7508   else
7509     return value_from_contents_and_address (type, 0, address);
7510 }
7511
7512 /* A value representing VAL, but with a standard (static-sized) type
7513    that correctly describes it.  Does not necessarily create a new
7514    value.  */
7515
7516 struct value *
7517 ada_to_fixed_value (struct value *val)
7518 {
7519   return ada_to_fixed_value_create (value_type (val),
7520                                     value_address (val),
7521                                     val);
7522 }
7523 \f
7524
7525 /* Attributes */
7526
7527 /* Table mapping attribute numbers to names.
7528    NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */
7529
7530 static const char *attribute_names[] = {
7531   "<?>",
7532
7533   "first",
7534   "last",
7535   "length",
7536   "image",
7537   "max",
7538   "min",
7539   "modulus",
7540   "pos",
7541   "size",
7542   "tag",
7543   "val",
7544   0
7545 };
7546
7547 const char *
7548 ada_attribute_name (enum exp_opcode n)
7549 {
7550   if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
7551     return attribute_names[n - OP_ATR_FIRST + 1];
7552   else
7553     return attribute_names[0];
7554 }
7555
7556 /* Evaluate the 'POS attribute applied to ARG.  */
7557
7558 static LONGEST
7559 pos_atr (struct value *arg)
7560 {
7561   struct value *val = coerce_ref (arg);
7562   struct type *type = value_type (val);
7563
7564   if (!discrete_type_p (type))
7565     error (_("'POS only defined on discrete types"));
7566
7567   if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7568     {
7569       int i;
7570       LONGEST v = value_as_long (val);
7571
7572       for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7573         {
7574           if (v == TYPE_FIELD_BITPOS (type, i))
7575             return i;
7576         }
7577       error (_("enumeration value is invalid: can't find 'POS"));
7578     }
7579   else
7580     return value_as_long (val);
7581 }
7582
7583 static struct value *
7584 value_pos_atr (struct type *type, struct value *arg)
7585 {
7586   return value_from_longest (type, pos_atr (arg));
7587 }
7588
7589 /* Evaluate the TYPE'VAL attribute applied to ARG.  */
7590
7591 static struct value *
7592 value_val_atr (struct type *type, struct value *arg)
7593 {
7594   if (!discrete_type_p (type))
7595     error (_("'VAL only defined on discrete types"));
7596   if (!integer_type_p (value_type (arg)))
7597     error (_("'VAL requires integral argument"));
7598
7599   if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7600     {
7601       long pos = value_as_long (arg);
7602       if (pos < 0 || pos >= TYPE_NFIELDS (type))
7603         error (_("argument to 'VAL out of range"));
7604       return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
7605     }
7606   else
7607     return value_from_longest (type, value_as_long (arg));
7608 }
7609 \f
7610
7611                                 /* Evaluation */
7612
7613 /* True if TYPE appears to be an Ada character type.
7614    [At the moment, this is true only for Character and Wide_Character;
7615    It is a heuristic test that could stand improvement].  */
7616
7617 int
7618 ada_is_character_type (struct type *type)
7619 {
7620   const char *name;
7621
7622   /* If the type code says it's a character, then assume it really is,
7623      and don't check any further.  */
7624   if (TYPE_CODE (type) == TYPE_CODE_CHAR)
7625     return 1;
7626
7627   /* Otherwise, assume it's a character type iff it is a discrete type
7628      with a known character type name.  */
7629   name = ada_type_name (type);
7630   return (name != NULL
7631           && (TYPE_CODE (type) == TYPE_CODE_INT
7632               || TYPE_CODE (type) == TYPE_CODE_RANGE)
7633           && (strcmp (name, "character") == 0
7634               || strcmp (name, "wide_character") == 0
7635               || strcmp (name, "wide_wide_character") == 0
7636               || strcmp (name, "unsigned char") == 0));
7637 }
7638
7639 /* True if TYPE appears to be an Ada string type.  */
7640
7641 int
7642 ada_is_string_type (struct type *type)
7643 {
7644   type = ada_check_typedef (type);
7645   if (type != NULL
7646       && TYPE_CODE (type) != TYPE_CODE_PTR
7647       && (ada_is_simple_array_type (type)
7648           || ada_is_array_descriptor_type (type))
7649       && ada_array_arity (type) == 1)
7650     {
7651       struct type *elttype = ada_array_element_type (type, 1);
7652
7653       return ada_is_character_type (elttype);
7654     }
7655   else
7656     return 0;
7657 }
7658
7659 /* The compiler sometimes provides a parallel XVS type for a given
7660    PAD type.  Normally, it is safe to follow the PAD type directly,
7661    but older versions of the compiler have a bug that causes the offset
7662    of its "F" field to be wrong.  Following that field in that case
7663    would lead to incorrect results, but this can be worked around
7664    by ignoring the PAD type and using the associated XVS type instead.
7665
7666    Set to True if the debugger should trust the contents of PAD types.
7667    Otherwise, ignore the PAD type if there is a parallel XVS type.  */
7668 static int trust_pad_over_xvs = 1;
7669
7670 /* True if TYPE is a struct type introduced by the compiler to force the
7671    alignment of a value.  Such types have a single field with a
7672    distinctive name.  */
7673
7674 int
7675 ada_is_aligner_type (struct type *type)
7676 {
7677   type = ada_check_typedef (type);
7678
7679   if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
7680     return 0;
7681
7682   return (TYPE_CODE (type) == TYPE_CODE_STRUCT
7683           && TYPE_NFIELDS (type) == 1
7684           && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
7685 }
7686
7687 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7688    the parallel type.  */
7689
7690 struct type *
7691 ada_get_base_type (struct type *raw_type)
7692 {
7693   struct type *real_type_namer;
7694   struct type *raw_real_type;
7695
7696   if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
7697     return raw_type;
7698
7699   if (ada_is_aligner_type (raw_type))
7700     /* The encoding specifies that we should always use the aligner type.
7701        So, even if this aligner type has an associated XVS type, we should
7702        simply ignore it.
7703
7704        According to the compiler gurus, an XVS type parallel to an aligner
7705        type may exist because of a stabs limitation.  In stabs, aligner
7706        types are empty because the field has a variable-sized type, and
7707        thus cannot actually be used as an aligner type.  As a result,
7708        we need the associated parallel XVS type to decode the type.
7709        Since the policy in the compiler is to not change the internal
7710        representation based on the debugging info format, we sometimes
7711        end up having a redundant XVS type parallel to the aligner type.  */
7712     return raw_type;
7713
7714   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
7715   if (real_type_namer == NULL
7716       || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
7717       || TYPE_NFIELDS (real_type_namer) != 1)
7718     return raw_type;
7719
7720   if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
7721     {
7722       /* This is an older encoding form where the base type needs to be
7723          looked up by name.  We prefer the newer enconding because it is
7724          more efficient.  */
7725       raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
7726       if (raw_real_type == NULL)
7727         return raw_type;
7728       else
7729         return raw_real_type;
7730     }
7731
7732   /* The field in our XVS type is a reference to the base type.  */
7733   return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
7734 }
7735
7736 /* The type of value designated by TYPE, with all aligners removed.  */
7737
7738 struct type *
7739 ada_aligned_type (struct type *type)
7740 {
7741   if (ada_is_aligner_type (type))
7742     return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
7743   else
7744     return ada_get_base_type (type);
7745 }
7746
7747
7748 /* The address of the aligned value in an object at address VALADDR
7749    having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */
7750
7751 const gdb_byte *
7752 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
7753 {
7754   if (ada_is_aligner_type (type))
7755     return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
7756                                    valaddr +
7757                                    TYPE_FIELD_BITPOS (type,
7758                                                       0) / TARGET_CHAR_BIT);
7759   else
7760     return valaddr;
7761 }
7762
7763
7764
7765 /* The printed representation of an enumeration literal with encoded
7766    name NAME.  The value is good to the next call of ada_enum_name.  */
7767 const char *
7768 ada_enum_name (const char *name)
7769 {
7770   static char *result;
7771   static size_t result_len = 0;
7772   char *tmp;
7773
7774   /* First, unqualify the enumeration name:
7775      1. Search for the last '.' character.  If we find one, then skip
7776      all the preceeding characters, the unqualified name starts
7777      right after that dot.
7778      2. Otherwise, we may be debugging on a target where the compiler
7779      translates dots into "__".  Search forward for double underscores,
7780      but stop searching when we hit an overloading suffix, which is
7781      of the form "__" followed by digits.  */
7782
7783   tmp = strrchr (name, '.');
7784   if (tmp != NULL)
7785     name = tmp + 1;
7786   else
7787     {
7788       while ((tmp = strstr (name, "__")) != NULL)
7789         {
7790           if (isdigit (tmp[2]))
7791             break;
7792           else
7793             name = tmp + 2;
7794         }
7795     }
7796
7797   if (name[0] == 'Q')
7798     {
7799       int v;
7800       if (name[1] == 'U' || name[1] == 'W')
7801         {
7802           if (sscanf (name + 2, "%x", &v) != 1)
7803             return name;
7804         }
7805       else
7806         return name;
7807
7808       GROW_VECT (result, result_len, 16);
7809       if (isascii (v) && isprint (v))
7810         xsnprintf (result, result_len, "'%c'", v);
7811       else if (name[1] == 'U')
7812         xsnprintf (result, result_len, "[\"%02x\"]", v);
7813       else
7814         xsnprintf (result, result_len, "[\"%04x\"]", v);
7815
7816       return result;
7817     }
7818   else
7819     {
7820       tmp = strstr (name, "__");
7821       if (tmp == NULL)
7822         tmp = strstr (name, "$");
7823       if (tmp != NULL)
7824         {
7825           GROW_VECT (result, result_len, tmp - name + 1);
7826           strncpy (result, name, tmp - name);
7827           result[tmp - name] = '\0';
7828           return result;
7829         }
7830
7831       return name;
7832     }
7833 }
7834
7835 /* Evaluate the subexpression of EXP starting at *POS as for
7836    evaluate_type, updating *POS to point just past the evaluated
7837    expression.  */
7838
7839 static struct value *
7840 evaluate_subexp_type (struct expression *exp, int *pos)
7841 {
7842   return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
7843 }
7844
7845 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7846    value it wraps.  */
7847
7848 static struct value *
7849 unwrap_value (struct value *val)
7850 {
7851   struct type *type = ada_check_typedef (value_type (val));
7852   if (ada_is_aligner_type (type))
7853     {
7854       struct value *v = ada_value_struct_elt (val, "F", 0);
7855       struct type *val_type = ada_check_typedef (value_type (v));
7856       if (ada_type_name (val_type) == NULL)
7857         TYPE_NAME (val_type) = ada_type_name (type);
7858
7859       return unwrap_value (v);
7860     }
7861   else
7862     {
7863       struct type *raw_real_type =
7864         ada_check_typedef (ada_get_base_type (type));
7865
7866       /* If there is no parallel XVS or XVE type, then the value is
7867          already unwrapped.  Return it without further modification.  */
7868       if ((type == raw_real_type)
7869           && ada_find_parallel_type (type, "___XVE") == NULL)
7870         return val;
7871
7872       return
7873         coerce_unspec_val_to_type
7874         (val, ada_to_fixed_type (raw_real_type, 0,
7875                                  value_address (val),
7876                                  NULL, 1));
7877     }
7878 }
7879
7880 static struct value *
7881 cast_to_fixed (struct type *type, struct value *arg)
7882 {
7883   LONGEST val;
7884
7885   if (type == value_type (arg))
7886     return arg;
7887   else if (ada_is_fixed_point_type (value_type (arg)))
7888     val = ada_float_to_fixed (type,
7889                               ada_fixed_to_float (value_type (arg),
7890                                                   value_as_long (arg)));
7891   else
7892     {
7893       DOUBLEST argd = value_as_double (arg);
7894       val = ada_float_to_fixed (type, argd);
7895     }
7896
7897   return value_from_longest (type, val);
7898 }
7899
7900 static struct value *
7901 cast_from_fixed (struct type *type, struct value *arg)
7902 {
7903   DOUBLEST val = ada_fixed_to_float (value_type (arg),
7904                                      value_as_long (arg));
7905   return value_from_double (type, val);
7906 }
7907
7908 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7909    return the converted value.  */
7910
7911 static struct value *
7912 coerce_for_assign (struct type *type, struct value *val)
7913 {
7914   struct type *type2 = value_type (val);
7915   if (type == type2)
7916     return val;
7917
7918   type2 = ada_check_typedef (type2);
7919   type = ada_check_typedef (type);
7920
7921   if (TYPE_CODE (type2) == TYPE_CODE_PTR
7922       && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7923     {
7924       val = ada_value_ind (val);
7925       type2 = value_type (val);
7926     }
7927
7928   if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
7929       && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7930     {
7931       if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
7932           || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
7933           != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
7934         error (_("Incompatible types in assignment"));
7935       deprecated_set_value_type (val, type);
7936     }
7937   return val;
7938 }
7939
7940 static struct value *
7941 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
7942 {
7943   struct value *val;
7944   struct type *type1, *type2;
7945   LONGEST v, v1, v2;
7946
7947   arg1 = coerce_ref (arg1);
7948   arg2 = coerce_ref (arg2);
7949   type1 = base_type (ada_check_typedef (value_type (arg1)));
7950   type2 = base_type (ada_check_typedef (value_type (arg2)));
7951
7952   if (TYPE_CODE (type1) != TYPE_CODE_INT
7953       || TYPE_CODE (type2) != TYPE_CODE_INT)
7954     return value_binop (arg1, arg2, op);
7955
7956   switch (op)
7957     {
7958     case BINOP_MOD:
7959     case BINOP_DIV:
7960     case BINOP_REM:
7961       break;
7962     default:
7963       return value_binop (arg1, arg2, op);
7964     }
7965
7966   v2 = value_as_long (arg2);
7967   if (v2 == 0)
7968     error (_("second operand of %s must not be zero."), op_string (op));
7969
7970   if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
7971     return value_binop (arg1, arg2, op);
7972
7973   v1 = value_as_long (arg1);
7974   switch (op)
7975     {
7976     case BINOP_DIV:
7977       v = v1 / v2;
7978       if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
7979         v += v > 0 ? -1 : 1;
7980       break;
7981     case BINOP_REM:
7982       v = v1 % v2;
7983       if (v * v1 < 0)
7984         v -= v2;
7985       break;
7986     default:
7987       /* Should not reach this point.  */
7988       v = 0;
7989     }
7990
7991   val = allocate_value (type1);
7992   store_unsigned_integer (value_contents_raw (val),
7993                           TYPE_LENGTH (value_type (val)),
7994                           gdbarch_byte_order (get_type_arch (type1)), v);
7995   return val;
7996 }
7997
7998 static int
7999 ada_value_equal (struct value *arg1, struct value *arg2)
8000 {
8001   if (ada_is_direct_array_type (value_type (arg1))
8002       || ada_is_direct_array_type (value_type (arg2)))
8003     {
8004       /* Automatically dereference any array reference before
8005          we attempt to perform the comparison.  */
8006       arg1 = ada_coerce_ref (arg1);
8007       arg2 = ada_coerce_ref (arg2);
8008
8009       arg1 = ada_coerce_to_simple_array (arg1);
8010       arg2 = ada_coerce_to_simple_array (arg2);
8011       if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
8012           || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
8013         error (_("Attempt to compare array with non-array"));
8014       /* FIXME: The following works only for types whose
8015          representations use all bits (no padding or undefined bits)
8016          and do not have user-defined equality.  */
8017       return
8018         TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
8019         && memcmp (value_contents (arg1), value_contents (arg2),
8020                    TYPE_LENGTH (value_type (arg1))) == 0;
8021     }
8022   return value_equal (arg1, arg2);
8023 }
8024
8025 /* Total number of component associations in the aggregate starting at
8026    index PC in EXP.  Assumes that index PC is the start of an
8027    OP_AGGREGATE. */
8028
8029 static int
8030 num_component_specs (struct expression *exp, int pc)
8031 {
8032   int n, m, i;
8033   m = exp->elts[pc + 1].longconst;
8034   pc += 3;
8035   n = 0;
8036   for (i = 0; i < m; i += 1)
8037     {
8038       switch (exp->elts[pc].opcode)
8039         {
8040         default:
8041           n += 1;
8042           break;
8043         case OP_CHOICES:
8044           n += exp->elts[pc + 1].longconst;
8045           break;
8046         }
8047       ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
8048     }
8049   return n;
8050 }
8051
8052 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
8053    component of LHS (a simple array or a record), updating *POS past
8054    the expression, assuming that LHS is contained in CONTAINER.  Does
8055    not modify the inferior's memory, nor does it modify LHS (unless
8056    LHS == CONTAINER).  */
8057
8058 static void
8059 assign_component (struct value *container, struct value *lhs, LONGEST index,
8060                   struct expression *exp, int *pos)
8061 {
8062   struct value *mark = value_mark ();
8063   struct value *elt;
8064   if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
8065     {
8066       struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
8067       struct value *index_val = value_from_longest (index_type, index);
8068       elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
8069     }
8070   else
8071     {
8072       elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
8073       elt = ada_to_fixed_value (unwrap_value (elt));
8074     }
8075
8076   if (exp->elts[*pos].opcode == OP_AGGREGATE)
8077     assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
8078   else
8079     value_assign_to_component (container, elt,
8080                                ada_evaluate_subexp (NULL, exp, pos,
8081                                                     EVAL_NORMAL));
8082
8083   value_free_to_mark (mark);
8084 }
8085
8086 /* Assuming that LHS represents an lvalue having a record or array
8087    type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8088    of that aggregate's value to LHS, advancing *POS past the
8089    aggregate.  NOSIDE is as for evaluate_subexp.  CONTAINER is an
8090    lvalue containing LHS (possibly LHS itself).  Does not modify
8091    the inferior's memory, nor does it modify the contents of
8092    LHS (unless == CONTAINER).  Returns the modified CONTAINER. */
8093
8094 static struct value *
8095 assign_aggregate (struct value *container,
8096                   struct value *lhs, struct expression *exp,
8097                   int *pos, enum noside noside)
8098 {
8099   struct type *lhs_type;
8100   int n = exp->elts[*pos+1].longconst;
8101   LONGEST low_index, high_index;
8102   int num_specs;
8103   LONGEST *indices;
8104   int max_indices, num_indices;
8105   int is_array_aggregate;
8106   int i;
8107
8108   *pos += 3;
8109   if (noside != EVAL_NORMAL)
8110     {
8111       int i;
8112       for (i = 0; i < n; i += 1)
8113         ada_evaluate_subexp (NULL, exp, pos, noside);
8114       return container;
8115     }
8116
8117   container = ada_coerce_ref (container);
8118   if (ada_is_direct_array_type (value_type (container)))
8119     container = ada_coerce_to_simple_array (container);
8120   lhs = ada_coerce_ref (lhs);
8121   if (!deprecated_value_modifiable (lhs))
8122     error (_("Left operand of assignment is not a modifiable lvalue."));
8123
8124   lhs_type = value_type (lhs);
8125   if (ada_is_direct_array_type (lhs_type))
8126     {
8127       lhs = ada_coerce_to_simple_array (lhs);
8128       lhs_type = value_type (lhs);
8129       low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
8130       high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
8131       is_array_aggregate = 1;
8132     }
8133   else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
8134     {
8135       low_index = 0;
8136       high_index = num_visible_fields (lhs_type) - 1;
8137       is_array_aggregate = 0;
8138     }
8139   else
8140     error (_("Left-hand side must be array or record."));
8141
8142   num_specs = num_component_specs (exp, *pos - 3);
8143   max_indices = 4 * num_specs + 4;
8144   indices = alloca (max_indices * sizeof (indices[0]));
8145   indices[0] = indices[1] = low_index - 1;
8146   indices[2] = indices[3] = high_index + 1;
8147   num_indices = 4;
8148
8149   for (i = 0; i < n; i += 1)
8150     {
8151       switch (exp->elts[*pos].opcode)
8152         {
8153         case OP_CHOICES:
8154           aggregate_assign_from_choices (container, lhs, exp, pos, indices,
8155                                          &num_indices, max_indices,
8156                                          low_index, high_index);
8157           break;
8158         case OP_POSITIONAL:
8159           aggregate_assign_positional (container, lhs, exp, pos, indices,
8160                                        &num_indices, max_indices,
8161                                        low_index, high_index);
8162           break;
8163         case OP_OTHERS:
8164           if (i != n-1)
8165             error (_("Misplaced 'others' clause"));
8166           aggregate_assign_others (container, lhs, exp, pos, indices,
8167                                    num_indices, low_index, high_index);
8168           break;
8169         default:
8170           error (_("Internal error: bad aggregate clause"));
8171         }
8172     }
8173
8174   return container;
8175 }
8176
8177 /* Assign into the component of LHS indexed by the OP_POSITIONAL
8178    construct at *POS, updating *POS past the construct, given that
8179    the positions are relative to lower bound LOW, where HIGH is the
8180    upper bound.  Record the position in INDICES[0 .. MAX_INDICES-1]
8181    updating *NUM_INDICES as needed.  CONTAINER is as for
8182    assign_aggregate. */
8183 static void
8184 aggregate_assign_positional (struct value *container,
8185                              struct value *lhs, struct expression *exp,
8186                              int *pos, LONGEST *indices, int *num_indices,
8187                              int max_indices, LONGEST low, LONGEST high)
8188 {
8189   LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
8190
8191   if (ind - 1 == high)
8192     warning (_("Extra components in aggregate ignored."));
8193   if (ind <= high)
8194     {
8195       add_component_interval (ind, ind, indices, num_indices, max_indices);
8196       *pos += 3;
8197       assign_component (container, lhs, ind, exp, pos);
8198     }
8199   else
8200     ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8201 }
8202
8203 /* Assign into the components of LHS indexed by the OP_CHOICES
8204    construct at *POS, updating *POS past the construct, given that
8205    the allowable indices are LOW..HIGH.  Record the indices assigned
8206    to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8207    needed.  CONTAINER is as for assign_aggregate. */
8208 static void
8209 aggregate_assign_from_choices (struct value *container,
8210                                struct value *lhs, struct expression *exp,
8211                                int *pos, LONGEST *indices, int *num_indices,
8212                                int max_indices, LONGEST low, LONGEST high)
8213 {
8214   int j;
8215   int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
8216   int choice_pos, expr_pc;
8217   int is_array = ada_is_direct_array_type (value_type (lhs));
8218
8219   choice_pos = *pos += 3;
8220
8221   for (j = 0; j < n_choices; j += 1)
8222     ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8223   expr_pc = *pos;
8224   ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8225
8226   for (j = 0; j < n_choices; j += 1)
8227     {
8228       LONGEST lower, upper;
8229       enum exp_opcode op = exp->elts[choice_pos].opcode;
8230       if (op == OP_DISCRETE_RANGE)
8231         {
8232           choice_pos += 1;
8233           lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8234                                                       EVAL_NORMAL));
8235           upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8236                                                       EVAL_NORMAL));
8237         }
8238       else if (is_array)
8239         {
8240           lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
8241                                                       EVAL_NORMAL));
8242           upper = lower;
8243         }
8244       else
8245         {
8246           int ind;
8247           char *name;
8248           switch (op)
8249             {
8250             case OP_NAME:
8251               name = &exp->elts[choice_pos + 2].string;
8252               break;
8253             case OP_VAR_VALUE:
8254               name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
8255               break;
8256             default:
8257               error (_("Invalid record component association."));
8258             }
8259           ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
8260           ind = 0;
8261           if (! find_struct_field (name, value_type (lhs), 0,
8262                                    NULL, NULL, NULL, NULL, &ind))
8263             error (_("Unknown component name: %s."), name);
8264           lower = upper = ind;
8265         }
8266
8267       if (lower <= upper && (lower < low || upper > high))
8268         error (_("Index in component association out of bounds."));
8269
8270       add_component_interval (lower, upper, indices, num_indices,
8271                               max_indices);
8272       while (lower <= upper)
8273         {
8274           int pos1;
8275           pos1 = expr_pc;
8276           assign_component (container, lhs, lower, exp, &pos1);
8277           lower += 1;
8278         }
8279     }
8280 }
8281
8282 /* Assign the value of the expression in the OP_OTHERS construct in
8283    EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8284    have not been previously assigned.  The index intervals already assigned
8285    are in INDICES[0 .. NUM_INDICES-1].  Updates *POS to after the
8286    OP_OTHERS clause.  CONTAINER is as for assign_aggregate*/
8287 static void
8288 aggregate_assign_others (struct value *container,
8289                          struct value *lhs, struct expression *exp,
8290                          int *pos, LONGEST *indices, int num_indices,
8291                          LONGEST low, LONGEST high)
8292 {
8293   int i;
8294   int expr_pc = *pos+1;
8295
8296   for (i = 0; i < num_indices - 2; i += 2)
8297     {
8298       LONGEST ind;
8299       for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
8300         {
8301           int pos;
8302           pos = expr_pc;
8303           assign_component (container, lhs, ind, exp, &pos);
8304         }
8305     }
8306   ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8307 }
8308
8309 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
8310    [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8311    modifying *SIZE as needed.  It is an error if *SIZE exceeds
8312    MAX_SIZE.  The resulting intervals do not overlap.  */
8313 static void
8314 add_component_interval (LONGEST low, LONGEST high,
8315                         LONGEST* indices, int *size, int max_size)
8316 {
8317   int i, j;
8318   for (i = 0; i < *size; i += 2) {
8319     if (high >= indices[i] && low <= indices[i + 1])
8320       {
8321         int kh;
8322         for (kh = i + 2; kh < *size; kh += 2)
8323           if (high < indices[kh])
8324             break;
8325         if (low < indices[i])
8326           indices[i] = low;
8327         indices[i + 1] = indices[kh - 1];
8328         if (high > indices[i + 1])
8329           indices[i + 1] = high;
8330         memcpy (indices + i + 2, indices + kh, *size - kh);
8331         *size -= kh - i - 2;
8332         return;
8333       }
8334     else if (high < indices[i])
8335       break;
8336   }
8337
8338   if (*size == max_size)
8339     error (_("Internal error: miscounted aggregate components."));
8340   *size += 2;
8341   for (j = *size-1; j >= i+2; j -= 1)
8342     indices[j] = indices[j - 2];
8343   indices[i] = low;
8344   indices[i + 1] = high;
8345 }
8346
8347 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8348    is different.  */
8349
8350 static struct value *
8351 ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
8352 {
8353   if (type == ada_check_typedef (value_type (arg2)))
8354     return arg2;
8355
8356   if (ada_is_fixed_point_type (type))
8357     return (cast_to_fixed (type, arg2));
8358
8359   if (ada_is_fixed_point_type (value_type (arg2)))
8360     return cast_from_fixed (type, arg2);
8361
8362   return value_cast (type, arg2);
8363 }
8364
8365 /*  Evaluating Ada expressions, and printing their result.
8366     ------------------------------------------------------
8367
8368     1. Introduction:
8369     ----------------
8370
8371     We usually evaluate an Ada expression in order to print its value.
8372     We also evaluate an expression in order to print its type, which
8373     happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
8374     but we'll focus mostly on the EVAL_NORMAL phase.  In practice, the
8375     EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
8376     the evaluation compared to the EVAL_NORMAL, but is otherwise very
8377     similar.
8378
8379     Evaluating expressions is a little more complicated for Ada entities
8380     than it is for entities in languages such as C.  The main reason for
8381     this is that Ada provides types whose definition might be dynamic.
8382     One example of such types is variant records.  Or another example
8383     would be an array whose bounds can only be known at run time.
8384
8385     The following description is a general guide as to what should be
8386     done (and what should NOT be done) in order to evaluate an expression
8387     involving such types, and when.  This does not cover how the semantic
8388     information is encoded by GNAT as this is covered separatly.  For the
8389     document used as the reference for the GNAT encoding, see exp_dbug.ads
8390     in the GNAT sources.
8391
8392     Ideally, we should embed each part of this description next to its
8393     associated code.  Unfortunately, the amount of code is so vast right
8394     now that it's hard to see whether the code handling a particular
8395     situation might be duplicated or not.  One day, when the code is
8396     cleaned up, this guide might become redundant with the comments
8397     inserted in the code, and we might want to remove it.
8398
8399     2. ``Fixing'' an Entity, the Simple Case:
8400     -----------------------------------------
8401
8402     When evaluating Ada expressions, the tricky issue is that they may
8403     reference entities whose type contents and size are not statically
8404     known.  Consider for instance a variant record:
8405
8406        type Rec (Empty : Boolean := True) is record
8407           case Empty is
8408              when True => null;
8409              when False => Value : Integer;
8410           end case;
8411        end record;
8412        Yes : Rec := (Empty => False, Value => 1);
8413        No  : Rec := (empty => True);
8414
8415     The size and contents of that record depends on the value of the
8416     descriminant (Rec.Empty).  At this point, neither the debugging
8417     information nor the associated type structure in GDB are able to
8418     express such dynamic types.  So what the debugger does is to create
8419     "fixed" versions of the type that applies to the specific object.
8420     We also informally refer to this opperation as "fixing" an object,
8421     which means creating its associated fixed type.
8422
8423     Example: when printing the value of variable "Yes" above, its fixed
8424     type would look like this:
8425
8426        type Rec is record
8427           Empty : Boolean;
8428           Value : Integer;
8429        end record;
8430
8431     On the other hand, if we printed the value of "No", its fixed type
8432     would become:
8433
8434        type Rec is record
8435           Empty : Boolean;
8436        end record;
8437
8438     Things become a little more complicated when trying to fix an entity
8439     with a dynamic type that directly contains another dynamic type,
8440     such as an array of variant records, for instance.  There are
8441     two possible cases: Arrays, and records.
8442
8443     3. ``Fixing'' Arrays:
8444     ---------------------
8445
8446     The type structure in GDB describes an array in terms of its bounds,
8447     and the type of its elements.  By design, all elements in the array
8448     have the same type and we cannot represent an array of variant elements
8449     using the current type structure in GDB.  When fixing an array,
8450     we cannot fix the array element, as we would potentially need one
8451     fixed type per element of the array.  As a result, the best we can do
8452     when fixing an array is to produce an array whose bounds and size
8453     are correct (allowing us to read it from memory), but without having
8454     touched its element type.  Fixing each element will be done later,
8455     when (if) necessary.
8456
8457     Arrays are a little simpler to handle than records, because the same
8458     amount of memory is allocated for each element of the array, even if
8459     the amount of space actually used by each element differs from element
8460     to element.  Consider for instance the following array of type Rec:
8461
8462        type Rec_Array is array (1 .. 2) of Rec;
8463
8464     The actual amount of memory occupied by each element might be different
8465     from element to element, depending on the value of their discriminant.
8466     But the amount of space reserved for each element in the array remains
8467     fixed regardless.  So we simply need to compute that size using
8468     the debugging information available, from which we can then determine
8469     the array size (we multiply the number of elements of the array by
8470     the size of each element).
8471
8472     The simplest case is when we have an array of a constrained element
8473     type. For instance, consider the following type declarations:
8474
8475         type Bounded_String (Max_Size : Integer) is
8476            Length : Integer;
8477            Buffer : String (1 .. Max_Size);
8478         end record;
8479         type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
8480
8481     In this case, the compiler describes the array as an array of
8482     variable-size elements (identified by its XVS suffix) for which
8483     the size can be read in the parallel XVZ variable.
8484
8485     In the case of an array of an unconstrained element type, the compiler
8486     wraps the array element inside a private PAD type.  This type should not
8487     be shown to the user, and must be "unwrap"'ed before printing.  Note
8488     that we also use the adjective "aligner" in our code to designate
8489     these wrapper types.
8490
8491     In some cases, the size allocated for each element is statically
8492     known.  In that case, the PAD type already has the correct size,
8493     and the array element should remain unfixed.
8494
8495     But there are cases when this size is not statically known.
8496     For instance, assuming that "Five" is an integer variable:
8497
8498         type Dynamic is array (1 .. Five) of Integer;
8499         type Wrapper (Has_Length : Boolean := False) is record
8500            Data : Dynamic;
8501            case Has_Length is
8502               when True => Length : Integer;
8503               when False => null;
8504            end case;
8505         end record;
8506         type Wrapper_Array is array (1 .. 2) of Wrapper;
8507
8508         Hello : Wrapper_Array := (others => (Has_Length => True,
8509                                              Data => (others => 17),
8510                                              Length => 1));
8511
8512
8513     The debugging info would describe variable Hello as being an
8514     array of a PAD type.  The size of that PAD type is not statically
8515     known, but can be determined using a parallel XVZ variable.
8516     In that case, a copy of the PAD type with the correct size should
8517     be used for the fixed array.
8518
8519     3. ``Fixing'' record type objects:
8520     ----------------------------------
8521
8522     Things are slightly different from arrays in the case of dynamic
8523     record types.  In this case, in order to compute the associated
8524     fixed type, we need to determine the size and offset of each of
8525     its components.  This, in turn, requires us to compute the fixed
8526     type of each of these components.
8527
8528     Consider for instance the example:
8529
8530         type Bounded_String (Max_Size : Natural) is record
8531            Str : String (1 .. Max_Size);
8532            Length : Natural;
8533         end record;
8534         My_String : Bounded_String (Max_Size => 10);
8535
8536     In that case, the position of field "Length" depends on the size
8537     of field Str, which itself depends on the value of the Max_Size
8538     discriminant.  In order to fix the type of variable My_String,
8539     we need to fix the type of field Str.  Therefore, fixing a variant
8540     record requires us to fix each of its components.
8541
8542     However, if a component does not have a dynamic size, the component
8543     should not be fixed.  In particular, fields that use a PAD type
8544     should not fixed.  Here is an example where this might happen
8545     (assuming type Rec above):
8546
8547        type Container (Big : Boolean) is record
8548           First : Rec;
8549           After : Integer;
8550           case Big is
8551              when True => Another : Integer;
8552              when False => null;
8553           end case;
8554        end record;
8555        My_Container : Container := (Big => False,
8556                                     First => (Empty => True),
8557                                     After => 42);
8558
8559     In that example, the compiler creates a PAD type for component First,
8560     whose size is constant, and then positions the component After just
8561     right after it.  The offset of component After is therefore constant
8562     in this case.
8563
8564     The debugger computes the position of each field based on an algorithm
8565     that uses, among other things, the actual position and size of the field
8566     preceding it.  Let's now imagine that the user is trying to print
8567     the value of My_Container.  If the type fixing was recursive, we would
8568     end up computing the offset of field After based on the size of the
8569     fixed version of field First.  And since in our example First has
8570     only one actual field, the size of the fixed type is actually smaller
8571     than the amount of space allocated to that field, and thus we would
8572     compute the wrong offset of field After.
8573
8574     To make things more complicated, we need to watch out for dynamic
8575     components of variant records (identified by the ___XVL suffix in
8576     the component name).  Even if the target type is a PAD type, the size
8577     of that type might not be statically known.  So the PAD type needs
8578     to be unwrapped and the resulting type needs to be fixed.  Otherwise,
8579     we might end up with the wrong size for our component.  This can be
8580     observed with the following type declarations:
8581
8582         type Octal is new Integer range 0 .. 7;
8583         type Octal_Array is array (Positive range <>) of Octal;
8584         pragma Pack (Octal_Array);
8585
8586         type Octal_Buffer (Size : Positive) is record
8587            Buffer : Octal_Array (1 .. Size);
8588            Length : Integer;
8589         end record;
8590
8591     In that case, Buffer is a PAD type whose size is unset and needs
8592     to be computed by fixing the unwrapped type.
8593
8594     4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
8595     ----------------------------------------------------------
8596
8597     Lastly, when should the sub-elements of an entity that remained unfixed
8598     thus far, be actually fixed?
8599
8600     The answer is: Only when referencing that element.  For instance
8601     when selecting one component of a record, this specific component
8602     should be fixed at that point in time.  Or when printing the value
8603     of a record, each component should be fixed before its value gets
8604     printed.  Similarly for arrays, the element of the array should be
8605     fixed when printing each element of the array, or when extracting
8606     one element out of that array.  On the other hand, fixing should
8607     not be performed on the elements when taking a slice of an array!
8608
8609     Note that one of the side-effects of miscomputing the offset and
8610     size of each field is that we end up also miscomputing the size
8611     of the containing type.  This can have adverse results when computing
8612     the value of an entity.  GDB fetches the value of an entity based
8613     on the size of its type, and thus a wrong size causes GDB to fetch
8614     the wrong amount of memory.  In the case where the computed size is
8615     too small, GDB fetches too little data to print the value of our
8616     entiry.  Results in this case as unpredicatble, as we usually read
8617     past the buffer containing the data =:-o.  */
8618
8619 /* Implement the evaluate_exp routine in the exp_descriptor structure
8620    for the Ada language.  */
8621
8622 static struct value *
8623 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
8624                      int *pos, enum noside noside)
8625 {
8626   enum exp_opcode op;
8627   int tem;
8628   int pc;
8629   struct value *arg1 = NULL, *arg2 = NULL, *arg3;
8630   struct type *type;
8631   int nargs, oplen;
8632   struct value **argvec;
8633
8634   pc = *pos;
8635   *pos += 1;
8636   op = exp->elts[pc].opcode;
8637
8638   switch (op)
8639     {
8640     default:
8641       *pos -= 1;
8642       arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
8643       arg1 = unwrap_value (arg1);
8644
8645       /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8646          then we need to perform the conversion manually, because
8647          evaluate_subexp_standard doesn't do it.  This conversion is
8648          necessary in Ada because the different kinds of float/fixed
8649          types in Ada have different representations.
8650
8651          Similarly, we need to perform the conversion from OP_LONG
8652          ourselves.  */
8653       if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
8654         arg1 = ada_value_cast (expect_type, arg1, noside);
8655
8656       return arg1;
8657
8658     case OP_STRING:
8659       {
8660         struct value *result;
8661         *pos -= 1;
8662         result = evaluate_subexp_standard (expect_type, exp, pos, noside);
8663         /* The result type will have code OP_STRING, bashed there from
8664            OP_ARRAY.  Bash it back.  */
8665         if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
8666           TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
8667         return result;
8668       }
8669
8670     case UNOP_CAST:
8671       (*pos) += 2;
8672       type = exp->elts[pc + 1].type;
8673       arg1 = evaluate_subexp (type, exp, pos, noside);
8674       if (noside == EVAL_SKIP)
8675         goto nosideret;
8676       arg1 = ada_value_cast (type, arg1, noside);
8677       return arg1;
8678
8679     case UNOP_QUAL:
8680       (*pos) += 2;
8681       type = exp->elts[pc + 1].type;
8682       return ada_evaluate_subexp (type, exp, pos, noside);
8683
8684     case BINOP_ASSIGN:
8685       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8686       if (exp->elts[*pos].opcode == OP_AGGREGATE)
8687         {
8688           arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
8689           if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
8690             return arg1;
8691           return ada_value_assign (arg1, arg1);
8692         }
8693       /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
8694          except if the lhs of our assignment is a convenience variable.
8695          In the case of assigning to a convenience variable, the lhs
8696          should be exactly the result of the evaluation of the rhs.  */
8697       type = value_type (arg1);
8698       if (VALUE_LVAL (arg1) == lval_internalvar)
8699          type = NULL;
8700       arg2 = evaluate_subexp (type, exp, pos, noside);
8701       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
8702         return arg1;
8703       if (ada_is_fixed_point_type (value_type (arg1)))
8704         arg2 = cast_to_fixed (value_type (arg1), arg2);
8705       else if (ada_is_fixed_point_type (value_type (arg2)))
8706         error
8707           (_("Fixed-point values must be assigned to fixed-point variables"));
8708       else
8709         arg2 = coerce_for_assign (value_type (arg1), arg2);
8710       return ada_value_assign (arg1, arg2);
8711
8712     case BINOP_ADD:
8713       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8714       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8715       if (noside == EVAL_SKIP)
8716         goto nosideret;
8717       if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
8718         return (value_from_longest
8719                  (value_type (arg1),
8720                   value_as_long (arg1) + value_as_long (arg2)));
8721       if ((ada_is_fixed_point_type (value_type (arg1))
8722            || ada_is_fixed_point_type (value_type (arg2)))
8723           && value_type (arg1) != value_type (arg2))
8724         error (_("Operands of fixed-point addition must have the same type"));
8725       /* Do the addition, and cast the result to the type of the first
8726          argument.  We cannot cast the result to a reference type, so if
8727          ARG1 is a reference type, find its underlying type.  */
8728       type = value_type (arg1);
8729       while (TYPE_CODE (type) == TYPE_CODE_REF)
8730         type = TYPE_TARGET_TYPE (type);
8731       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8732       return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
8733
8734     case BINOP_SUB:
8735       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8736       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8737       if (noside == EVAL_SKIP)
8738         goto nosideret;
8739       if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
8740         return (value_from_longest
8741                  (value_type (arg1),
8742                   value_as_long (arg1) - value_as_long (arg2)));
8743       if ((ada_is_fixed_point_type (value_type (arg1))
8744            || ada_is_fixed_point_type (value_type (arg2)))
8745           && value_type (arg1) != value_type (arg2))
8746         error (_("Operands of fixed-point subtraction must have the same type"));
8747       /* Do the substraction, and cast the result to the type of the first
8748          argument.  We cannot cast the result to a reference type, so if
8749          ARG1 is a reference type, find its underlying type.  */
8750       type = value_type (arg1);
8751       while (TYPE_CODE (type) == TYPE_CODE_REF)
8752         type = TYPE_TARGET_TYPE (type);
8753       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8754       return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
8755
8756     case BINOP_MUL:
8757     case BINOP_DIV:
8758     case BINOP_REM:
8759     case BINOP_MOD:
8760       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8761       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8762       if (noside == EVAL_SKIP)
8763         goto nosideret;
8764       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8765         {
8766           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8767           return value_zero (value_type (arg1), not_lval);
8768         }
8769       else
8770         {
8771           type = builtin_type (exp->gdbarch)->builtin_double;
8772           if (ada_is_fixed_point_type (value_type (arg1)))
8773             arg1 = cast_from_fixed (type, arg1);
8774           if (ada_is_fixed_point_type (value_type (arg2)))
8775             arg2 = cast_from_fixed (type, arg2);
8776           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8777           return ada_value_binop (arg1, arg2, op);
8778         }
8779
8780     case BINOP_EQUAL:
8781     case BINOP_NOTEQUAL:
8782       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8783       arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
8784       if (noside == EVAL_SKIP)
8785         goto nosideret;
8786       if (noside == EVAL_AVOID_SIDE_EFFECTS)
8787         tem = 0;
8788       else
8789         {
8790           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8791           tem = ada_value_equal (arg1, arg2);
8792         }
8793       if (op == BINOP_NOTEQUAL)
8794         tem = !tem;
8795       type = language_bool_type (exp->language_defn, exp->gdbarch);
8796       return value_from_longest (type, (LONGEST) tem);
8797
8798     case UNOP_NEG:
8799       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8800       if (noside == EVAL_SKIP)
8801         goto nosideret;
8802       else if (ada_is_fixed_point_type (value_type (arg1)))
8803         return value_cast (value_type (arg1), value_neg (arg1));
8804       else
8805         {
8806           unop_promote (exp->language_defn, exp->gdbarch, &arg1);
8807           return value_neg (arg1);
8808         }
8809
8810     case BINOP_LOGICAL_AND:
8811     case BINOP_LOGICAL_OR:
8812     case UNOP_LOGICAL_NOT:
8813       {
8814         struct value *val;
8815
8816         *pos -= 1;
8817         val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8818         type = language_bool_type (exp->language_defn, exp->gdbarch);
8819         return value_cast (type, val);
8820       }
8821
8822     case BINOP_BITWISE_AND:
8823     case BINOP_BITWISE_IOR:
8824     case BINOP_BITWISE_XOR:
8825       {
8826         struct value *val;
8827
8828         arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
8829         *pos = pc;
8830         val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8831
8832         return value_cast (value_type (arg1), val);
8833       }
8834
8835     case OP_VAR_VALUE:
8836       *pos -= 1;
8837
8838       if (noside == EVAL_SKIP)
8839         {
8840           *pos += 4;
8841           goto nosideret;
8842         }
8843       else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
8844         /* Only encountered when an unresolved symbol occurs in a
8845            context other than a function call, in which case, it is
8846            invalid.  */
8847         error (_("Unexpected unresolved symbol, %s, during evaluation"),
8848                SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
8849       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8850         {
8851           type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
8852           /* Check to see if this is a tagged type.  We also need to handle
8853              the case where the type is a reference to a tagged type, but
8854              we have to be careful to exclude pointers to tagged types.
8855              The latter should be shown as usual (as a pointer), whereas
8856              a reference should mostly be transparent to the user.  */
8857           if (ada_is_tagged_type (type, 0)
8858               || (TYPE_CODE(type) == TYPE_CODE_REF
8859                   && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
8860           {
8861             /* Tagged types are a little special in the fact that the real
8862                type is dynamic and can only be determined by inspecting the
8863                object's tag.  This means that we need to get the object's
8864                value first (EVAL_NORMAL) and then extract the actual object
8865                type from its tag.
8866
8867                Note that we cannot skip the final step where we extract
8868                the object type from its tag, because the EVAL_NORMAL phase
8869                results in dynamic components being resolved into fixed ones.
8870                This can cause problems when trying to print the type
8871                description of tagged types whose parent has a dynamic size:
8872                We use the type name of the "_parent" component in order
8873                to print the name of the ancestor type in the type description.
8874                If that component had a dynamic size, the resolution into
8875                a fixed type would result in the loss of that type name,
8876                thus preventing us from printing the name of the ancestor
8877                type in the type description.  */
8878             struct type *actual_type;
8879
8880             arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
8881             actual_type = type_from_tag (ada_value_tag (arg1));
8882             if (actual_type == NULL)
8883               /* If, for some reason, we were unable to determine
8884                  the actual type from the tag, then use the static
8885                  approximation that we just computed as a fallback.
8886                  This can happen if the debugging information is
8887                  incomplete, for instance.  */
8888               actual_type = type;
8889
8890             return value_zero (actual_type, not_lval);
8891           }
8892
8893           *pos += 4;
8894           return value_zero
8895             (to_static_fixed_type
8896              (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
8897              not_lval);
8898         }
8899       else
8900         {
8901           arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
8902           arg1 = unwrap_value (arg1);
8903           return ada_to_fixed_value (arg1);
8904         }
8905
8906     case OP_FUNCALL:
8907       (*pos) += 2;
8908
8909       /* Allocate arg vector, including space for the function to be
8910          called in argvec[0] and a terminating NULL.  */
8911       nargs = longest_to_int (exp->elts[pc + 1].longconst);
8912       argvec =
8913         (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
8914
8915       if (exp->elts[*pos].opcode == OP_VAR_VALUE
8916           && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
8917         error (_("Unexpected unresolved symbol, %s, during evaluation"),
8918                SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
8919       else
8920         {
8921           for (tem = 0; tem <= nargs; tem += 1)
8922             argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8923           argvec[tem] = 0;
8924
8925           if (noside == EVAL_SKIP)
8926             goto nosideret;
8927         }
8928
8929       if (ada_is_constrained_packed_array_type
8930           (desc_base_type (value_type (argvec[0]))))
8931         argvec[0] = ada_coerce_to_simple_array (argvec[0]);
8932       else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
8933                && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
8934         /* This is a packed array that has already been fixed, and
8935            therefore already coerced to a simple array.  Nothing further
8936            to do.  */
8937         ;
8938       else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
8939                || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
8940                    && VALUE_LVAL (argvec[0]) == lval_memory))
8941         argvec[0] = value_addr (argvec[0]);
8942
8943       type = ada_check_typedef (value_type (argvec[0]));
8944       if (TYPE_CODE (type) == TYPE_CODE_PTR)
8945         {
8946           switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
8947             {
8948             case TYPE_CODE_FUNC:
8949               type = ada_check_typedef (TYPE_TARGET_TYPE (type));
8950               break;
8951             case TYPE_CODE_ARRAY:
8952               break;
8953             case TYPE_CODE_STRUCT:
8954               if (noside != EVAL_AVOID_SIDE_EFFECTS)
8955                 argvec[0] = ada_value_ind (argvec[0]);
8956               type = ada_check_typedef (TYPE_TARGET_TYPE (type));
8957               break;
8958             default:
8959               error (_("cannot subscript or call something of type `%s'"),
8960                      ada_type_name (value_type (argvec[0])));
8961               break;
8962             }
8963         }
8964
8965       switch (TYPE_CODE (type))
8966         {
8967         case TYPE_CODE_FUNC:
8968           if (noside == EVAL_AVOID_SIDE_EFFECTS)
8969             return allocate_value (TYPE_TARGET_TYPE (type));
8970           return call_function_by_hand (argvec[0], nargs, argvec + 1);
8971         case TYPE_CODE_STRUCT:
8972           {
8973             int arity;
8974
8975             arity = ada_array_arity (type);
8976             type = ada_array_element_type (type, nargs);
8977             if (type == NULL)
8978               error (_("cannot subscript or call a record"));
8979             if (arity != nargs)
8980               error (_("wrong number of subscripts; expecting %d"), arity);
8981             if (noside == EVAL_AVOID_SIDE_EFFECTS)
8982               return value_zero (ada_aligned_type (type), lval_memory);
8983             return
8984               unwrap_value (ada_value_subscript
8985                             (argvec[0], nargs, argvec + 1));
8986           }
8987         case TYPE_CODE_ARRAY:
8988           if (noside == EVAL_AVOID_SIDE_EFFECTS)
8989             {
8990               type = ada_array_element_type (type, nargs);
8991               if (type == NULL)
8992                 error (_("element type of array unknown"));
8993               else
8994                 return value_zero (ada_aligned_type (type), lval_memory);
8995             }
8996           return
8997             unwrap_value (ada_value_subscript
8998                           (ada_coerce_to_simple_array (argvec[0]),
8999                            nargs, argvec + 1));
9000         case TYPE_CODE_PTR:     /* Pointer to array */
9001           type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
9002           if (noside == EVAL_AVOID_SIDE_EFFECTS)
9003             {
9004               type = ada_array_element_type (type, nargs);
9005               if (type == NULL)
9006                 error (_("element type of array unknown"));
9007               else
9008                 return value_zero (ada_aligned_type (type), lval_memory);
9009             }
9010           return
9011             unwrap_value (ada_value_ptr_subscript (argvec[0], type,
9012                                                    nargs, argvec + 1));
9013
9014         default:
9015           error (_("Attempt to index or call something other than an "
9016                    "array or function"));
9017         }
9018
9019     case TERNOP_SLICE:
9020       {
9021         struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9022         struct value *low_bound_val =
9023           evaluate_subexp (NULL_TYPE, exp, pos, noside);
9024         struct value *high_bound_val =
9025           evaluate_subexp (NULL_TYPE, exp, pos, noside);
9026         LONGEST low_bound;
9027         LONGEST high_bound;
9028         low_bound_val = coerce_ref (low_bound_val);
9029         high_bound_val = coerce_ref (high_bound_val);
9030         low_bound = pos_atr (low_bound_val);
9031         high_bound = pos_atr (high_bound_val);
9032
9033         if (noside == EVAL_SKIP)
9034           goto nosideret;
9035
9036         /* If this is a reference to an aligner type, then remove all
9037            the aligners.  */
9038         if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
9039             && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
9040           TYPE_TARGET_TYPE (value_type (array)) =
9041             ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
9042
9043         if (ada_is_constrained_packed_array_type (value_type (array)))
9044           error (_("cannot slice a packed array"));
9045
9046         /* If this is a reference to an array or an array lvalue,
9047            convert to a pointer.  */
9048         if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
9049             || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
9050                 && VALUE_LVAL (array) == lval_memory))
9051           array = value_addr (array);
9052
9053         if (noside == EVAL_AVOID_SIDE_EFFECTS
9054             && ada_is_array_descriptor_type (ada_check_typedef
9055                                              (value_type (array))))
9056           return empty_array (ada_type_of_array (array, 0), low_bound);
9057
9058         array = ada_coerce_to_simple_array_ptr (array);
9059
9060         /* If we have more than one level of pointer indirection,
9061            dereference the value until we get only one level.  */
9062         while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
9063                && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
9064                      == TYPE_CODE_PTR))
9065           array = value_ind (array);
9066
9067         /* Make sure we really do have an array type before going further,
9068            to avoid a SEGV when trying to get the index type or the target
9069            type later down the road if the debug info generated by
9070            the compiler is incorrect or incomplete.  */
9071         if (!ada_is_simple_array_type (value_type (array)))
9072           error (_("cannot take slice of non-array"));
9073
9074         if (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR)
9075           {
9076             if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
9077               return empty_array (TYPE_TARGET_TYPE (value_type (array)),
9078                                   low_bound);
9079             else
9080               {
9081                 struct type *arr_type0 =
9082                   to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array)),
9083                                        NULL, 1);
9084                 return ada_value_slice_from_ptr (array, arr_type0,
9085                                                  longest_to_int (low_bound),
9086                                                  longest_to_int (high_bound));
9087               }
9088           }
9089         else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9090           return array;
9091         else if (high_bound < low_bound)
9092           return empty_array (value_type (array), low_bound);
9093         else
9094           return ada_value_slice (array, longest_to_int (low_bound),
9095                                   longest_to_int (high_bound));
9096       }
9097
9098     case UNOP_IN_RANGE:
9099       (*pos) += 2;
9100       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9101       type = check_typedef (exp->elts[pc + 1].type);
9102
9103       if (noside == EVAL_SKIP)
9104         goto nosideret;
9105
9106       switch (TYPE_CODE (type))
9107         {
9108         default:
9109           lim_warning (_("Membership test incompletely implemented; "
9110                          "always returns true"));
9111           type = language_bool_type (exp->language_defn, exp->gdbarch);
9112           return value_from_longest (type, (LONGEST) 1);
9113
9114         case TYPE_CODE_RANGE:
9115           arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
9116           arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
9117           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9118           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9119           type = language_bool_type (exp->language_defn, exp->gdbarch);
9120           return
9121             value_from_longest (type,
9122                                 (value_less (arg1, arg3)
9123                                  || value_equal (arg1, arg3))
9124                                 && (value_less (arg2, arg1)
9125                                     || value_equal (arg2, arg1)));
9126         }
9127
9128     case BINOP_IN_BOUNDS:
9129       (*pos) += 2;
9130       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9131       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9132
9133       if (noside == EVAL_SKIP)
9134         goto nosideret;
9135
9136       if (noside == EVAL_AVOID_SIDE_EFFECTS)
9137         {
9138           type = language_bool_type (exp->language_defn, exp->gdbarch);
9139           return value_zero (type, not_lval);
9140         }
9141
9142       tem = longest_to_int (exp->elts[pc + 1].longconst);
9143
9144       type = ada_index_type (value_type (arg2), tem, "range");
9145       if (!type)
9146         type = value_type (arg1);
9147
9148       arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
9149       arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
9150
9151       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9152       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9153       type = language_bool_type (exp->language_defn, exp->gdbarch);
9154       return
9155         value_from_longest (type,
9156                             (value_less (arg1, arg3)
9157                              || value_equal (arg1, arg3))
9158                             && (value_less (arg2, arg1)
9159                                 || value_equal (arg2, arg1)));
9160
9161     case TERNOP_IN_RANGE:
9162       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9163       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9164       arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9165
9166       if (noside == EVAL_SKIP)
9167         goto nosideret;
9168
9169       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9170       binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
9171       type = language_bool_type (exp->language_defn, exp->gdbarch);
9172       return
9173         value_from_longest (type,
9174                             (value_less (arg1, arg3)
9175                              || value_equal (arg1, arg3))
9176                             && (value_less (arg2, arg1)
9177                                 || value_equal (arg2, arg1)));
9178
9179     case OP_ATR_FIRST:
9180     case OP_ATR_LAST:
9181     case OP_ATR_LENGTH:
9182       {
9183         struct type *type_arg;
9184         if (exp->elts[*pos].opcode == OP_TYPE)
9185           {
9186             evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9187             arg1 = NULL;
9188             type_arg = check_typedef (exp->elts[pc + 2].type);
9189           }
9190         else
9191           {
9192             arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9193             type_arg = NULL;
9194           }
9195
9196         if (exp->elts[*pos].opcode != OP_LONG)
9197           error (_("Invalid operand to '%s"), ada_attribute_name (op));
9198         tem = longest_to_int (exp->elts[*pos + 2].longconst);
9199         *pos += 4;
9200
9201         if (noside == EVAL_SKIP)
9202           goto nosideret;
9203
9204         if (type_arg == NULL)
9205           {
9206             arg1 = ada_coerce_ref (arg1);
9207
9208             if (ada_is_constrained_packed_array_type (value_type (arg1)))
9209               arg1 = ada_coerce_to_simple_array (arg1);
9210
9211             type = ada_index_type (value_type (arg1), tem,
9212                                    ada_attribute_name (op));
9213             if (type == NULL)
9214               type = builtin_type (exp->gdbarch)->builtin_int;
9215
9216             if (noside == EVAL_AVOID_SIDE_EFFECTS)
9217               return allocate_value (type);
9218
9219             switch (op)
9220               {
9221               default:          /* Should never happen.  */
9222                 error (_("unexpected attribute encountered"));
9223               case OP_ATR_FIRST:
9224                 return value_from_longest
9225                         (type, ada_array_bound (arg1, tem, 0));
9226               case OP_ATR_LAST:
9227                 return value_from_longest
9228                         (type, ada_array_bound (arg1, tem, 1));
9229               case OP_ATR_LENGTH:
9230                 return value_from_longest
9231                         (type, ada_array_length (arg1, tem));
9232               }
9233           }
9234         else if (discrete_type_p (type_arg))
9235           {
9236             struct type *range_type;
9237             char *name = ada_type_name (type_arg);
9238             range_type = NULL;
9239             if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
9240               range_type = to_fixed_range_type (type_arg, NULL);
9241             if (range_type == NULL)
9242               range_type = type_arg;
9243             switch (op)
9244               {
9245               default:
9246                 error (_("unexpected attribute encountered"));
9247               case OP_ATR_FIRST:
9248                 return value_from_longest
9249                   (range_type, ada_discrete_type_low_bound (range_type));
9250               case OP_ATR_LAST:
9251                 return value_from_longest
9252                   (range_type, ada_discrete_type_high_bound (range_type));
9253               case OP_ATR_LENGTH:
9254                 error (_("the 'length attribute applies only to array types"));
9255               }
9256           }
9257         else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
9258           error (_("unimplemented type attribute"));
9259         else
9260           {
9261             LONGEST low, high;
9262
9263             if (ada_is_constrained_packed_array_type (type_arg))
9264               type_arg = decode_constrained_packed_array_type (type_arg);
9265
9266             type = ada_index_type (type_arg, tem, ada_attribute_name (op));
9267             if (type == NULL)
9268               type = builtin_type (exp->gdbarch)->builtin_int;
9269
9270             if (noside == EVAL_AVOID_SIDE_EFFECTS)
9271               return allocate_value (type);
9272
9273             switch (op)
9274               {
9275               default:
9276                 error (_("unexpected attribute encountered"));
9277               case OP_ATR_FIRST:
9278                 low = ada_array_bound_from_type (type_arg, tem, 0);
9279                 return value_from_longest (type, low);
9280               case OP_ATR_LAST:
9281                 high = ada_array_bound_from_type (type_arg, tem, 1);
9282                 return value_from_longest (type, high);
9283               case OP_ATR_LENGTH:
9284                 low = ada_array_bound_from_type (type_arg, tem, 0);
9285                 high = ada_array_bound_from_type (type_arg, tem, 1);
9286                 return value_from_longest (type, high - low + 1);
9287               }
9288           }
9289       }
9290
9291     case OP_ATR_TAG:
9292       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9293       if (noside == EVAL_SKIP)
9294         goto nosideret;
9295
9296       if (noside == EVAL_AVOID_SIDE_EFFECTS)
9297         return value_zero (ada_tag_type (arg1), not_lval);
9298
9299       return ada_value_tag (arg1);
9300
9301     case OP_ATR_MIN:
9302     case OP_ATR_MAX:
9303       evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9304       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9305       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9306       if (noside == EVAL_SKIP)
9307         goto nosideret;
9308       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9309         return value_zero (value_type (arg1), not_lval);
9310       else
9311         {
9312           binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9313           return value_binop (arg1, arg2,
9314                               op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
9315         }
9316
9317     case OP_ATR_MODULUS:
9318       {
9319         struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
9320         evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9321
9322         if (noside == EVAL_SKIP)
9323           goto nosideret;
9324
9325         if (!ada_is_modular_type (type_arg))
9326           error (_("'modulus must be applied to modular type"));
9327
9328         return value_from_longest (TYPE_TARGET_TYPE (type_arg),
9329                                    ada_modulus (type_arg));
9330       }
9331
9332
9333     case OP_ATR_POS:
9334       evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9335       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9336       if (noside == EVAL_SKIP)
9337         goto nosideret;
9338       type = builtin_type (exp->gdbarch)->builtin_int;
9339       if (noside == EVAL_AVOID_SIDE_EFFECTS)
9340         return value_zero (type, not_lval);
9341       else
9342         return value_pos_atr (type, arg1);
9343
9344     case OP_ATR_SIZE:
9345       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9346       type = value_type (arg1);
9347
9348       /* If the argument is a reference, then dereference its type, since
9349          the user is really asking for the size of the actual object,
9350          not the size of the pointer.  */
9351       if (TYPE_CODE (type) == TYPE_CODE_REF)
9352         type = TYPE_TARGET_TYPE (type);
9353
9354       if (noside == EVAL_SKIP)
9355         goto nosideret;
9356       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9357         return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
9358       else
9359         return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
9360                                    TARGET_CHAR_BIT * TYPE_LENGTH (type));
9361
9362     case OP_ATR_VAL:
9363       evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9364       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9365       type = exp->elts[pc + 2].type;
9366       if (noside == EVAL_SKIP)
9367         goto nosideret;
9368       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9369         return value_zero (type, not_lval);
9370       else
9371         return value_val_atr (type, arg1);
9372
9373     case BINOP_EXP:
9374       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9375       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9376       if (noside == EVAL_SKIP)
9377         goto nosideret;
9378       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9379         return value_zero (value_type (arg1), not_lval);
9380       else
9381         {
9382           /* For integer exponentiation operations,
9383              only promote the first argument.  */
9384           if (is_integral_type (value_type (arg2)))
9385             unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9386           else
9387             binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9388
9389           return value_binop (arg1, arg2, op);
9390         }
9391
9392     case UNOP_PLUS:
9393       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9394       if (noside == EVAL_SKIP)
9395         goto nosideret;
9396       else
9397         return arg1;
9398
9399     case UNOP_ABS:
9400       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9401       if (noside == EVAL_SKIP)
9402         goto nosideret;
9403       unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9404       if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
9405         return value_neg (arg1);
9406       else
9407         return arg1;
9408
9409     case UNOP_IND:
9410       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9411       if (noside == EVAL_SKIP)
9412         goto nosideret;
9413       type = ada_check_typedef (value_type (arg1));
9414       if (noside == EVAL_AVOID_SIDE_EFFECTS)
9415         {
9416           if (ada_is_array_descriptor_type (type))
9417             /* GDB allows dereferencing GNAT array descriptors.  */
9418             {
9419               struct type *arrType = ada_type_of_array (arg1, 0);
9420               if (arrType == NULL)
9421                 error (_("Attempt to dereference null array pointer."));
9422               return value_at_lazy (arrType, 0);
9423             }
9424           else if (TYPE_CODE (type) == TYPE_CODE_PTR
9425                    || TYPE_CODE (type) == TYPE_CODE_REF
9426                    /* In C you can dereference an array to get the 1st elt.  */
9427                    || TYPE_CODE (type) == TYPE_CODE_ARRAY)
9428             {
9429               type = to_static_fixed_type
9430                 (ada_aligned_type
9431                  (ada_check_typedef (TYPE_TARGET_TYPE (type))));
9432               check_size (type);
9433               return value_zero (type, lval_memory);
9434             }
9435           else if (TYPE_CODE (type) == TYPE_CODE_INT)
9436             {
9437               /* GDB allows dereferencing an int.  */
9438               if (expect_type == NULL)
9439                 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
9440                                    lval_memory);
9441               else
9442                 {
9443                   expect_type =
9444                     to_static_fixed_type (ada_aligned_type (expect_type));
9445                   return value_zero (expect_type, lval_memory);
9446                 }
9447             }
9448           else
9449             error (_("Attempt to take contents of a non-pointer value."));
9450         }
9451       arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for?? */
9452       type = ada_check_typedef (value_type (arg1));
9453
9454       if (TYPE_CODE (type) == TYPE_CODE_INT)
9455           /* GDB allows dereferencing an int.  If we were given
9456              the expect_type, then use that as the target type.
9457              Otherwise, assume that the target type is an int.  */
9458         {
9459           if (expect_type != NULL)
9460             return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
9461                                               arg1));
9462           else
9463             return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
9464                                   (CORE_ADDR) value_as_address (arg1));
9465         }
9466
9467       if (ada_is_array_descriptor_type (type))
9468         /* GDB allows dereferencing GNAT array descriptors.  */
9469         return ada_coerce_to_simple_array (arg1);
9470       else
9471         return ada_value_ind (arg1);
9472
9473     case STRUCTOP_STRUCT:
9474       tem = longest_to_int (exp->elts[pc + 1].longconst);
9475       (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
9476       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9477       if (noside == EVAL_SKIP)
9478         goto nosideret;
9479       if (noside == EVAL_AVOID_SIDE_EFFECTS)
9480         {
9481           struct type *type1 = value_type (arg1);
9482           if (ada_is_tagged_type (type1, 1))
9483             {
9484               type = ada_lookup_struct_elt_type (type1,
9485                                                  &exp->elts[pc + 2].string,
9486                                                  1, 1, NULL);
9487               if (type == NULL)
9488                 /* In this case, we assume that the field COULD exist
9489                    in some extension of the type.  Return an object of
9490                    "type" void, which will match any formal
9491                    (see ada_type_match). */
9492                 return value_zero (builtin_type (exp->gdbarch)->builtin_void,
9493                                    lval_memory);
9494             }
9495           else
9496             type =
9497               ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
9498                                           0, NULL);
9499
9500           return value_zero (ada_aligned_type (type), lval_memory);
9501         }
9502       else
9503         arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
9504         arg1 = unwrap_value (arg1);
9505         return ada_to_fixed_value (arg1);
9506
9507     case OP_TYPE:
9508       /* The value is not supposed to be used.  This is here to make it
9509          easier to accommodate expressions that contain types.  */
9510       (*pos) += 2;
9511       if (noside == EVAL_SKIP)
9512         goto nosideret;
9513       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9514         return allocate_value (exp->elts[pc + 1].type);
9515       else
9516         error (_("Attempt to use a type name as an expression"));
9517
9518     case OP_AGGREGATE:
9519     case OP_CHOICES:
9520     case OP_OTHERS:
9521     case OP_DISCRETE_RANGE:
9522     case OP_POSITIONAL:
9523     case OP_NAME:
9524       if (noside == EVAL_NORMAL)
9525         switch (op)
9526           {
9527           case OP_NAME:
9528             error (_("Undefined name, ambiguous name, or renaming used in "
9529                      "component association: %s."), &exp->elts[pc+2].string);
9530           case OP_AGGREGATE:
9531             error (_("Aggregates only allowed on the right of an assignment"));
9532           default:
9533             internal_error (__FILE__, __LINE__, _("aggregate apparently mangled"));
9534           }
9535
9536       ada_forward_operator_length (exp, pc, &oplen, &nargs);
9537       *pos += oplen - 1;
9538       for (tem = 0; tem < nargs; tem += 1)
9539         ada_evaluate_subexp (NULL, exp, pos, noside);
9540       goto nosideret;
9541     }
9542
9543 nosideret:
9544   return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
9545 }
9546 \f
9547
9548                                 /* Fixed point */
9549
9550 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9551    type name that encodes the 'small and 'delta information.
9552    Otherwise, return NULL.  */
9553
9554 static const char *
9555 fixed_type_info (struct type *type)
9556 {
9557   const char *name = ada_type_name (type);
9558   enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
9559
9560   if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
9561     {
9562       const char *tail = strstr (name, "___XF_");
9563       if (tail == NULL)
9564         return NULL;
9565       else
9566         return tail + 5;
9567     }
9568   else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
9569     return fixed_type_info (TYPE_TARGET_TYPE (type));
9570   else
9571     return NULL;
9572 }
9573
9574 /* Returns non-zero iff TYPE represents an Ada fixed-point type.  */
9575
9576 int
9577 ada_is_fixed_point_type (struct type *type)
9578 {
9579   return fixed_type_info (type) != NULL;
9580 }
9581
9582 /* Return non-zero iff TYPE represents a System.Address type.  */
9583
9584 int
9585 ada_is_system_address_type (struct type *type)
9586 {
9587   return (TYPE_NAME (type)
9588           && strcmp (TYPE_NAME (type), "system__address") == 0);
9589 }
9590
9591 /* Assuming that TYPE is the representation of an Ada fixed-point
9592    type, return its delta, or -1 if the type is malformed and the
9593    delta cannot be determined.  */
9594
9595 DOUBLEST
9596 ada_delta (struct type *type)
9597 {
9598   const char *encoding = fixed_type_info (type);
9599   DOUBLEST num, den;
9600
9601   /* Strictly speaking, num and den are encoded as integer.  However,
9602      they may not fit into a long, and they will have to be converted
9603      to DOUBLEST anyway.  So scan them as DOUBLEST.  */
9604   if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
9605               &num, &den) < 2)
9606     return -1.0;
9607   else
9608     return num / den;
9609 }
9610
9611 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9612    factor ('SMALL value) associated with the type.  */
9613
9614 static DOUBLEST
9615 scaling_factor (struct type *type)
9616 {
9617   const char *encoding = fixed_type_info (type);
9618   DOUBLEST num0, den0, num1, den1;
9619   int n;
9620
9621   /* Strictly speaking, num's and den's are encoded as integer.  However,
9622      they may not fit into a long, and they will have to be converted
9623      to DOUBLEST anyway.  So scan them as DOUBLEST.  */
9624   n = sscanf (encoding,
9625               "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
9626               "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
9627               &num0, &den0, &num1, &den1);
9628
9629   if (n < 2)
9630     return 1.0;
9631   else if (n == 4)
9632     return num1 / den1;
9633   else
9634     return num0 / den0;
9635 }
9636
9637
9638 /* Assuming that X is the representation of a value of fixed-point
9639    type TYPE, return its floating-point equivalent.  */
9640
9641 DOUBLEST
9642 ada_fixed_to_float (struct type *type, LONGEST x)
9643 {
9644   return (DOUBLEST) x *scaling_factor (type);
9645 }
9646
9647 /* The representation of a fixed-point value of type TYPE
9648    corresponding to the value X.  */
9649
9650 LONGEST
9651 ada_float_to_fixed (struct type *type, DOUBLEST x)
9652 {
9653   return (LONGEST) (x / scaling_factor (type) + 0.5);
9654 }
9655
9656 \f
9657
9658                                 /* Range types */
9659
9660 /* Scan STR beginning at position K for a discriminant name, and
9661    return the value of that discriminant field of DVAL in *PX.  If
9662    PNEW_K is not null, put the position of the character beyond the
9663    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
9664    not alter *PX and *PNEW_K if unsuccessful.  */
9665
9666 static int
9667 scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
9668                     int *pnew_k)
9669 {
9670   static char *bound_buffer = NULL;
9671   static size_t bound_buffer_len = 0;
9672   char *bound;
9673   char *pend;
9674   struct value *bound_val;
9675
9676   if (dval == NULL || str == NULL || str[k] == '\0')
9677     return 0;
9678
9679   pend = strstr (str + k, "__");
9680   if (pend == NULL)
9681     {
9682       bound = str + k;
9683       k += strlen (bound);
9684     }
9685   else
9686     {
9687       GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
9688       bound = bound_buffer;
9689       strncpy (bound_buffer, str + k, pend - (str + k));
9690       bound[pend - (str + k)] = '\0';
9691       k = pend - str;
9692     }
9693
9694   bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
9695   if (bound_val == NULL)
9696     return 0;
9697
9698   *px = value_as_long (bound_val);
9699   if (pnew_k != NULL)
9700     *pnew_k = k;
9701   return 1;
9702 }
9703
9704 /* Value of variable named NAME in the current environment.  If
9705    no such variable found, then if ERR_MSG is null, returns 0, and
9706    otherwise causes an error with message ERR_MSG.  */
9707
9708 static struct value *
9709 get_var_value (char *name, char *err_msg)
9710 {
9711   struct ada_symbol_info *syms;
9712   int nsyms;
9713
9714   nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
9715                                   &syms);
9716
9717   if (nsyms != 1)
9718     {
9719       if (err_msg == NULL)
9720         return 0;
9721       else
9722         error (("%s"), err_msg);
9723     }
9724
9725   return value_of_variable (syms[0].sym, syms[0].block);
9726 }
9727
9728 /* Value of integer variable named NAME in the current environment.  If
9729    no such variable found, returns 0, and sets *FLAG to 0.  If
9730    successful, sets *FLAG to 1.  */
9731
9732 LONGEST
9733 get_int_var_value (char *name, int *flag)
9734 {
9735   struct value *var_val = get_var_value (name, 0);
9736
9737   if (var_val == 0)
9738     {
9739       if (flag != NULL)
9740         *flag = 0;
9741       return 0;
9742     }
9743   else
9744     {
9745       if (flag != NULL)
9746         *flag = 1;
9747       return value_as_long (var_val);
9748     }
9749 }
9750
9751
9752 /* Return a range type whose base type is that of the range type named
9753    NAME in the current environment, and whose bounds are calculated
9754    from NAME according to the GNAT range encoding conventions.
9755    Extract discriminant values, if needed, from DVAL.  ORIG_TYPE is the
9756    corresponding range type from debug information; fall back to using it
9757    if symbol lookup fails.  If a new type must be created, allocate it
9758    like ORIG_TYPE was.  The bounds information, in general, is encoded
9759    in NAME, the base type given in the named range type.  */
9760
9761 static struct type *
9762 to_fixed_range_type (struct type *raw_type, struct value *dval)
9763 {
9764   char *name;
9765   struct type *base_type;
9766   char *subtype_info;
9767
9768   gdb_assert (raw_type != NULL);
9769   gdb_assert (TYPE_NAME (raw_type) != NULL);
9770
9771   if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
9772     base_type = TYPE_TARGET_TYPE (raw_type);
9773   else
9774     base_type = raw_type;
9775
9776   name = TYPE_NAME (raw_type);
9777   subtype_info = strstr (name, "___XD");
9778   if (subtype_info == NULL)
9779     {
9780       LONGEST L = ada_discrete_type_low_bound (raw_type);
9781       LONGEST U = ada_discrete_type_high_bound (raw_type);
9782       if (L < INT_MIN || U > INT_MAX)
9783         return raw_type;
9784       else
9785         return create_range_type (alloc_type_copy (raw_type), raw_type,
9786                                   ada_discrete_type_low_bound (raw_type),
9787                                   ada_discrete_type_high_bound (raw_type));
9788     }
9789   else
9790     {
9791       static char *name_buf = NULL;
9792       static size_t name_len = 0;
9793       int prefix_len = subtype_info - name;
9794       LONGEST L, U;
9795       struct type *type;
9796       char *bounds_str;
9797       int n;
9798
9799       GROW_VECT (name_buf, name_len, prefix_len + 5);
9800       strncpy (name_buf, name, prefix_len);
9801       name_buf[prefix_len] = '\0';
9802
9803       subtype_info += 5;
9804       bounds_str = strchr (subtype_info, '_');
9805       n = 1;
9806
9807       if (*subtype_info == 'L')
9808         {
9809           if (!ada_scan_number (bounds_str, n, &L, &n)
9810               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
9811             return raw_type;
9812           if (bounds_str[n] == '_')
9813             n += 2;
9814           else if (bounds_str[n] == '.')        /* FIXME? SGI Workshop kludge.  */
9815             n += 1;
9816           subtype_info += 1;
9817         }
9818       else
9819         {
9820           int ok;
9821           strcpy (name_buf + prefix_len, "___L");
9822           L = get_int_var_value (name_buf, &ok);
9823           if (!ok)
9824             {
9825               lim_warning (_("Unknown lower bound, using 1."));
9826               L = 1;
9827             }
9828         }
9829
9830       if (*subtype_info == 'U')
9831         {
9832           if (!ada_scan_number (bounds_str, n, &U, &n)
9833               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
9834             return raw_type;
9835         }
9836       else
9837         {
9838           int ok;
9839           strcpy (name_buf + prefix_len, "___U");
9840           U = get_int_var_value (name_buf, &ok);
9841           if (!ok)
9842             {
9843               lim_warning (_("Unknown upper bound, using %ld."), (long) L);
9844               U = L;
9845             }
9846         }
9847
9848       type = create_range_type (alloc_type_copy (raw_type), base_type, L, U);
9849       TYPE_NAME (type) = name;
9850       return type;
9851     }
9852 }
9853
9854 /* True iff NAME is the name of a range type.  */
9855
9856 int
9857 ada_is_range_type_name (const char *name)
9858 {
9859   return (name != NULL && strstr (name, "___XD"));
9860 }
9861 \f
9862
9863                                 /* Modular types */
9864
9865 /* True iff TYPE is an Ada modular type.  */
9866
9867 int
9868 ada_is_modular_type (struct type *type)
9869 {
9870   struct type *subranged_type = base_type (type);
9871
9872   return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
9873           && TYPE_CODE (subranged_type) == TYPE_CODE_INT
9874           && TYPE_UNSIGNED (subranged_type));
9875 }
9876
9877 /* Try to determine the lower and upper bounds of the given modular type
9878    using the type name only.  Return non-zero and set L and U as the lower
9879    and upper bounds (respectively) if successful.  */
9880
9881 int
9882 ada_modulus_from_name (struct type *type, ULONGEST *modulus)
9883 {
9884   char *name = ada_type_name (type);
9885   char *suffix;
9886   int k;
9887   LONGEST U;
9888
9889   if (name == NULL)
9890     return 0;
9891
9892   /* Discrete type bounds are encoded using an __XD suffix.  In our case,
9893      we are looking for static bounds, which means an __XDLU suffix.
9894      Moreover, we know that the lower bound of modular types is always
9895      zero, so the actual suffix should start with "__XDLU_0__", and
9896      then be followed by the upper bound value.  */
9897   suffix = strstr (name, "__XDLU_0__");
9898   if (suffix == NULL)
9899     return 0;
9900   k = 10;
9901   if (!ada_scan_number (suffix, k, &U, NULL))
9902     return 0;
9903
9904   *modulus = (ULONGEST) U + 1;
9905   return 1;
9906 }
9907
9908 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */
9909
9910 ULONGEST
9911 ada_modulus (struct type *type)
9912 {
9913   return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
9914 }
9915 \f
9916
9917 /* Ada exception catchpoint support:
9918    ---------------------------------
9919
9920    We support 3 kinds of exception catchpoints:
9921      . catchpoints on Ada exceptions
9922      . catchpoints on unhandled Ada exceptions
9923      . catchpoints on failed assertions
9924
9925    Exceptions raised during failed assertions, or unhandled exceptions
9926    could perfectly be caught with the general catchpoint on Ada exceptions.
9927    However, we can easily differentiate these two special cases, and having
9928    the option to distinguish these two cases from the rest can be useful
9929    to zero-in on certain situations.
9930
9931    Exception catchpoints are a specialized form of breakpoint,
9932    since they rely on inserting breakpoints inside known routines
9933    of the GNAT runtime.  The implementation therefore uses a standard
9934    breakpoint structure of the BP_BREAKPOINT type, but with its own set
9935    of breakpoint_ops.
9936
9937    Support in the runtime for exception catchpoints have been changed
9938    a few times already, and these changes affect the implementation
9939    of these catchpoints.  In order to be able to support several
9940    variants of the runtime, we use a sniffer that will determine
9941    the runtime variant used by the program being debugged.
9942
9943    At this time, we do not support the use of conditions on Ada exception
9944    catchpoints.  The COND and COND_STRING fields are therefore set
9945    to NULL (most of the time, see below).
9946
9947    Conditions where EXP_STRING, COND, and COND_STRING are used:
9948
9949      When a user specifies the name of a specific exception in the case
9950      of catchpoints on Ada exceptions, we store the name of that exception
9951      in the EXP_STRING.  We then translate this request into an actual
9952      condition stored in COND_STRING, and then parse it into an expression
9953      stored in COND.  */
9954
9955 /* The different types of catchpoints that we introduced for catching
9956    Ada exceptions.  */
9957
9958 enum exception_catchpoint_kind
9959 {
9960   ex_catch_exception,
9961   ex_catch_exception_unhandled,
9962   ex_catch_assert
9963 };
9964
9965 /* Ada's standard exceptions.  */
9966
9967 static char *standard_exc[] = {
9968   "constraint_error",
9969   "program_error",
9970   "storage_error",
9971   "tasking_error"
9972 };
9973
9974 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
9975
9976 /* A structure that describes how to support exception catchpoints
9977    for a given executable.  */
9978
9979 struct exception_support_info
9980 {
9981    /* The name of the symbol to break on in order to insert
9982       a catchpoint on exceptions.  */
9983    const char *catch_exception_sym;
9984
9985    /* The name of the symbol to break on in order to insert
9986       a catchpoint on unhandled exceptions.  */
9987    const char *catch_exception_unhandled_sym;
9988
9989    /* The name of the symbol to break on in order to insert
9990       a catchpoint on failed assertions.  */
9991    const char *catch_assert_sym;
9992
9993    /* Assuming that the inferior just triggered an unhandled exception
9994       catchpoint, this function is responsible for returning the address
9995       in inferior memory where the name of that exception is stored.
9996       Return zero if the address could not be computed.  */
9997    ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
9998 };
9999
10000 static CORE_ADDR ada_unhandled_exception_name_addr (void);
10001 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
10002
10003 /* The following exception support info structure describes how to
10004    implement exception catchpoints with the latest version of the
10005    Ada runtime (as of 2007-03-06).  */
10006
10007 static const struct exception_support_info default_exception_support_info =
10008 {
10009   "__gnat_debug_raise_exception", /* catch_exception_sym */
10010   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
10011   "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
10012   ada_unhandled_exception_name_addr
10013 };
10014
10015 /* The following exception support info structure describes how to
10016    implement exception catchpoints with a slightly older version
10017    of the Ada runtime.  */
10018
10019 static const struct exception_support_info exception_support_info_fallback =
10020 {
10021   "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
10022   "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
10023   "system__assertions__raise_assert_failure",  /* catch_assert_sym */
10024   ada_unhandled_exception_name_addr_from_raise
10025 };
10026
10027 /* For each executable, we sniff which exception info structure to use
10028    and cache it in the following global variable.  */
10029
10030 static const struct exception_support_info *exception_info = NULL;
10031
10032 /* Inspect the Ada runtime and determine which exception info structure
10033    should be used to provide support for exception catchpoints.
10034
10035    This function will always set exception_info, or raise an error.  */
10036
10037 static void
10038 ada_exception_support_info_sniffer (void)
10039 {
10040   struct symbol *sym;
10041
10042   /* If the exception info is already known, then no need to recompute it.  */
10043   if (exception_info != NULL)
10044     return;
10045
10046   /* Check the latest (default) exception support info.  */
10047   sym = standard_lookup (default_exception_support_info.catch_exception_sym,
10048                          NULL, VAR_DOMAIN);
10049   if (sym != NULL)
10050     {
10051       exception_info = &default_exception_support_info;
10052       return;
10053     }
10054
10055   /* Try our fallback exception suport info.  */
10056   sym = standard_lookup (exception_support_info_fallback.catch_exception_sym,
10057                          NULL, VAR_DOMAIN);
10058   if (sym != NULL)
10059     {
10060       exception_info = &exception_support_info_fallback;
10061       return;
10062     }
10063
10064   /* Sometimes, it is normal for us to not be able to find the routine
10065      we are looking for.  This happens when the program is linked with
10066      the shared version of the GNAT runtime, and the program has not been
10067      started yet.  Inform the user of these two possible causes if
10068      applicable.  */
10069
10070   if (ada_update_initial_language (language_unknown) != language_ada)
10071     error (_("Unable to insert catchpoint.  Is this an Ada main program?"));
10072
10073   /* If the symbol does not exist, then check that the program is
10074      already started, to make sure that shared libraries have been
10075      loaded.  If it is not started, this may mean that the symbol is
10076      in a shared library.  */
10077
10078   if (ptid_get_pid (inferior_ptid) == 0)
10079     error (_("Unable to insert catchpoint. Try to start the program first."));
10080
10081   /* At this point, we know that we are debugging an Ada program and
10082      that the inferior has been started, but we still are not able to
10083      find the run-time symbols. That can mean that we are in
10084      configurable run time mode, or that a-except as been optimized
10085      out by the linker...  In any case, at this point it is not worth
10086      supporting this feature.  */
10087
10088   error (_("Cannot insert catchpoints in this configuration."));
10089 }
10090
10091 /* An observer of "executable_changed" events.
10092    Its role is to clear certain cached values that need to be recomputed
10093    each time a new executable is loaded by GDB.  */
10094
10095 static void
10096 ada_executable_changed_observer (void)
10097 {
10098   /* If the executable changed, then it is possible that the Ada runtime
10099      is different.  So we need to invalidate the exception support info
10100      cache.  */
10101   exception_info = NULL;
10102 }
10103
10104 /* True iff FRAME is very likely to be that of a function that is
10105    part of the runtime system.  This is all very heuristic, but is
10106    intended to be used as advice as to what frames are uninteresting
10107    to most users.  */
10108
10109 static int
10110 is_known_support_routine (struct frame_info *frame)
10111 {
10112   struct symtab_and_line sal;
10113   char *func_name;
10114   enum language func_lang;
10115   int i;
10116
10117   /* If this code does not have any debugging information (no symtab),
10118      This cannot be any user code.  */
10119
10120   find_frame_sal (frame, &sal);
10121   if (sal.symtab == NULL)
10122     return 1;
10123
10124   /* If there is a symtab, but the associated source file cannot be
10125      located, then assume this is not user code:  Selecting a frame
10126      for which we cannot display the code would not be very helpful
10127      for the user.  This should also take care of case such as VxWorks
10128      where the kernel has some debugging info provided for a few units.  */
10129
10130   if (symtab_to_fullname (sal.symtab) == NULL)
10131     return 1;
10132
10133   /* Check the unit filename againt the Ada runtime file naming.
10134      We also check the name of the objfile against the name of some
10135      known system libraries that sometimes come with debugging info
10136      too.  */
10137
10138   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
10139     {
10140       re_comp (known_runtime_file_name_patterns[i]);
10141       if (re_exec (sal.symtab->filename))
10142         return 1;
10143       if (sal.symtab->objfile != NULL
10144           && re_exec (sal.symtab->objfile->name))
10145         return 1;
10146     }
10147
10148   /* Check whether the function is a GNAT-generated entity.  */
10149
10150   find_frame_funname (frame, &func_name, &func_lang);
10151   if (func_name == NULL)
10152     return 1;
10153
10154   for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
10155     {
10156       re_comp (known_auxiliary_function_name_patterns[i]);
10157       if (re_exec (func_name))
10158         return 1;
10159     }
10160
10161   return 0;
10162 }
10163
10164 /* Find the first frame that contains debugging information and that is not
10165    part of the Ada run-time, starting from FI and moving upward.  */
10166
10167 void
10168 ada_find_printable_frame (struct frame_info *fi)
10169 {
10170   for (; fi != NULL; fi = get_prev_frame (fi))
10171     {
10172       if (!is_known_support_routine (fi))
10173         {
10174           select_frame (fi);
10175           break;
10176         }
10177     }
10178
10179 }
10180
10181 /* Assuming that the inferior just triggered an unhandled exception
10182    catchpoint, return the address in inferior memory where the name
10183    of the exception is stored.
10184
10185    Return zero if the address could not be computed.  */
10186
10187 static CORE_ADDR
10188 ada_unhandled_exception_name_addr (void)
10189 {
10190   return parse_and_eval_address ("e.full_name");
10191 }
10192
10193 /* Same as ada_unhandled_exception_name_addr, except that this function
10194    should be used when the inferior uses an older version of the runtime,
10195    where the exception name needs to be extracted from a specific frame
10196    several frames up in the callstack.  */
10197
10198 static CORE_ADDR
10199 ada_unhandled_exception_name_addr_from_raise (void)
10200 {
10201   int frame_level;
10202   struct frame_info *fi;
10203
10204   /* To determine the name of this exception, we need to select
10205      the frame corresponding to RAISE_SYM_NAME.  This frame is
10206      at least 3 levels up, so we simply skip the first 3 frames
10207      without checking the name of their associated function.  */
10208   fi = get_current_frame ();
10209   for (frame_level = 0; frame_level < 3; frame_level += 1)
10210     if (fi != NULL)
10211       fi = get_prev_frame (fi);
10212
10213   while (fi != NULL)
10214     {
10215       char *func_name;
10216       enum language func_lang;
10217
10218       find_frame_funname (fi, &func_name, &func_lang);
10219       if (func_name != NULL
10220           && strcmp (func_name, exception_info->catch_exception_sym) == 0)
10221         break; /* We found the frame we were looking for...  */
10222       fi = get_prev_frame (fi);
10223     }
10224
10225   if (fi == NULL)
10226     return 0;
10227
10228   select_frame (fi);
10229   return parse_and_eval_address ("id.full_name");
10230 }
10231
10232 /* Assuming the inferior just triggered an Ada exception catchpoint
10233    (of any type), return the address in inferior memory where the name
10234    of the exception is stored, if applicable.
10235
10236    Return zero if the address could not be computed, or if not relevant.  */
10237
10238 static CORE_ADDR
10239 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex,
10240                            struct breakpoint *b)
10241 {
10242   switch (ex)
10243     {
10244       case ex_catch_exception:
10245         return (parse_and_eval_address ("e.full_name"));
10246         break;
10247
10248       case ex_catch_exception_unhandled:
10249         return exception_info->unhandled_exception_name_addr ();
10250         break;
10251
10252       case ex_catch_assert:
10253         return 0;  /* Exception name is not relevant in this case.  */
10254         break;
10255
10256       default:
10257         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10258         break;
10259     }
10260
10261   return 0; /* Should never be reached.  */
10262 }
10263
10264 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
10265    any error that ada_exception_name_addr_1 might cause to be thrown.
10266    When an error is intercepted, a warning with the error message is printed,
10267    and zero is returned.  */
10268
10269 static CORE_ADDR
10270 ada_exception_name_addr (enum exception_catchpoint_kind ex,
10271                          struct breakpoint *b)
10272 {
10273   struct gdb_exception e;
10274   CORE_ADDR result = 0;
10275
10276   TRY_CATCH (e, RETURN_MASK_ERROR)
10277     {
10278       result = ada_exception_name_addr_1 (ex, b);
10279     }
10280
10281   if (e.reason < 0)
10282     {
10283       warning (_("failed to get exception name: %s"), e.message);
10284       return 0;
10285     }
10286
10287   return result;
10288 }
10289
10290 /* Implement the PRINT_IT method in the breakpoint_ops structure
10291    for all exception catchpoint kinds.  */
10292
10293 static enum print_stop_action
10294 print_it_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
10295 {
10296   const CORE_ADDR addr = ada_exception_name_addr (ex, b);
10297   char exception_name[256];
10298
10299   if (addr != 0)
10300     {
10301       read_memory (addr, exception_name, sizeof (exception_name) - 1);
10302       exception_name [sizeof (exception_name) - 1] = '\0';
10303     }
10304
10305   ada_find_printable_frame (get_current_frame ());
10306
10307   annotate_catchpoint (b->number);
10308   switch (ex)
10309     {
10310       case ex_catch_exception:
10311         if (addr != 0)
10312           printf_filtered (_("\nCatchpoint %d, %s at "),
10313                            b->number, exception_name);
10314         else
10315           printf_filtered (_("\nCatchpoint %d, exception at "), b->number);
10316         break;
10317       case ex_catch_exception_unhandled:
10318         if (addr != 0)
10319           printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10320                            b->number, exception_name);
10321         else
10322           printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10323                            b->number);
10324         break;
10325       case ex_catch_assert:
10326         printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10327                          b->number);
10328         break;
10329     }
10330
10331   return PRINT_SRC_AND_LOC;
10332 }
10333
10334 /* Implement the PRINT_ONE method in the breakpoint_ops structure
10335    for all exception catchpoint kinds.  */
10336
10337 static void
10338 print_one_exception (enum exception_catchpoint_kind ex,
10339                      struct breakpoint *b, struct bp_location **last_loc)
10340 {
10341   struct value_print_options opts;
10342
10343   get_user_print_options (&opts);
10344   if (opts.addressprint)
10345     {
10346       annotate_field (4);
10347       ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
10348     }
10349
10350   annotate_field (5);
10351   *last_loc = b->loc;
10352   switch (ex)
10353     {
10354       case ex_catch_exception:
10355         if (b->exp_string != NULL)
10356           {
10357             char *msg = xstrprintf (_("`%s' Ada exception"), b->exp_string);
10358
10359             ui_out_field_string (uiout, "what", msg);
10360             xfree (msg);
10361           }
10362         else
10363           ui_out_field_string (uiout, "what", "all Ada exceptions");
10364
10365         break;
10366
10367       case ex_catch_exception_unhandled:
10368         ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
10369         break;
10370
10371       case ex_catch_assert:
10372         ui_out_field_string (uiout, "what", "failed Ada assertions");
10373         break;
10374
10375       default:
10376         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10377         break;
10378     }
10379 }
10380
10381 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
10382    for all exception catchpoint kinds.  */
10383
10384 static void
10385 print_mention_exception (enum exception_catchpoint_kind ex,
10386                          struct breakpoint *b)
10387 {
10388   switch (ex)
10389     {
10390       case ex_catch_exception:
10391         if (b->exp_string != NULL)
10392           printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10393                            b->number, b->exp_string);
10394         else
10395           printf_filtered (_("Catchpoint %d: all Ada exceptions"), b->number);
10396
10397         break;
10398
10399       case ex_catch_exception_unhandled:
10400         printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10401                          b->number);
10402         break;
10403
10404       case ex_catch_assert:
10405         printf_filtered (_("Catchpoint %d: failed Ada assertions"), b->number);
10406         break;
10407
10408       default:
10409         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10410         break;
10411     }
10412 }
10413
10414 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
10415    for all exception catchpoint kinds.  */
10416
10417 static void
10418 print_recreate_exception (enum exception_catchpoint_kind ex,
10419                           struct breakpoint *b, struct ui_file *fp)
10420 {
10421   switch (ex)
10422     {
10423       case ex_catch_exception:
10424         fprintf_filtered (fp, "catch exception");
10425         if (b->exp_string != NULL)
10426           fprintf_filtered (fp, " %s", b->exp_string);
10427         break;
10428
10429       case ex_catch_exception_unhandled:
10430         fprintf_filtered (fp, "catch exception unhandled");
10431         break;
10432
10433       case ex_catch_assert:
10434         fprintf_filtered (fp, "catch assert");
10435         break;
10436
10437       default:
10438         internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10439     }
10440 }
10441
10442 /* Virtual table for "catch exception" breakpoints.  */
10443
10444 static enum print_stop_action
10445 print_it_catch_exception (struct breakpoint *b)
10446 {
10447   return print_it_exception (ex_catch_exception, b);
10448 }
10449
10450 static void
10451 print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
10452 {
10453   print_one_exception (ex_catch_exception, b, last_loc);
10454 }
10455
10456 static void
10457 print_mention_catch_exception (struct breakpoint *b)
10458 {
10459   print_mention_exception (ex_catch_exception, b);
10460 }
10461
10462 static void
10463 print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
10464 {
10465   print_recreate_exception (ex_catch_exception, b, fp);
10466 }
10467
10468 static struct breakpoint_ops catch_exception_breakpoint_ops =
10469 {
10470   NULL, /* insert */
10471   NULL, /* remove */
10472   NULL, /* breakpoint_hit */
10473   print_it_catch_exception,
10474   print_one_catch_exception,
10475   print_mention_catch_exception,
10476   print_recreate_catch_exception
10477 };
10478
10479 /* Virtual table for "catch exception unhandled" breakpoints.  */
10480
10481 static enum print_stop_action
10482 print_it_catch_exception_unhandled (struct breakpoint *b)
10483 {
10484   return print_it_exception (ex_catch_exception_unhandled, b);
10485 }
10486
10487 static void
10488 print_one_catch_exception_unhandled (struct breakpoint *b,
10489                                      struct bp_location **last_loc)
10490 {
10491   print_one_exception (ex_catch_exception_unhandled, b, last_loc);
10492 }
10493
10494 static void
10495 print_mention_catch_exception_unhandled (struct breakpoint *b)
10496 {
10497   print_mention_exception (ex_catch_exception_unhandled, b);
10498 }
10499
10500 static void
10501 print_recreate_catch_exception_unhandled (struct breakpoint *b,
10502                                           struct ui_file *fp)
10503 {
10504   print_recreate_exception (ex_catch_exception_unhandled, b, fp);
10505 }
10506
10507 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops = {
10508   NULL, /* insert */
10509   NULL, /* remove */
10510   NULL, /* breakpoint_hit */
10511   print_it_catch_exception_unhandled,
10512   print_one_catch_exception_unhandled,
10513   print_mention_catch_exception_unhandled,
10514   print_recreate_catch_exception_unhandled
10515 };
10516
10517 /* Virtual table for "catch assert" breakpoints.  */
10518
10519 static enum print_stop_action
10520 print_it_catch_assert (struct breakpoint *b)
10521 {
10522   return print_it_exception (ex_catch_assert, b);
10523 }
10524
10525 static void
10526 print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
10527 {
10528   print_one_exception (ex_catch_assert, b, last_loc);
10529 }
10530
10531 static void
10532 print_mention_catch_assert (struct breakpoint *b)
10533 {
10534   print_mention_exception (ex_catch_assert, b);
10535 }
10536
10537 static void
10538 print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
10539 {
10540   print_recreate_exception (ex_catch_assert, b, fp);
10541 }
10542
10543 static struct breakpoint_ops catch_assert_breakpoint_ops = {
10544   NULL, /* insert */
10545   NULL, /* remove */
10546   NULL, /* breakpoint_hit */
10547   print_it_catch_assert,
10548   print_one_catch_assert,
10549   print_mention_catch_assert,
10550   print_recreate_catch_assert
10551 };
10552
10553 /* Return non-zero if B is an Ada exception catchpoint.  */
10554
10555 int
10556 ada_exception_catchpoint_p (struct breakpoint *b)
10557 {
10558   return (b->ops == &catch_exception_breakpoint_ops
10559           || b->ops == &catch_exception_unhandled_breakpoint_ops
10560           || b->ops == &catch_assert_breakpoint_ops);
10561 }
10562
10563 /* Return a newly allocated copy of the first space-separated token
10564    in ARGSP, and then adjust ARGSP to point immediately after that
10565    token.
10566
10567    Return NULL if ARGPS does not contain any more tokens.  */
10568
10569 static char *
10570 ada_get_next_arg (char **argsp)
10571 {
10572   char *args = *argsp;
10573   char *end;
10574   char *result;
10575
10576   /* Skip any leading white space.  */
10577
10578   while (isspace (*args))
10579     args++;
10580
10581   if (args[0] == '\0')
10582     return NULL; /* No more arguments.  */
10583
10584   /* Find the end of the current argument.  */
10585
10586   end = args;
10587   while (*end != '\0' && !isspace (*end))
10588     end++;
10589
10590   /* Adjust ARGSP to point to the start of the next argument.  */
10591
10592   *argsp = end;
10593
10594   /* Make a copy of the current argument and return it.  */
10595
10596   result = xmalloc (end - args + 1);
10597   strncpy (result, args, end - args);
10598   result[end - args] = '\0';
10599
10600   return result;
10601 }
10602
10603 /* Split the arguments specified in a "catch exception" command.
10604    Set EX to the appropriate catchpoint type.
10605    Set EXP_STRING to the name of the specific exception if
10606    specified by the user.  */
10607
10608 static void
10609 catch_ada_exception_command_split (char *args,
10610                                    enum exception_catchpoint_kind *ex,
10611                                    char **exp_string)
10612 {
10613   struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
10614   char *exception_name;
10615
10616   exception_name = ada_get_next_arg (&args);
10617   make_cleanup (xfree, exception_name);
10618
10619   /* Check that we do not have any more arguments.  Anything else
10620      is unexpected.  */
10621
10622   while (isspace (*args))
10623     args++;
10624
10625   if (args[0] != '\0')
10626     error (_("Junk at end of expression"));
10627
10628   discard_cleanups (old_chain);
10629
10630   if (exception_name == NULL)
10631     {
10632       /* Catch all exceptions.  */
10633       *ex = ex_catch_exception;
10634       *exp_string = NULL;
10635     }
10636   else if (strcmp (exception_name, "unhandled") == 0)
10637     {
10638       /* Catch unhandled exceptions.  */
10639       *ex = ex_catch_exception_unhandled;
10640       *exp_string = NULL;
10641     }
10642   else
10643     {
10644       /* Catch a specific exception.  */
10645       *ex = ex_catch_exception;
10646       *exp_string = exception_name;
10647     }
10648 }
10649
10650 /* Return the name of the symbol on which we should break in order to
10651    implement a catchpoint of the EX kind.  */
10652
10653 static const char *
10654 ada_exception_sym_name (enum exception_catchpoint_kind ex)
10655 {
10656   gdb_assert (exception_info != NULL);
10657
10658   switch (ex)
10659     {
10660       case ex_catch_exception:
10661         return (exception_info->catch_exception_sym);
10662         break;
10663       case ex_catch_exception_unhandled:
10664         return (exception_info->catch_exception_unhandled_sym);
10665         break;
10666       case ex_catch_assert:
10667         return (exception_info->catch_assert_sym);
10668         break;
10669       default:
10670         internal_error (__FILE__, __LINE__,
10671                         _("unexpected catchpoint kind (%d)"), ex);
10672     }
10673 }
10674
10675 /* Return the breakpoint ops "virtual table" used for catchpoints
10676    of the EX kind.  */
10677
10678 static struct breakpoint_ops *
10679 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex)
10680 {
10681   switch (ex)
10682     {
10683       case ex_catch_exception:
10684         return (&catch_exception_breakpoint_ops);
10685         break;
10686       case ex_catch_exception_unhandled:
10687         return (&catch_exception_unhandled_breakpoint_ops);
10688         break;
10689       case ex_catch_assert:
10690         return (&catch_assert_breakpoint_ops);
10691         break;
10692       default:
10693         internal_error (__FILE__, __LINE__,
10694                         _("unexpected catchpoint kind (%d)"), ex);
10695     }
10696 }
10697
10698 /* Return the condition that will be used to match the current exception
10699    being raised with the exception that the user wants to catch.  This
10700    assumes that this condition is used when the inferior just triggered
10701    an exception catchpoint.
10702
10703    The string returned is a newly allocated string that needs to be
10704    deallocated later.  */
10705
10706 static char *
10707 ada_exception_catchpoint_cond_string (const char *exp_string)
10708 {
10709   int i;
10710
10711   /* The standard exceptions are a special case. They are defined in
10712      runtime units that have been compiled without debugging info; if
10713      EXP_STRING is the not-fully-qualified name of a standard
10714      exception (e.g. "constraint_error") then, during the evaluation
10715      of the condition expression, the symbol lookup on this name would
10716      *not* return this standard exception. The catchpoint condition
10717      may then be set only on user-defined exceptions which have the
10718      same not-fully-qualified name (e.g. my_package.constraint_error).
10719
10720      To avoid this unexcepted behavior, these standard exceptions are
10721      systematically prefixed by "standard". This means that "catch
10722      exception constraint_error" is rewritten into "catch exception
10723      standard.constraint_error".
10724
10725      If an exception named contraint_error is defined in another package of
10726      the inferior program, then the only way to specify this exception as a
10727      breakpoint condition is to use its fully-qualified named:
10728      e.g. my_package.constraint_error.  */
10729
10730   for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
10731     {
10732       if (strcmp (standard_exc [i], exp_string) == 0)
10733         {
10734           return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
10735                              exp_string);
10736         }
10737     }
10738   return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string);
10739 }
10740
10741 /* Return the expression corresponding to COND_STRING evaluated at SAL.  */
10742
10743 static struct expression *
10744 ada_parse_catchpoint_condition (char *cond_string,
10745                                 struct symtab_and_line sal)
10746 {
10747   return (parse_exp_1 (&cond_string, block_for_pc (sal.pc), 0));
10748 }
10749
10750 /* Return the symtab_and_line that should be used to insert an exception
10751    catchpoint of the TYPE kind.
10752
10753    EX_STRING should contain the name of a specific exception
10754    that the catchpoint should catch, or NULL otherwise.
10755
10756    The idea behind all the remaining parameters is that their names match
10757    the name of certain fields in the breakpoint structure that are used to
10758    handle exception catchpoints.  This function returns the value to which
10759    these fields should be set, depending on the type of catchpoint we need
10760    to create.
10761
10762    If COND and COND_STRING are both non-NULL, any value they might
10763    hold will be free'ed, and then replaced by newly allocated ones.
10764    These parameters are left untouched otherwise.  */
10765
10766 static struct symtab_and_line
10767 ada_exception_sal (enum exception_catchpoint_kind ex, char *exp_string,
10768                    char **addr_string, char **cond_string,
10769                    struct expression **cond, struct breakpoint_ops **ops)
10770 {
10771   const char *sym_name;
10772   struct symbol *sym;
10773   struct symtab_and_line sal;
10774
10775   /* First, find out which exception support info to use.  */
10776   ada_exception_support_info_sniffer ();
10777
10778   /* Then lookup the function on which we will break in order to catch
10779      the Ada exceptions requested by the user.  */
10780
10781   sym_name = ada_exception_sym_name (ex);
10782   sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
10783
10784   /* The symbol we're looking up is provided by a unit in the GNAT runtime
10785      that should be compiled with debugging information.  As a result, we
10786      expect to find that symbol in the symtabs.  If we don't find it, then
10787      the target most likely does not support Ada exceptions, or we cannot
10788      insert exception breakpoints yet, because the GNAT runtime hasn't been
10789      loaded yet.  */
10790
10791   /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
10792      in such a way that no debugging information is produced for the symbol
10793      we are looking for.  In this case, we could search the minimal symbols
10794      as a fall-back mechanism.  This would still be operating in degraded
10795      mode, however, as we would still be missing the debugging information
10796      that is needed in order to extract the name of the exception being
10797      raised (this name is printed in the catchpoint message, and is also
10798      used when trying to catch a specific exception).  We do not handle
10799      this case for now.  */
10800
10801   if (sym == NULL)
10802     error (_("Unable to break on '%s' in this configuration."), sym_name);
10803
10804   /* Make sure that the symbol we found corresponds to a function.  */
10805   if (SYMBOL_CLASS (sym) != LOC_BLOCK)
10806     error (_("Symbol \"%s\" is not a function (class = %d)"),
10807            sym_name, SYMBOL_CLASS (sym));
10808
10809   sal = find_function_start_sal (sym, 1);
10810
10811   /* Set ADDR_STRING.  */
10812
10813   *addr_string = xstrdup (sym_name);
10814
10815   /* Set the COND and COND_STRING (if not NULL).  */
10816
10817   if (cond_string != NULL && cond != NULL)
10818     {
10819       if (*cond_string != NULL)
10820         {
10821           xfree (*cond_string);
10822           *cond_string = NULL;
10823         }
10824       if (*cond != NULL)
10825         {
10826           xfree (*cond);
10827           *cond = NULL;
10828         }
10829       if (exp_string != NULL)
10830         {
10831           *cond_string = ada_exception_catchpoint_cond_string (exp_string);
10832           *cond = ada_parse_catchpoint_condition (*cond_string, sal);
10833         }
10834     }
10835
10836   /* Set OPS.  */
10837   *ops = ada_exception_breakpoint_ops (ex);
10838
10839   return sal;
10840 }
10841
10842 /* Parse the arguments (ARGS) of the "catch exception" command.
10843
10844    Set TYPE to the appropriate exception catchpoint type.
10845    If the user asked the catchpoint to catch only a specific
10846    exception, then save the exception name in ADDR_STRING.
10847
10848    See ada_exception_sal for a description of all the remaining
10849    function arguments of this function.  */
10850
10851 struct symtab_and_line
10852 ada_decode_exception_location (char *args, char **addr_string,
10853                                char **exp_string, char **cond_string,
10854                                struct expression **cond,
10855                                struct breakpoint_ops **ops)
10856 {
10857   enum exception_catchpoint_kind ex;
10858
10859   catch_ada_exception_command_split (args, &ex, exp_string);
10860   return ada_exception_sal (ex, *exp_string, addr_string, cond_string,
10861                             cond, ops);
10862 }
10863
10864 struct symtab_and_line
10865 ada_decode_assert_location (char *args, char **addr_string,
10866                             struct breakpoint_ops **ops)
10867 {
10868   /* Check that no argument where provided at the end of the command.  */
10869
10870   if (args != NULL)
10871     {
10872       while (isspace (*args))
10873         args++;
10874       if (*args != '\0')
10875         error (_("Junk at end of arguments."));
10876     }
10877
10878   return ada_exception_sal (ex_catch_assert, NULL, addr_string, NULL, NULL,
10879                             ops);
10880 }
10881
10882                                 /* Operators */
10883 /* Information about operators given special treatment in functions
10884    below.  */
10885 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>).  */
10886
10887 #define ADA_OPERATORS \
10888     OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10889     OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10890     OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10891     OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10892     OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10893     OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10894     OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10895     OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10896     OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10897     OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10898     OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10899     OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10900     OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10901     OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10902     OP_DEFN (UNOP_QUAL, 3, 1, 0) \
10903     OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10904     OP_DEFN (OP_OTHERS, 1, 1, 0) \
10905     OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10906     OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
10907
10908 static void
10909 ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp)
10910 {
10911   switch (exp->elts[pc - 1].opcode)
10912     {
10913     default:
10914       operator_length_standard (exp, pc, oplenp, argsp);
10915       break;
10916
10917 #define OP_DEFN(op, len, args, binop) \
10918     case op: *oplenp = len; *argsp = args; break;
10919       ADA_OPERATORS;
10920 #undef OP_DEFN
10921
10922     case OP_AGGREGATE:
10923       *oplenp = 3;
10924       *argsp = longest_to_int (exp->elts[pc - 2].longconst);
10925       break;
10926
10927     case OP_CHOICES:
10928       *oplenp = 3;
10929       *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
10930       break;
10931     }
10932 }
10933
10934 /* Implementation of the exp_descriptor method operator_check.  */
10935
10936 static int
10937 ada_operator_check (struct expression *exp, int pos,
10938                     int (*objfile_func) (struct objfile *objfile, void *data),
10939                     void *data)
10940 {
10941   const union exp_element *const elts = exp->elts;
10942   struct type *type = NULL;
10943
10944   switch (elts[pos].opcode)
10945     {
10946       case UNOP_IN_RANGE:
10947       case UNOP_QUAL:
10948         type = elts[pos + 1].type;
10949         break;
10950
10951       default:
10952         return operator_check_standard (exp, pos, objfile_func, data);
10953     }
10954
10955   /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL.  */
10956
10957   if (type && TYPE_OBJFILE (type)
10958       && (*objfile_func) (TYPE_OBJFILE (type), data))
10959     return 1;
10960
10961   return 0;
10962 }
10963
10964 static char *
10965 ada_op_name (enum exp_opcode opcode)
10966 {
10967   switch (opcode)
10968     {
10969     default:
10970       return op_name_standard (opcode);
10971
10972 #define OP_DEFN(op, len, args, binop) case op: return #op;
10973       ADA_OPERATORS;
10974 #undef OP_DEFN
10975
10976     case OP_AGGREGATE:
10977       return "OP_AGGREGATE";
10978     case OP_CHOICES:
10979       return "OP_CHOICES";
10980     case OP_NAME:
10981       return "OP_NAME";
10982     }
10983 }
10984
10985 /* As for operator_length, but assumes PC is pointing at the first
10986    element of the operator, and gives meaningful results only for the
10987    Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise.  */
10988
10989 static void
10990 ada_forward_operator_length (struct expression *exp, int pc,
10991                              int *oplenp, int *argsp)
10992 {
10993   switch (exp->elts[pc].opcode)
10994     {
10995     default:
10996       *oplenp = *argsp = 0;
10997       break;
10998
10999 #define OP_DEFN(op, len, args, binop) \
11000     case op: *oplenp = len; *argsp = args; break;
11001       ADA_OPERATORS;
11002 #undef OP_DEFN
11003
11004     case OP_AGGREGATE:
11005       *oplenp = 3;
11006       *argsp = longest_to_int (exp->elts[pc + 1].longconst);
11007       break;
11008
11009     case OP_CHOICES:
11010       *oplenp = 3;
11011       *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
11012       break;
11013
11014     case OP_STRING:
11015     case OP_NAME:
11016       {
11017         int len = longest_to_int (exp->elts[pc + 1].longconst);
11018         *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
11019         *argsp = 0;
11020         break;
11021       }
11022     }
11023 }
11024
11025 static int
11026 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
11027 {
11028   enum exp_opcode op = exp->elts[elt].opcode;
11029   int oplen, nargs;
11030   int pc = elt;
11031   int i;
11032
11033   ada_forward_operator_length (exp, elt, &oplen, &nargs);
11034
11035   switch (op)
11036     {
11037       /* Ada attributes ('Foo).  */
11038     case OP_ATR_FIRST:
11039     case OP_ATR_LAST:
11040     case OP_ATR_LENGTH:
11041     case OP_ATR_IMAGE:
11042     case OP_ATR_MAX:
11043     case OP_ATR_MIN:
11044     case OP_ATR_MODULUS:
11045     case OP_ATR_POS:
11046     case OP_ATR_SIZE:
11047     case OP_ATR_TAG:
11048     case OP_ATR_VAL:
11049       break;
11050
11051     case UNOP_IN_RANGE:
11052     case UNOP_QUAL:
11053       /* XXX: gdb_sprint_host_address, type_sprint */
11054       fprintf_filtered (stream, _("Type @"));
11055       gdb_print_host_address (exp->elts[pc + 1].type, stream);
11056       fprintf_filtered (stream, " (");
11057       type_print (exp->elts[pc + 1].type, NULL, stream, 0);
11058       fprintf_filtered (stream, ")");
11059       break;
11060     case BINOP_IN_BOUNDS:
11061       fprintf_filtered (stream, " (%d)",
11062                         longest_to_int (exp->elts[pc + 2].longconst));
11063       break;
11064     case TERNOP_IN_RANGE:
11065       break;
11066
11067     case OP_AGGREGATE:
11068     case OP_OTHERS:
11069     case OP_DISCRETE_RANGE:
11070     case OP_POSITIONAL:
11071     case OP_CHOICES:
11072       break;
11073
11074     case OP_NAME:
11075     case OP_STRING:
11076       {
11077         char *name = &exp->elts[elt + 2].string;
11078         int len = longest_to_int (exp->elts[elt + 1].longconst);
11079         fprintf_filtered (stream, "Text: `%.*s'", len, name);
11080         break;
11081       }
11082
11083     default:
11084       return dump_subexp_body_standard (exp, stream, elt);
11085     }
11086
11087   elt += oplen;
11088   for (i = 0; i < nargs; i += 1)
11089     elt = dump_subexp (exp, stream, elt);
11090
11091   return elt;
11092 }
11093
11094 /* The Ada extension of print_subexp (q.v.).  */
11095
11096 static void
11097 ada_print_subexp (struct expression *exp, int *pos,
11098                   struct ui_file *stream, enum precedence prec)
11099 {
11100   int oplen, nargs, i;
11101   int pc = *pos;
11102   enum exp_opcode op = exp->elts[pc].opcode;
11103
11104   ada_forward_operator_length (exp, pc, &oplen, &nargs);
11105
11106   *pos += oplen;
11107   switch (op)
11108     {
11109     default:
11110       *pos -= oplen;
11111       print_subexp_standard (exp, pos, stream, prec);
11112       return;
11113
11114     case OP_VAR_VALUE:
11115       fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
11116       return;
11117
11118     case BINOP_IN_BOUNDS:
11119       /* XXX: sprint_subexp */
11120       print_subexp (exp, pos, stream, PREC_SUFFIX);
11121       fputs_filtered (" in ", stream);
11122       print_subexp (exp, pos, stream, PREC_SUFFIX);
11123       fputs_filtered ("'range", stream);
11124       if (exp->elts[pc + 1].longconst > 1)
11125         fprintf_filtered (stream, "(%ld)",
11126                           (long) exp->elts[pc + 1].longconst);
11127       return;
11128
11129     case TERNOP_IN_RANGE:
11130       if (prec >= PREC_EQUAL)
11131         fputs_filtered ("(", stream);
11132       /* XXX: sprint_subexp */
11133       print_subexp (exp, pos, stream, PREC_SUFFIX);
11134       fputs_filtered (" in ", stream);
11135       print_subexp (exp, pos, stream, PREC_EQUAL);
11136       fputs_filtered (" .. ", stream);
11137       print_subexp (exp, pos, stream, PREC_EQUAL);
11138       if (prec >= PREC_EQUAL)
11139         fputs_filtered (")", stream);
11140       return;
11141
11142     case OP_ATR_FIRST:
11143     case OP_ATR_LAST:
11144     case OP_ATR_LENGTH:
11145     case OP_ATR_IMAGE:
11146     case OP_ATR_MAX:
11147     case OP_ATR_MIN:
11148     case OP_ATR_MODULUS:
11149     case OP_ATR_POS:
11150     case OP_ATR_SIZE:
11151     case OP_ATR_TAG:
11152     case OP_ATR_VAL:
11153       if (exp->elts[*pos].opcode == OP_TYPE)
11154         {
11155           if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
11156             LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
11157           *pos += 3;
11158         }
11159       else
11160         print_subexp (exp, pos, stream, PREC_SUFFIX);
11161       fprintf_filtered (stream, "'%s", ada_attribute_name (op));
11162       if (nargs > 1)
11163         {
11164           int tem;
11165           for (tem = 1; tem < nargs; tem += 1)
11166             {
11167               fputs_filtered ((tem == 1) ? " (" : ", ", stream);
11168               print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
11169             }
11170           fputs_filtered (")", stream);
11171         }
11172       return;
11173
11174     case UNOP_QUAL:
11175       type_print (exp->elts[pc + 1].type, "", stream, 0);
11176       fputs_filtered ("'(", stream);
11177       print_subexp (exp, pos, stream, PREC_PREFIX);
11178       fputs_filtered (")", stream);
11179       return;
11180
11181     case UNOP_IN_RANGE:
11182       /* XXX: sprint_subexp */
11183       print_subexp (exp, pos, stream, PREC_SUFFIX);
11184       fputs_filtered (" in ", stream);
11185       LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
11186       return;
11187
11188     case OP_DISCRETE_RANGE:
11189       print_subexp (exp, pos, stream, PREC_SUFFIX);
11190       fputs_filtered ("..", stream);
11191       print_subexp (exp, pos, stream, PREC_SUFFIX);
11192       return;
11193
11194     case OP_OTHERS:
11195       fputs_filtered ("others => ", stream);
11196       print_subexp (exp, pos, stream, PREC_SUFFIX);
11197       return;
11198
11199     case OP_CHOICES:
11200       for (i = 0; i < nargs-1; i += 1)
11201         {
11202           if (i > 0)
11203             fputs_filtered ("|", stream);
11204           print_subexp (exp, pos, stream, PREC_SUFFIX);
11205         }
11206       fputs_filtered (" => ", stream);
11207       print_subexp (exp, pos, stream, PREC_SUFFIX);
11208       return;
11209
11210     case OP_POSITIONAL:
11211       print_subexp (exp, pos, stream, PREC_SUFFIX);
11212       return;
11213
11214     case OP_AGGREGATE:
11215       fputs_filtered ("(", stream);
11216       for (i = 0; i < nargs; i += 1)
11217         {
11218           if (i > 0)
11219             fputs_filtered (", ", stream);
11220           print_subexp (exp, pos, stream, PREC_SUFFIX);
11221         }
11222       fputs_filtered (")", stream);
11223       return;
11224     }
11225 }
11226
11227 /* Table mapping opcodes into strings for printing operators
11228    and precedences of the operators.  */
11229
11230 static const struct op_print ada_op_print_tab[] = {
11231   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
11232   {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
11233   {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
11234   {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
11235   {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
11236   {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
11237   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
11238   {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
11239   {"<=", BINOP_LEQ, PREC_ORDER, 0},
11240   {">=", BINOP_GEQ, PREC_ORDER, 0},
11241   {">", BINOP_GTR, PREC_ORDER, 0},
11242   {"<", BINOP_LESS, PREC_ORDER, 0},
11243   {">>", BINOP_RSH, PREC_SHIFT, 0},
11244   {"<<", BINOP_LSH, PREC_SHIFT, 0},
11245   {"+", BINOP_ADD, PREC_ADD, 0},
11246   {"-", BINOP_SUB, PREC_ADD, 0},
11247   {"&", BINOP_CONCAT, PREC_ADD, 0},
11248   {"*", BINOP_MUL, PREC_MUL, 0},
11249   {"/", BINOP_DIV, PREC_MUL, 0},
11250   {"rem", BINOP_REM, PREC_MUL, 0},
11251   {"mod", BINOP_MOD, PREC_MUL, 0},
11252   {"**", BINOP_EXP, PREC_REPEAT, 0},
11253   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
11254   {"-", UNOP_NEG, PREC_PREFIX, 0},
11255   {"+", UNOP_PLUS, PREC_PREFIX, 0},
11256   {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
11257   {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
11258   {"abs ", UNOP_ABS, PREC_PREFIX, 0},
11259   {".all", UNOP_IND, PREC_SUFFIX, 1},
11260   {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
11261   {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
11262   {NULL, 0, 0, 0}
11263 };
11264 \f
11265 enum ada_primitive_types {
11266   ada_primitive_type_int,
11267   ada_primitive_type_long,
11268   ada_primitive_type_short,
11269   ada_primitive_type_char,
11270   ada_primitive_type_float,
11271   ada_primitive_type_double,
11272   ada_primitive_type_void,
11273   ada_primitive_type_long_long,
11274   ada_primitive_type_long_double,
11275   ada_primitive_type_natural,
11276   ada_primitive_type_positive,
11277   ada_primitive_type_system_address,
11278   nr_ada_primitive_types
11279 };
11280
11281 static void
11282 ada_language_arch_info (struct gdbarch *gdbarch,
11283                         struct language_arch_info *lai)
11284 {
11285   const struct builtin_type *builtin = builtin_type (gdbarch);
11286   lai->primitive_type_vector
11287     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
11288                               struct type *);
11289
11290   lai->primitive_type_vector [ada_primitive_type_int]
11291     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
11292                          0, "integer");
11293   lai->primitive_type_vector [ada_primitive_type_long]
11294     = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
11295                          0, "long_integer");
11296   lai->primitive_type_vector [ada_primitive_type_short]
11297     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
11298                          0, "short_integer");
11299   lai->string_char_type
11300     = lai->primitive_type_vector [ada_primitive_type_char]
11301     = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
11302   lai->primitive_type_vector [ada_primitive_type_float]
11303     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
11304                        "float", NULL);
11305   lai->primitive_type_vector [ada_primitive_type_double]
11306     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
11307                        "long_float", NULL);
11308   lai->primitive_type_vector [ada_primitive_type_long_long]
11309     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
11310                          0, "long_long_integer");
11311   lai->primitive_type_vector [ada_primitive_type_long_double]
11312     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
11313                        "long_long_float", NULL);
11314   lai->primitive_type_vector [ada_primitive_type_natural]
11315     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
11316                          0, "natural");
11317   lai->primitive_type_vector [ada_primitive_type_positive]
11318     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
11319                          0, "positive");
11320   lai->primitive_type_vector [ada_primitive_type_void]
11321     = builtin->builtin_void;
11322
11323   lai->primitive_type_vector [ada_primitive_type_system_address]
11324     = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
11325   TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
11326     = "system__address";
11327
11328   lai->bool_type_symbol = NULL;
11329   lai->bool_type_default = builtin->builtin_bool;
11330 }
11331 \f
11332                                 /* Language vector */
11333
11334 /* Not really used, but needed in the ada_language_defn.  */
11335
11336 static void
11337 emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
11338 {
11339   ada_emit_char (c, type, stream, quoter, 1);
11340 }
11341
11342 static int
11343 parse (void)
11344 {
11345   warnings_issued = 0;
11346   return ada_parse ();
11347 }
11348
11349 static const struct exp_descriptor ada_exp_descriptor = {
11350   ada_print_subexp,
11351   ada_operator_length,
11352   ada_operator_check,
11353   ada_op_name,
11354   ada_dump_subexp_body,
11355   ada_evaluate_subexp
11356 };
11357
11358 const struct language_defn ada_language_defn = {
11359   "ada",                        /* Language name */
11360   language_ada,
11361   range_check_off,
11362   type_check_off,
11363   case_sensitive_on,            /* Yes, Ada is case-insensitive, but
11364                                    that's not quite what this means.  */
11365   array_row_major,
11366   macro_expansion_no,
11367   &ada_exp_descriptor,
11368   parse,
11369   ada_error,
11370   resolve,
11371   ada_printchar,                /* Print a character constant */
11372   ada_printstr,                 /* Function to print string constant */
11373   emit_char,                    /* Function to print single char (not used) */
11374   ada_print_type,               /* Print a type using appropriate syntax */
11375   ada_print_typedef,            /* Print a typedef using appropriate syntax */
11376   ada_val_print,                /* Print a value using appropriate syntax */
11377   ada_value_print,              /* Print a top-level value */
11378   NULL,                         /* Language specific skip_trampoline */
11379   NULL,                         /* name_of_this */
11380   ada_lookup_symbol_nonlocal,   /* Looking up non-local symbols.  */
11381   basic_lookup_transparent_type,        /* lookup_transparent_type */
11382   ada_la_decode,                /* Language specific symbol demangler */
11383   NULL,                         /* Language specific class_name_from_physname */
11384   ada_op_print_tab,             /* expression operators for printing */
11385   0,                            /* c-style arrays */
11386   1,                            /* String lower bound */
11387   ada_get_gdb_completer_word_break_characters,
11388   ada_make_symbol_completion_list,
11389   ada_language_arch_info,
11390   ada_print_array_index,
11391   default_pass_by_reference,
11392   c_get_string,
11393   LANG_MAGIC
11394 };
11395
11396 /* Provide a prototype to silence -Wmissing-prototypes.  */
11397 extern initialize_file_ftype _initialize_ada_language;
11398
11399 /* Command-list for the "set/show ada" prefix command.  */
11400 static struct cmd_list_element *set_ada_list;
11401 static struct cmd_list_element *show_ada_list;
11402
11403 /* Implement the "set ada" prefix command.  */
11404
11405 static void
11406 set_ada_command (char *arg, int from_tty)
11407 {
11408   printf_unfiltered (_(\
11409 "\"set ada\" must be followed by the name of a setting.\n"));
11410   help_list (set_ada_list, "set ada ", -1, gdb_stdout);
11411 }
11412
11413 /* Implement the "show ada" prefix command.  */
11414
11415 static void
11416 show_ada_command (char *args, int from_tty)
11417 {
11418   cmd_show_list (show_ada_list, from_tty, "");
11419 }
11420
11421 void
11422 _initialize_ada_language (void)
11423 {
11424   add_language (&ada_language_defn);
11425
11426   add_prefix_cmd ("ada", no_class, set_ada_command,
11427                   _("Prefix command for changing Ada-specfic settings"),
11428                   &set_ada_list, "set ada ", 0, &setlist);
11429
11430   add_prefix_cmd ("ada", no_class, show_ada_command,
11431                   _("Generic command for showing Ada-specific settings."),
11432                   &show_ada_list, "show ada ", 0, &showlist);
11433
11434   add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
11435                            &trust_pad_over_xvs, _("\
11436 Enable or disable an optimization trusting PAD types over XVS types"), _("\
11437 Show whether an optimization trusting PAD types over XVS types is activated"),
11438                            _("\
11439 This is related to the encoding used by the GNAT compiler.  The debugger\n\
11440 should normally trust the contents of PAD types, but certain older versions\n\
11441 of GNAT have a bug that sometimes causes the information in the PAD type\n\
11442 to be incorrect.  Turning this setting \"off\" allows the debugger to\n\
11443 work around this bug.  It is always safe to turn this option \"off\", but\n\
11444 this incurs a slight performance penalty, so it is recommended to NOT change\n\
11445 this option to \"off\" unless necessary."),
11446                             NULL, NULL, &set_ada_list, &show_ada_list);
11447
11448   varsize_limit = 65536;
11449
11450   obstack_init (&symbol_list_obstack);
11451
11452   decoded_names_store = htab_create_alloc
11453     (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
11454      NULL, xcalloc, xfree);
11455
11456   observer_attach_executable_changed (ada_executable_changed_observer);
11457 }