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