gdb/ada-lang.c

   1 /* Ada language support routines for GDB, the GNU debugger.  Copyright
   2    1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004
   3    Free Software Foundation, Inc.
   4
   5 This file is part of GDB.
   6
   7 This program is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2 of the License, or
  10 (at your option) any later version.
  11
  12 This program is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with this program; if not, write to the Free Software
  19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  20
  21 #include <stdio.h>
  22 #include "gdb_string.h"
  23 #include <ctype.h>
  24 #include <stdarg.h>
  25 #include "demangle.h"
  26 #include "defs.h"
  27 #include "symtab.h"
  28 #include "gdbtypes.h"
  29 #include "gdbcmd.h"
  30 #include "expression.h"
  31 #include "parser-defs.h"
  32 #include "language.h"
  33 #include "c-lang.h"
  34 #include "inferior.h"
  35 #include "symfile.h"
  36 #include "objfiles.h"
  37 #include "breakpoint.h"
  38 #include "gdbcore.h"
  39 #include "ada-lang.h"
  40 #include "ui-out.h"
  41 #include "block.h"
  42 #include "infcall.h"
  43 #include "dictionary.h"
  44
  45 struct cleanup *unresolved_names;
  46
  47 void extract_string (CORE_ADDR addr, char *buf);
  48
  49 static struct type *ada_create_fundamental_type (struct objfile *, int);
  50
  51 static void modify_general_field (char *, LONGEST, int, int);
  52
  53 static struct type *desc_base_type (struct type *);
  54
  55 static struct type *desc_bounds_type (struct type *);
  56
  57 static struct value *desc_bounds (struct value *);
  58
  59 static int fat_pntr_bounds_bitpos (struct type *);
  60
  61 static int fat_pntr_bounds_bitsize (struct type *);
  62
  63 static struct type *desc_data_type (struct type *);
  64
  65 static struct value *desc_data (struct value *);
  66
  67 static int fat_pntr_data_bitpos (struct type *);
  68
  69 static int fat_pntr_data_bitsize (struct type *);
  70
  71 static struct value *desc_one_bound (struct value *, int, int);
  72
  73 static int desc_bound_bitpos (struct type *, int, int);
  74
  75 static int desc_bound_bitsize (struct type *, int, int);
  76
  77 static struct type *desc_index_type (struct type *, int);
  78
  79 static int desc_arity (struct type *);
  80
  81 static int ada_type_match (struct type *, struct type *, int);
  82
  83 static int ada_args_match (struct symbol *, struct value **, int);
  84
  85 static struct value *place_on_stack (struct value *, CORE_ADDR *);
  86
  87 static struct value *convert_actual (struct value *, struct type *,
  88                                      CORE_ADDR *);
  89
  90 static struct value *make_array_descriptor (struct type *, struct value *,
  91                                             CORE_ADDR *);
  92
  93 static void ada_add_block_symbols (struct block *, const char *,
  94                                    domain_enum, struct objfile *, int);
  95
  96 static void fill_in_ada_prototype (struct symbol *);
  97
  98 static int is_nonfunction (struct symbol **, int);
  99
 100 static void add_defn_to_vec (struct symbol *, struct block *);
 101
 102 static struct partial_symbol *ada_lookup_partial_symbol (struct partial_symtab
 103                                                          *, const char *, int,
 104                                                          domain_enum, int);
 105
 106 static struct symtab *symtab_for_sym (struct symbol *);
 107
 108 static struct value *ada_resolve_subexp (struct expression **, int *, int,
 109                                          struct type *);
 110
 111 static void replace_operator_with_call (struct expression **, int, int, int,
 112                                         struct symbol *, struct block *);
 113
 114 static int possible_user_operator_p (enum exp_opcode, struct value **);
 115
 116 static const char *ada_op_name (enum exp_opcode);
 117
 118 static int numeric_type_p (struct type *);
 119
 120 static int integer_type_p (struct type *);
 121
 122 static int scalar_type_p (struct type *);
 123
 124 static int discrete_type_p (struct type *);
 125
 126 static char *extended_canonical_line_spec (struct symtab_and_line,
 127                                            const char *);
 128
 129 static struct value *evaluate_subexp (struct type *, struct expression *,
 130                                       int *, enum noside);
 131
 132 static struct value *evaluate_subexp_type (struct expression *, int *);
 133
 134 static struct type *ada_create_fundamental_type (struct objfile *, int);
 135
 136 static int is_dynamic_field (struct type *, int);
 137
 138 static struct type *to_fixed_variant_branch_type (struct type *, char *,
 139                                                   CORE_ADDR, struct value *);
 140
 141 static struct type *to_fixed_range_type (char *, struct value *,
 142                                          struct objfile *);
 143
 144 static struct type *to_static_fixed_type (struct type *);
 145
 146 static struct value *unwrap_value (struct value *);
 147
 148 static struct type *packed_array_type (struct type *, long *);
 149
 150 static struct type *decode_packed_array_type (struct type *);
 151
 152 static struct value *decode_packed_array (struct value *);
 153
 154 static struct value *value_subscript_packed (struct value *, int,
 155                                              struct value **);
 156
 157 static struct value *coerce_unspec_val_to_type (struct value *, long,
 158                                                 struct type *);
 159
 160 static struct value *get_var_value (char *, char *);
 161
 162 static int lesseq_defined_than (struct symbol *, struct symbol *);
 163
 164 static int equiv_types (struct type *, struct type *);
 165
 166 static int is_name_suffix (const char *);
 167
 168 static int wild_match (const char *, int, const char *);
 169
 170 static struct symtabs_and_lines find_sal_from_funcs_and_line (const char *,
 171                                                               int,
 172                                                               struct symbol
 173                                                               **, int);
 174
 175 static int find_line_in_linetable (struct linetable *, int, struct symbol **,
 176                                    int, int *);
 177
 178 static int find_next_line_in_linetable (struct linetable *, int, int, int);
 179
 180 static struct symtabs_and_lines all_sals_for_line (const char *, int,
 181                                                    char ***);
 182
 183 static void read_all_symtabs (const char *);
 184
 185 static int is_plausible_func_for_line (struct symbol *, int);
 186
 187 static struct value *ada_coerce_ref (struct value *);
 188
 189 static struct value *value_pos_atr (struct value *);
 190
 191 static struct value *value_val_atr (struct type *, struct value *);
 192
 193 static struct symbol *standard_lookup (const char *, domain_enum);
 194
 195 extern void markTimeStart (int index);
 196 extern void markTimeStop (int index);
 197 \f
 198
 199
 200 /* Maximum-sized dynamic type. */
 201 static unsigned int varsize_limit;
 202
 203 static const char *ada_completer_word_break_characters =
 204   " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
 205
 206 /* The name of the symbol to use to get the name of the main subprogram */
 207 #define ADA_MAIN_PROGRAM_SYMBOL_NAME "__gnat_ada_main_program_name"
 208
 209                                 /* Utilities */
 210
 211 /* extract_string
 212  *
 213  * read the string located at ADDR from the inferior and store the
 214  * result into BUF
 215  */
 216 void
 217 extract_string (CORE_ADDR addr, char *buf)
 218 {
 219   int char_index = 0;
 220
 221   /* Loop, reading one byte at a time, until we reach the '\000'
 222      end-of-string marker */
 223   do
 224     {
 225       target_read_memory (addr + char_index * sizeof (char),
 226                           buf + char_index * sizeof (char), sizeof (char));
 227       char_index++;
 228     }
 229   while (buf[char_index - 1] != '\000');
 230 }
 231
 232 /* Assuming *OLD_VECT points to an array of *SIZE objects of size
 233    ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
 234    updating *OLD_VECT and *SIZE as necessary. */
 235
 236 void
 237 grow_vect (void **old_vect, size_t * size, size_t min_size, int element_size)
 238 {
 239   if (*size < min_size)
 240     {
 241       *size *= 2;
 242       if (*size < min_size)
 243         *size = min_size;
 244       *old_vect = xrealloc (*old_vect, *size * element_size);
 245     }
 246 }
 247
 248 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
 249    suffix of FIELD_NAME beginning "___" */
 250
 251 static int
 252 field_name_match (const char *field_name, const char *target)
 253 {
 254   int len = strlen (target);
 255   return
 256     DEPRECATED_STREQN (field_name, target, len)
 257     && (field_name[len] == '\0'
 258         || (DEPRECATED_STREQN (field_name + len, "___", 3)
 259             && !DEPRECATED_STREQ (field_name + strlen (field_name) - 6, "___XVN")));
 260 }
 261
 262
 263 /* The length of the prefix of NAME prior to any "___" suffix. */
 264
 265 int
 266 ada_name_prefix_len (const char *name)
 267 {
 268   if (name == NULL)
 269     return 0;
 270   else
 271     {
 272       const char *p = strstr (name, "___");
 273       if (p == NULL)
 274         return strlen (name);
 275       else
 276         return p - name;
 277     }
 278 }
 279
 280 /* SUFFIX is a suffix of STR. False if STR is null. */
 281 static int
 282 is_suffix (const char *str, const char *suffix)
 283 {
 284   int len1, len2;
 285   if (str == NULL)
 286     return 0;
 287   len1 = strlen (str);
 288   len2 = strlen (suffix);
 289   return (len1 >= len2 && DEPRECATED_STREQ (str + len1 - len2, suffix));
 290 }
 291
 292 /* Create a value of type TYPE whose contents come from VALADDR, if it
 293  * is non-null, and whose memory address (in the inferior) is
 294  * ADDRESS. */
 295 struct value *
 296 value_from_contents_and_address (struct type *type, char *valaddr,
 297                                  CORE_ADDR address)
 298 {
 299   struct value *v = allocate_value (type);
 300   if (valaddr == NULL)
 301     VALUE_LAZY (v) = 1;
 302   else
 303     memcpy (VALUE_CONTENTS_RAW (v), valaddr, TYPE_LENGTH (type));
 304   VALUE_ADDRESS (v) = address;
 305   if (address != 0)
 306     VALUE_LVAL (v) = lval_memory;
 307   return v;
 308 }
 309
 310 /* The contents of value VAL, beginning at offset OFFSET, treated as a
 311    value of type TYPE.  The result is an lval in memory if VAL is. */
 312
 313 static struct value *
 314 coerce_unspec_val_to_type (struct value *val, long offset, struct type *type)
 315 {
 316   CHECK_TYPEDEF (type);
 317   if (VALUE_LVAL (val) == lval_memory)
 318     return value_at_lazy (type,
 319                           VALUE_ADDRESS (val) + VALUE_OFFSET (val) + offset,
 320                           NULL);
 321   else
 322     {
 323       struct value *result = allocate_value (type);
 324       VALUE_LVAL (result) = not_lval;
 325       if (VALUE_ADDRESS (val) == 0)
 326         memcpy (VALUE_CONTENTS_RAW (result), VALUE_CONTENTS (val) + offset,
 327                 TYPE_LENGTH (type) > TYPE_LENGTH (VALUE_TYPE (val))
 328                 ? TYPE_LENGTH (VALUE_TYPE (val)) : TYPE_LENGTH (type));
 329       else
 330         {
 331           VALUE_ADDRESS (result) =
 332             VALUE_ADDRESS (val) + VALUE_OFFSET (val) + offset;
 333           VALUE_LAZY (result) = 1;
 334         }
 335       return result;
 336     }
 337 }
 338
 339 static char *
 340 cond_offset_host (char *valaddr, long offset)
 341 {
 342   if (valaddr == NULL)
 343     return NULL;
 344   else
 345     return valaddr + offset;
 346 }
 347
 348 static CORE_ADDR
 349 cond_offset_target (CORE_ADDR address, long offset)
 350 {
 351   if (address == 0)
 352     return 0;
 353   else
 354     return address + offset;
 355 }
 356
 357 /* Perform execute_command on the result of concatenating all
 358    arguments up to NULL. */
 359 static void
 360 do_command (const char *arg, ...)
 361 {
 362   int len;
 363   char *cmd;
 364   const char *s;
 365   va_list ap;
 366
 367   va_start (ap, arg);
 368   len = 0;
 369   s = arg;
 370   cmd = "";
 371   for (; s != NULL; s = va_arg (ap, const char *))
 372     {
 373       char *cmd1;
 374       len += strlen (s);
 375       cmd1 = alloca (len + 1);
 376       strcpy (cmd1, cmd);
 377       strcat (cmd1, s);
 378       cmd = cmd1;
 379     }
 380   va_end (ap);
 381   execute_command (cmd, 0);
 382 }
 383 \f
 384
 385                                 /* Language Selection */
 386
 387 /* If the main program is in Ada, return language_ada, otherwise return LANG
 388    (the main program is in Ada iif the adainit symbol is found).
 389
 390    MAIN_PST is not used. */
 391
 392 enum language
 393 ada_update_initial_language (enum language lang,
 394                              struct partial_symtab *main_pst)
 395 {
 396   if (lookup_minimal_symbol ("adainit", (const char *) NULL,
 397                              (struct objfile *) NULL) != NULL)
 398     /*    return language_ada; */
 399     /* FIXME: language_ada should be defined in defs.h */
 400     return language_unknown;
 401
 402   return lang;
 403 }
 404 \f
 405
 406                                 /* Symbols */
 407
 408 /* Table of Ada operators and their GNAT-mangled names.  Last entry is pair
 409    of NULLs. */
 410
 411 const struct ada_opname_map ada_opname_table[] = {
 412   {"Oadd", "\"+\"", BINOP_ADD},
 413   {"Osubtract", "\"-\"", BINOP_SUB},
 414   {"Omultiply", "\"*\"", BINOP_MUL},
 415   {"Odivide", "\"/\"", BINOP_DIV},
 416   {"Omod", "\"mod\"", BINOP_MOD},
 417   {"Orem", "\"rem\"", BINOP_REM},
 418   {"Oexpon", "\"**\"", BINOP_EXP},
 419   {"Olt", "\"<\"", BINOP_LESS},
 420   {"Ole", "\"<=\"", BINOP_LEQ},
 421   {"Ogt", "\">\"", BINOP_GTR},
 422   {"Oge", "\">=\"", BINOP_GEQ},
 423   {"Oeq", "\"=\"", BINOP_EQUAL},
 424   {"One", "\"/=\"", BINOP_NOTEQUAL},
 425   {"Oand", "\"and\"", BINOP_BITWISE_AND},
 426   {"Oor", "\"or\"", BINOP_BITWISE_IOR},
 427   {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
 428   {"Oconcat", "\"&\"", BINOP_CONCAT},
 429   {"Oabs", "\"abs\"", UNOP_ABS},
 430   {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
 431   {"Oadd", "\"+\"", UNOP_PLUS},
 432   {"Osubtract", "\"-\"", UNOP_NEG},
 433   {NULL, NULL}
 434 };
 435
 436 /* True if STR should be suppressed in info listings. */
 437 static int
 438 is_suppressed_name (const char *str)
 439 {
 440   if (DEPRECATED_STREQN (str, "_ada_", 5))
 441     str += 5;
 442   if (str[0] == '_' || str[0] == '\000')
 443     return 1;
 444   else
 445     {
 446       const char *p;
 447       const char *suffix = strstr (str, "___");
 448       if (suffix != NULL && suffix[3] != 'X')
 449         return 1;
 450       if (suffix == NULL)
 451         suffix = str + strlen (str);
 452       for (p = suffix - 1; p != str; p -= 1)
 453         if (isupper (*p))
 454           {
 455             int i;
 456             if (p[0] == 'X' && p[-1] != '_')
 457               goto OK;
 458             if (*p != 'O')
 459               return 1;
 460             for (i = 0; ada_opname_table[i].mangled != NULL; i += 1)
 461               if (DEPRECATED_STREQN (ada_opname_table[i].mangled, p,
 462                           strlen (ada_opname_table[i].mangled)))
 463                 goto OK;
 464             return 1;
 465           OK:;
 466           }
 467       return 0;
 468     }
 469 }
 470
 471 /* The "mangled" form of DEMANGLED, according to GNAT conventions.
 472  * The result is valid until the next call to ada_mangle. */
 473 char *
 474 ada_mangle (const char *demangled)
 475 {
 476   static char *mangling_buffer = NULL;
 477   static size_t mangling_buffer_size = 0;
 478   const char *p;
 479   int k;
 480
 481   if (demangled == NULL)
 482     return NULL;
 483
 484   GROW_VECT (mangling_buffer, mangling_buffer_size,
 485              2 * strlen (demangled) + 10);
 486
 487   k = 0;
 488   for (p = demangled; *p != '\0'; p += 1)
 489     {
 490       if (*p == '.')
 491         {
 492           mangling_buffer[k] = mangling_buffer[k + 1] = '_';
 493           k += 2;
 494         }
 495       else if (*p == '"')
 496         {
 497           const struct ada_opname_map *mapping;
 498
 499           for (mapping = ada_opname_table;
 500                mapping->mangled != NULL &&
 501                !DEPRECATED_STREQN (mapping->demangled, p, strlen (mapping->demangled));
 502                p += 1)
 503             ;
 504           if (mapping->mangled == NULL)
 505             error ("invalid Ada operator name: %s", p);
 506           strcpy (mangling_buffer + k, mapping->mangled);
 507           k += strlen (mapping->mangled);
 508           break;
 509         }
 510       else
 511         {
 512           mangling_buffer[k] = *p;
 513           k += 1;
 514         }
 515     }
 516
 517   mangling_buffer[k] = '\0';
 518   return mangling_buffer;
 519 }
 520
 521 /* Return NAME folded to lower case, or, if surrounded by single
 522  * quotes, unfolded, but with the quotes stripped away.  Result good
 523  * to next call. */
 524 char *
 525 ada_fold_name (const char *name)
 526 {
 527   static char *fold_buffer = NULL;
 528   static size_t fold_buffer_size = 0;
 529
 530   int len = strlen (name);
 531   GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
 532
 533   if (name[0] == '\'')
 534     {
 535       strncpy (fold_buffer, name + 1, len - 2);
 536       fold_buffer[len - 2] = '\000';
 537     }
 538   else
 539     {
 540       int i;
 541       for (i = 0; i <= len; i += 1)
 542         fold_buffer[i] = tolower (name[i]);
 543     }
 544
 545   return fold_buffer;
 546 }
 547
 548 /* Demangle:
 549      1. Discard final __{DIGIT}+ or ${DIGIT}+
 550      2. Convert other instances of embedded "__" to `.'.
 551      3. Discard leading _ada_.
 552      4. Convert operator names to the appropriate quoted symbols.
 553      5. Remove everything after first ___ if it is followed by
 554         'X'.
 555      6. Replace TK__ with __, and a trailing B or TKB with nothing.
 556      7. Put symbols that should be suppressed in <...> brackets.
 557      8. Remove trailing X[bn]* suffix (indicating names in package bodies).
 558    The resulting string is valid until the next call of ada_demangle.
 559   */
 560
 561 char *
 562 ada_demangle (const char *mangled)
 563 {
 564   int i, j;
 565   int len0;
 566   const char *p;
 567   char *demangled;
 568   int at_start_name;
 569   static char *demangling_buffer = NULL;
 570   static size_t demangling_buffer_size = 0;
 571
 572   if (DEPRECATED_STREQN (mangled, "_ada_", 5))
 573     mangled += 5;
 574
 575   if (mangled[0] == '_' || mangled[0] == '<')
 576     goto Suppress;
 577
 578   p = strstr (mangled, "___");
 579   if (p == NULL)
 580     len0 = strlen (mangled);
 581   else
 582     {
 583       if (p[3] == 'X')
 584         len0 = p - mangled;
 585       else
 586         goto Suppress;
 587     }
 588   if (len0 > 3 && DEPRECATED_STREQ (mangled + len0 - 3, "TKB"))
 589     len0 -= 3;
 590   if (len0 > 1 && DEPRECATED_STREQ (mangled + len0 - 1, "B"))
 591     len0 -= 1;
 592
 593   /* Make demangled big enough for possible expansion by operator name. */
 594   GROW_VECT (demangling_buffer, demangling_buffer_size, 2 * len0 + 1);
 595   demangled = demangling_buffer;
 596
 597   if (isdigit (mangled[len0 - 1]))
 598     {
 599       for (i = len0 - 2; i >= 0 && isdigit (mangled[i]); i -= 1)
 600         ;
 601       if (i > 1 && mangled[i] == '_' && mangled[i - 1] == '_')
 602         len0 = i - 1;
 603       else if (mangled[i] == '$')
 604         len0 = i;
 605     }
 606
 607   for (i = 0, j = 0; i < len0 && !isalpha (mangled[i]); i += 1, j += 1)
 608     demangled[j] = mangled[i];
 609
 610   at_start_name = 1;
 611   while (i < len0)
 612     {
 613       if (at_start_name && mangled[i] == 'O')
 614         {
 615           int k;
 616           for (k = 0; ada_opname_table[k].mangled != NULL; k += 1)
 617             {
 618               int op_len = strlen (ada_opname_table[k].mangled);
 619               if (DEPRECATED_STREQN
 620                   (ada_opname_table[k].mangled + 1, mangled + i + 1,
 621                    op_len - 1) && !isalnum (mangled[i + op_len]))
 622                 {
 623                   strcpy (demangled + j, ada_opname_table[k].demangled);
 624                   at_start_name = 0;
 625                   i += op_len;
 626                   j += strlen (ada_opname_table[k].demangled);
 627                   break;
 628                 }
 629             }
 630           if (ada_opname_table[k].mangled != NULL)
 631             continue;
 632         }
 633       at_start_name = 0;
 634
 635       if (i < len0 - 4 && DEPRECATED_STREQN (mangled + i, "TK__", 4))
 636         i += 2;
 637       if (mangled[i] == 'X' && i != 0 && isalnum (mangled[i - 1]))
 638         {
 639           do
 640             i += 1;
 641           while (i < len0 && (mangled[i] == 'b' || mangled[i] == 'n'));
 642           if (i < len0)
 643             goto Suppress;
 644         }
 645       else if (i < len0 - 2 && mangled[i] == '_' && mangled[i + 1] == '_')
 646         {
 647           demangled[j] = '.';
 648           at_start_name = 1;
 649           i += 2;
 650           j += 1;
 651         }
 652       else
 653         {
 654           demangled[j] = mangled[i];
 655           i += 1;
 656           j += 1;
 657         }
 658     }
 659   demangled[j] = '\000';
 660
 661   for (i = 0; demangled[i] != '\0'; i += 1)
 662     if (isupper (demangled[i]) || demangled[i] == ' ')
 663       goto Suppress;
 664
 665   return demangled;
 666
 667 Suppress:
 668   GROW_VECT (demangling_buffer, demangling_buffer_size, strlen (mangled) + 3);
 669   demangled = demangling_buffer;
 670   if (mangled[0] == '<')
 671     strcpy (demangled, mangled);
 672   else
 673     sprintf (demangled, "<%s>", mangled);
 674   return demangled;
 675
 676 }
 677
 678 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
 679  * suffixes that encode debugging information or leading _ada_ on
 680  * SYM_NAME (see is_name_suffix commentary for the debugging
 681  * information that is ignored).  If WILD, then NAME need only match a
 682  * suffix of SYM_NAME minus the same suffixes. Also returns 0 if
 683  * either argument is NULL. */
 684
 685 int
 686 ada_match_name (const char *sym_name, const char *name, int wild)
 687 {
 688   if (sym_name == NULL || name == NULL)
 689     return 0;
 690   else if (wild)
 691     return wild_match (name, strlen (name), sym_name);
 692   else
 693     {
 694       int len_name = strlen (name);
 695       return (DEPRECATED_STREQN (sym_name, name, len_name)
 696               && is_name_suffix (sym_name + len_name))
 697         || (DEPRECATED_STREQN (sym_name, "_ada_", 5)
 698             && DEPRECATED_STREQN (sym_name + 5, name, len_name)
 699             && is_name_suffix (sym_name + len_name + 5));
 700     }
 701 }
 702
 703 /* True (non-zero) iff in Ada mode, the symbol SYM should be
 704    suppressed in info listings. */
 705
 706 int
 707 ada_suppress_symbol_printing (struct symbol *sym)
 708 {
 709   if (SYMBOL_DOMAIN (sym) == STRUCT_DOMAIN)
 710     return 1;
 711   else
 712     return is_suppressed_name (DEPRECATED_SYMBOL_NAME (sym));
 713 }
 714 \f
 715
 716                                 /* Arrays */
 717
 718 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of
 719    array descriptors.  */
 720
 721 static char *bound_name[] = {
 722   "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
 723   "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
 724 };
 725
 726 /* Maximum number of array dimensions we are prepared to handle.  */
 727
 728 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char*)))
 729
 730 /* Like modify_field, but allows bitpos > wordlength. */
 731
 732 static void
 733 modify_general_field (char *addr, LONGEST fieldval, int bitpos, int bitsize)
 734 {
 735   modify_field (addr + sizeof (LONGEST) * bitpos / (8 * sizeof (LONGEST)),
 736                 fieldval, bitpos % (8 * sizeof (LONGEST)), bitsize);
 737 }
 738
 739
 740 /* The desc_* routines return primitive portions of array descriptors
 741    (fat pointers). */
 742
 743 /* The descriptor or array type, if any, indicated by TYPE; removes
 744    level of indirection, if needed. */
 745 static struct type *
 746 desc_base_type (struct type *type)
 747 {
 748   if (type == NULL)
 749     return NULL;
 750   CHECK_TYPEDEF (type);
 751   if (type != NULL && TYPE_CODE (type) == TYPE_CODE_PTR)
 752     return check_typedef (TYPE_TARGET_TYPE (type));
 753   else
 754     return type;
 755 }
 756
 757 /* True iff TYPE indicates a "thin" array pointer type. */
 758 static int
 759 is_thin_pntr (struct type *type)
 760 {
 761   return
 762     is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
 763     || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
 764 }
 765
 766 /* The descriptor type for thin pointer type TYPE. */
 767 static struct type *
 768 thin_descriptor_type (struct type *type)
 769 {
 770   struct type *base_type = desc_base_type (type);
 771   if (base_type == NULL)
 772     return NULL;
 773   if (is_suffix (ada_type_name (base_type), "___XVE"))
 774     return base_type;
 775   else
 776     {
 777       struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
 778       if (alt_type == NULL)
 779         return base_type;
 780       else
 781         return alt_type;
 782     }
 783 }
 784
 785 /* A pointer to the array data for thin-pointer value VAL. */
 786 static struct value *
 787 thin_data_pntr (struct value *val)
 788 {
 789   struct type *type = VALUE_TYPE (val);
 790   if (TYPE_CODE (type) == TYPE_CODE_PTR)
 791     return value_cast (desc_data_type (thin_descriptor_type (type)),
 792                        value_copy (val));
 793   else
 794     return value_from_longest (desc_data_type (thin_descriptor_type (type)),
 795                                VALUE_ADDRESS (val) + VALUE_OFFSET (val));
 796 }
 797
 798 /* True iff TYPE indicates a "thick" array pointer type. */
 799 static int
 800 is_thick_pntr (struct type *type)
 801 {
 802   type = desc_base_type (type);
 803   return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
 804           && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
 805 }
 806
 807 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
 808    pointer to one, the type of its bounds data; otherwise, NULL. */
 809 static struct type *
 810 desc_bounds_type (struct type *type)
 811 {
 812   struct type *r;
 813
 814   type = desc_base_type (type);
 815
 816   if (type == NULL)
 817     return NULL;
 818   else if (is_thin_pntr (type))
 819     {
 820       type = thin_descriptor_type (type);
 821       if (type == NULL)
 822         return NULL;
 823       r = lookup_struct_elt_type (type, "BOUNDS", 1);
 824       if (r != NULL)
 825         return check_typedef (r);
 826     }
 827   else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
 828     {
 829       r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
 830       if (r != NULL)
 831         return check_typedef (TYPE_TARGET_TYPE (check_typedef (r)));
 832     }
 833   return NULL;
 834 }
 835
 836 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
 837    one, a pointer to its bounds data.   Otherwise NULL. */
 838 static struct value *
 839 desc_bounds (struct value *arr)
 840 {
 841   struct type *type = check_typedef (VALUE_TYPE (arr));
 842   if (is_thin_pntr (type))
 843     {
 844       struct type *bounds_type =
 845         desc_bounds_type (thin_descriptor_type (type));
 846       LONGEST addr;
 847
 848       if (desc_bounds_type == NULL)
 849         error ("Bad GNAT array descriptor");
 850
 851       /* NOTE: The following calculation is not really kosher, but
 852          since desc_type is an XVE-encoded type (and shouldn't be),
 853          the correct calculation is a real pain. FIXME (and fix GCC). */
 854       if (TYPE_CODE (type) == TYPE_CODE_PTR)
 855         addr = value_as_long (arr);
 856       else
 857         addr = VALUE_ADDRESS (arr) + VALUE_OFFSET (arr);
 858
 859       return
 860         value_from_longest (lookup_pointer_type (bounds_type),
 861                             addr - TYPE_LENGTH (bounds_type));
 862     }
 863
 864   else if (is_thick_pntr (type))
 865     return value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
 866                              "Bad GNAT array descriptor");
 867   else
 868     return NULL;
 869 }
 870
 871 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
 872    position of the field containing the address of the bounds data. */
 873 static int
 874 fat_pntr_bounds_bitpos (struct type *type)
 875 {
 876   return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
 877 }
 878
 879 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
 880    size of the field containing the address of the bounds data. */
 881 static int
 882 fat_pntr_bounds_bitsize (struct type *type)
 883 {
 884   type = desc_base_type (type);
 885
 886   if (TYPE_FIELD_BITSIZE (type, 1) > 0)
 887     return TYPE_FIELD_BITSIZE (type, 1);
 888   else
 889     return 8 * TYPE_LENGTH (check_typedef (TYPE_FIELD_TYPE (type, 1)));
 890 }
 891
 892 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
 893    pointer to one, the type of its array data (a
 894    pointer-to-array-with-no-bounds type); otherwise,  NULL.  Use
 895    ada_type_of_array to get an array type with bounds data. */
 896 static struct type *
 897 desc_data_type (struct type *type)
 898 {
 899   type = desc_base_type (type);
 900
 901   /* NOTE: The following is bogus; see comment in desc_bounds. */
 902   if (is_thin_pntr (type))
 903     return lookup_pointer_type
 904       (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)));
 905   else if (is_thick_pntr (type))
 906     return lookup_struct_elt_type (type, "P_ARRAY", 1);
 907   else
 908     return NULL;
 909 }
 910
 911 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
 912    its array data.  */
 913 static struct value *
 914 desc_data (struct value *arr)
 915 {
 916   struct type *type = VALUE_TYPE (arr);
 917   if (is_thin_pntr (type))
 918     return thin_data_pntr (arr);
 919   else if (is_thick_pntr (type))
 920     return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
 921                              "Bad GNAT array descriptor");
 922   else
 923     return NULL;
 924 }
 925
 926
 927 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
 928    position of the field containing the address of the data. */
 929 static int
 930 fat_pntr_data_bitpos (struct type *type)
 931 {
 932   return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
 933 }
 934
 935 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
 936    size of the field containing the address of the data. */
 937 static int
 938 fat_pntr_data_bitsize (struct type *type)
 939 {
 940   type = desc_base_type (type);
 941
 942   if (TYPE_FIELD_BITSIZE (type, 0) > 0)
 943     return TYPE_FIELD_BITSIZE (type, 0);
 944   else
 945     return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
 946 }
 947
 948 /* If BOUNDS is an array-bounds structure (or pointer to one), return
 949    the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
 950    bound, if WHICH is 1.  The first bound is I=1. */
 951 static struct value *
 952 desc_one_bound (struct value *bounds, int i, int which)
 953 {
 954   return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
 955                            "Bad GNAT array descriptor bounds");
 956 }
 957
 958 /* If BOUNDS is an array-bounds structure type, return the bit position
 959    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
 960    bound, if WHICH is 1.  The first bound is I=1. */
 961 static int
 962 desc_bound_bitpos (struct type *type, int i, int which)
 963 {
 964   return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
 965 }
 966
 967 /* If BOUNDS is an array-bounds structure type, return the bit field size
 968    of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
 969    bound, if WHICH is 1.  The first bound is I=1. */
 970 static int
 971 desc_bound_bitsize (struct type *type, int i, int which)
 972 {
 973   type = desc_base_type (type);
 974
 975   if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
 976     return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
 977   else
 978     return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
 979 }
 980
 981 /* If TYPE is the type of an array-bounds structure, the type of its
 982    Ith bound (numbering from 1). Otherwise, NULL. */
 983 static struct type *
 984 desc_index_type (struct type *type, int i)
 985 {
 986   type = desc_base_type (type);
 987
 988   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
 989     return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
 990   else
 991     return NULL;
 992 }
 993
 994 /* The number of index positions in the array-bounds type TYPE.  0
 995    if TYPE is NULL. */
 996 static int
 997 desc_arity (struct type *type)
 998 {
 999   type = desc_base_type (type);
1000
1001   if (type != NULL)
1002     return TYPE_NFIELDS (type) / 2;
1003   return 0;
1004 }
1005
1006
1007 /* Non-zero iff type is a simple array type (or pointer to one). */
1008 int
1009 ada_is_simple_array (struct type *type)
1010 {
1011   if (type == NULL)
1012     return 0;
1013   CHECK_TYPEDEF (type);
1014   return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1015           || (TYPE_CODE (type) == TYPE_CODE_PTR
1016               && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY));
1017 }
1018
1019 /* Non-zero iff type belongs to a GNAT array descriptor. */
1020 int
1021 ada_is_array_descriptor (struct type *type)
1022 {
1023   struct type *data_type = desc_data_type (type);
1024
1025   if (type == NULL)
1026     return 0;
1027   CHECK_TYPEDEF (type);
1028   return
1029     data_type != NULL
1030     && ((TYPE_CODE (data_type) == TYPE_CODE_PTR
1031          && TYPE_TARGET_TYPE (data_type) != NULL
1032          && TYPE_CODE (TYPE_TARGET_TYPE (data_type)) == TYPE_CODE_ARRAY)
1033         ||
1034         TYPE_CODE (data_type) == TYPE_CODE_ARRAY)
1035     && desc_arity (desc_bounds_type (type)) > 0;
1036 }
1037
1038 /* Non-zero iff type is a partially mal-formed GNAT array
1039    descriptor.  (FIXME: This is to compensate for some problems with
1040    debugging output from GNAT.  Re-examine periodically to see if it
1041    is still needed. */
1042 int
1043 ada_is_bogus_array_descriptor (struct type *type)
1044 {
1045   return
1046     type != NULL
1047     && TYPE_CODE (type) == TYPE_CODE_STRUCT
1048     && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1049         || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1050     && !ada_is_array_descriptor (type);
1051 }
1052
1053
1054 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1055    (fat pointer) returns the type of the array data described---specifically,
1056    a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
1057    in from the descriptor; otherwise, they are left unspecified.  If
1058    the ARR denotes a null array descriptor and BOUNDS is non-zero,
1059    returns NULL.  The result is simply the type of ARR if ARR is not
1060    a descriptor.  */
1061 struct type *
1062 ada_type_of_array (struct value *arr, int bounds)
1063 {
1064   if (ada_is_packed_array_type (VALUE_TYPE (arr)))
1065     return decode_packed_array_type (VALUE_TYPE (arr));
1066
1067   if (!ada_is_array_descriptor (VALUE_TYPE (arr)))
1068     return VALUE_TYPE (arr);
1069
1070   if (!bounds)
1071     return
1072       check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr))));
1073   else
1074     {
1075       struct type *elt_type;
1076       int arity;
1077       struct value *descriptor;
1078       struct objfile *objf = TYPE_OBJFILE (VALUE_TYPE (arr));
1079
1080       elt_type = ada_array_element_type (VALUE_TYPE (arr), -1);
1081       arity = ada_array_arity (VALUE_TYPE (arr));
1082
1083       if (elt_type == NULL || arity == 0)
1084         return check_typedef (VALUE_TYPE (arr));
1085
1086       descriptor = desc_bounds (arr);
1087       if (value_as_long (descriptor) == 0)
1088         return NULL;
1089       while (arity > 0)
1090         {
1091           struct type *range_type = alloc_type (objf);
1092           struct type *array_type = alloc_type (objf);
1093           struct value *low = desc_one_bound (descriptor, arity, 0);
1094           struct value *high = desc_one_bound (descriptor, arity, 1);
1095           arity -= 1;
1096
1097           create_range_type (range_type, VALUE_TYPE (low),
1098                              (int) value_as_long (low),
1099                              (int) value_as_long (high));
1100           elt_type = create_array_type (array_type, elt_type, range_type);
1101         }
1102
1103       return lookup_pointer_type (elt_type);
1104     }
1105 }
1106
1107 /* If ARR does not represent an array, returns ARR unchanged.
1108    Otherwise, returns either a standard GDB array with bounds set
1109    appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1110    GDB array.  Returns NULL if ARR is a null fat pointer. */
1111 struct value *
1112 ada_coerce_to_simple_array_ptr (struct value *arr)
1113 {
1114   if (ada_is_array_descriptor (VALUE_TYPE (arr)))
1115     {
1116       struct type *arrType = ada_type_of_array (arr, 1);
1117       if (arrType == NULL)
1118         return NULL;
1119       return value_cast (arrType, value_copy (desc_data (arr)));
1120     }
1121   else if (ada_is_packed_array_type (VALUE_TYPE (arr)))
1122     return decode_packed_array (arr);
1123   else
1124     return arr;
1125 }
1126
1127 /* If ARR does not represent an array, returns ARR unchanged.
1128    Otherwise, returns a standard GDB array describing ARR (which may
1129    be ARR itself if it already is in the proper form). */
1130 struct value *
1131 ada_coerce_to_simple_array (struct value *arr)
1132 {
1133   if (ada_is_array_descriptor (VALUE_TYPE (arr)))
1134     {
1135       struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1136       if (arrVal == NULL)
1137         error ("Bounds unavailable for null array pointer.");
1138       return value_ind (arrVal);
1139     }
1140   else if (ada_is_packed_array_type (VALUE_TYPE (arr)))
1141     return decode_packed_array (arr);
1142   else
1143     return arr;
1144 }
1145
1146 /* If TYPE represents a GNAT array type, return it translated to an
1147    ordinary GDB array type (possibly with BITSIZE fields indicating
1148    packing). For other types, is the identity. */
1149 struct type *
1150 ada_coerce_to_simple_array_type (struct type *type)
1151 {
1152   struct value *mark = value_mark ();
1153   struct value *dummy = value_from_longest (builtin_type_long, 0);
1154   struct type *result;
1155   VALUE_TYPE (dummy) = type;
1156   result = ada_type_of_array (dummy, 0);
1157   value_free_to_mark (dummy);
1158   return result;
1159 }
1160
1161 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1162 int
1163 ada_is_packed_array_type (struct type *type)
1164 {
1165   if (type == NULL)
1166     return 0;
1167   CHECK_TYPEDEF (type);
1168   return
1169     ada_type_name (type) != NULL
1170     && strstr (ada_type_name (type), "___XP") != NULL;
1171 }
1172
1173 /* Given that TYPE is a standard GDB array type with all bounds filled
1174    in, and that the element size of its ultimate scalar constituents
1175    (that is, either its elements, or, if it is an array of arrays, its
1176    elements' elements, etc.) is *ELT_BITS, return an identical type,
1177    but with the bit sizes of its elements (and those of any
1178    constituent arrays) recorded in the BITSIZE components of its
1179    TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1180    in bits. */
1181 static struct type *
1182 packed_array_type (struct type *type, long *elt_bits)
1183 {
1184   struct type *new_elt_type;
1185   struct type *new_type;
1186   LONGEST low_bound, high_bound;
1187
1188   CHECK_TYPEDEF (type);
1189   if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1190     return type;
1191
1192   new_type = alloc_type (TYPE_OBJFILE (type));
1193   new_elt_type = packed_array_type (check_typedef (TYPE_TARGET_TYPE (type)),
1194                                     elt_bits);
1195   create_array_type (new_type, new_elt_type, TYPE_FIELD_TYPE (type, 0));
1196   TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
1197   TYPE_NAME (new_type) = ada_type_name (type);
1198
1199   if (get_discrete_bounds (TYPE_FIELD_TYPE (type, 0),
1200                            &low_bound, &high_bound) < 0)
1201     low_bound = high_bound = 0;
1202   if (high_bound < low_bound)
1203     *elt_bits = TYPE_LENGTH (new_type) = 0;
1204   else
1205     {
1206       *elt_bits *= (high_bound - low_bound + 1);
1207       TYPE_LENGTH (new_type) =
1208         (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
1209     }
1210
1211   /*  TYPE_FLAGS (new_type) |= TYPE_FLAG_FIXED_INSTANCE; */
1212   /* FIXME:  TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
1213   return new_type;
1214 }
1215
1216 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE).
1217  */
1218 static struct type *
1219 decode_packed_array_type (struct type *type)
1220 {
1221   struct symbol **syms;
1222   struct block **blocks;
1223   const char *raw_name = ada_type_name (check_typedef (type));
1224   char *name = (char *) alloca (strlen (raw_name) + 1);
1225   char *tail = strstr (raw_name, "___XP");
1226   struct type *shadow_type;
1227   long bits;
1228   int i, n;
1229
1230   memcpy (name, raw_name, tail - raw_name);
1231   name[tail - raw_name] = '\000';
1232
1233   /* NOTE: Use ada_lookup_symbol_list because of bug in some versions
1234    * of gcc (Solaris, e.g.). FIXME when compiler is fixed. */
1235   n = ada_lookup_symbol_list (name, get_selected_block (NULL),
1236                               VAR_DOMAIN, &syms, &blocks);
1237   for (i = 0; i < n; i += 1)
1238     if (syms[i] != NULL && SYMBOL_CLASS (syms[i]) == LOC_TYPEDEF
1239         && DEPRECATED_STREQ (name, ada_type_name (SYMBOL_TYPE (syms[i]))))
1240       break;
1241   if (i >= n)
1242     {
1243       warning ("could not find bounds information on packed array");
1244       return NULL;
1245     }
1246   shadow_type = SYMBOL_TYPE (syms[i]);
1247
1248   if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
1249     {
1250       warning ("could not understand bounds information on packed array");
1251       return NULL;
1252     }
1253
1254   if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1255     {
1256       warning ("could not understand bit size information on packed array");
1257       return NULL;
1258     }
1259
1260   return packed_array_type (shadow_type, &bits);
1261 }
1262
1263 /* Given that ARR is a struct value* indicating a GNAT packed array,
1264    returns a simple array that denotes that array.  Its type is a
1265    standard GDB array type except that the BITSIZEs of the array
1266    target types are set to the number of bits in each element, and the
1267    type length is set appropriately. */
1268
1269 static struct value *
1270 decode_packed_array (struct value *arr)
1271 {
1272   struct type *type = decode_packed_array_type (VALUE_TYPE (arr));
1273
1274   if (type == NULL)
1275     {
1276       error ("can't unpack array");
1277       return NULL;
1278     }
1279   else
1280     return coerce_unspec_val_to_type (arr, 0, type);
1281 }
1282
1283
1284 /* The value of the element of packed array ARR at the ARITY indices
1285    given in IND.   ARR must be a simple array. */
1286
1287 static struct value *
1288 value_subscript_packed (struct value *arr, int arity, struct value **ind)
1289 {
1290   int i;
1291   int bits, elt_off, bit_off;
1292   long elt_total_bit_offset;
1293   struct type *elt_type;
1294   struct value *v;
1295
1296   bits = 0;
1297   elt_total_bit_offset = 0;
1298   elt_type = check_typedef (VALUE_TYPE (arr));
1299   for (i = 0; i < arity; i += 1)
1300     {
1301       if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
1302           || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
1303         error
1304           ("attempt to do packed indexing of something other than a packed array");
1305       else
1306         {
1307           struct type *range_type = TYPE_INDEX_TYPE (elt_type);
1308           LONGEST lowerbound, upperbound;
1309           LONGEST idx;
1310
1311           if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
1312             {
1313               warning ("don't know bounds of array");
1314               lowerbound = upperbound = 0;
1315             }
1316
1317           idx = value_as_long (value_pos_atr (ind[i]));
1318           if (idx < lowerbound || idx > upperbound)
1319             warning ("packed array index %ld out of bounds", (long) idx);
1320           bits = TYPE_FIELD_BITSIZE (elt_type, 0);
1321           elt_total_bit_offset += (idx - lowerbound) * bits;
1322           elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
1323         }
1324     }
1325   elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
1326   bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
1327
1328   v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
1329                                       bits, elt_type);
1330   if (VALUE_LVAL (arr) == lval_internalvar)
1331     VALUE_LVAL (v) = lval_internalvar_component;
1332   else
1333     VALUE_LVAL (v) = VALUE_LVAL (arr);
1334   return v;
1335 }
1336
1337 /* Non-zero iff TYPE includes negative integer values. */
1338
1339 static int
1340 has_negatives (struct type *type)
1341 {
1342   switch (TYPE_CODE (type))
1343     {
1344     default:
1345       return 0;
1346     case TYPE_CODE_INT:
1347       return !TYPE_UNSIGNED (type);
1348     case TYPE_CODE_RANGE:
1349       return TYPE_LOW_BOUND (type) < 0;
1350     }
1351 }
1352
1353
1354 /* Create a new value of type TYPE from the contents of OBJ starting
1355    at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1356    proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
1357    assigning through the result will set the field fetched from. OBJ
1358    may also be NULL, in which case, VALADDR+OFFSET must address the
1359    start of storage containing the packed value.  The value returned
1360    in this case is never an lval.
1361    Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1362
1363 struct value *
1364 ada_value_primitive_packed_val (struct value *obj, char *valaddr, long offset,
1365                                 int bit_offset, int bit_size,
1366                                 struct type *type)
1367 {
1368   struct value *v;
1369   int src,                      /* Index into the source area. */
1370     targ,                       /* Index into the target area. */
1371     i, srcBitsLeft,             /* Number of source bits left to move. */
1372     nsrc, ntarg,                /* Number of source and target bytes. */
1373     unusedLS,                   /* Number of bits in next significant
1374                                  * byte of source that are unused. */
1375     accumSize;                  /* Number of meaningful bits in accum */
1376   unsigned char *bytes;         /* First byte containing data to unpack. */
1377   unsigned char *unpacked;
1378   unsigned long accum;          /* Staging area for bits being transferred */
1379   unsigned char sign;
1380   int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
1381   /* Transmit bytes from least to most significant; delta is the
1382    * direction the indices move. */
1383   int delta = BITS_BIG_ENDIAN ? -1 : 1;
1384
1385   CHECK_TYPEDEF (type);
1386
1387   if (obj == NULL)
1388     {
1389       v = allocate_value (type);
1390       bytes = (unsigned char *) (valaddr + offset);
1391     }
1392   else if (VALUE_LAZY (obj))
1393     {
1394       v = value_at (type,
1395                     VALUE_ADDRESS (obj) + VALUE_OFFSET (obj) + offset, NULL);
1396       bytes = (unsigned char *) alloca (len);
1397       read_memory (VALUE_ADDRESS (v), bytes, len);
1398     }
1399   else
1400     {
1401       v = allocate_value (type);
1402       bytes = (unsigned char *) VALUE_CONTENTS (obj) + offset;
1403     }
1404
1405   if (obj != NULL)
1406     {
1407       VALUE_LVAL (v) = VALUE_LVAL (obj);
1408       if (VALUE_LVAL (obj) == lval_internalvar)
1409         VALUE_LVAL (v) = lval_internalvar_component;
1410       VALUE_ADDRESS (v) = VALUE_ADDRESS (obj) + VALUE_OFFSET (obj) + offset;
1411       VALUE_BITPOS (v) = bit_offset + VALUE_BITPOS (obj);
1412       VALUE_BITSIZE (v) = bit_size;
1413       if (VALUE_BITPOS (v) >= HOST_CHAR_BIT)
1414         {
1415           VALUE_ADDRESS (v) += 1;
1416           VALUE_BITPOS (v) -= HOST_CHAR_BIT;
1417         }
1418     }
1419   else
1420     VALUE_BITSIZE (v) = bit_size;
1421   unpacked = (unsigned char *) VALUE_CONTENTS (v);
1422
1423   srcBitsLeft = bit_size;
1424   nsrc = len;
1425   ntarg = TYPE_LENGTH (type);
1426   sign = 0;
1427   if (bit_size == 0)
1428     {
1429       memset (unpacked, 0, TYPE_LENGTH (type));
1430       return v;
1431     }
1432   else if (BITS_BIG_ENDIAN)
1433     {
1434       src = len - 1;
1435       if (has_negatives (type) &&
1436           ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
1437         sign = ~0;
1438
1439       unusedLS =
1440         (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
1441         % HOST_CHAR_BIT;
1442
1443       switch (TYPE_CODE (type))
1444         {
1445         case TYPE_CODE_ARRAY:
1446         case TYPE_CODE_UNION:
1447         case TYPE_CODE_STRUCT:
1448           /* Non-scalar values must be aligned at a byte boundary. */
1449           accumSize =
1450             (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
1451           /* And are placed at the beginning (most-significant) bytes
1452            * of the target. */
1453           targ = src;
1454           break;
1455         default:
1456           accumSize = 0;
1457           targ = TYPE_LENGTH (type) - 1;
1458           break;
1459         }
1460     }
1461   else
1462     {
1463       int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
1464
1465       src = targ = 0;
1466       unusedLS = bit_offset;
1467       accumSize = 0;
1468
1469       if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
1470         sign = ~0;
1471     }
1472
1473   accum = 0;
1474   while (nsrc > 0)
1475     {
1476       /* Mask for removing bits of the next source byte that are not
1477        * part of the value. */
1478       unsigned int unusedMSMask =
1479         (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
1480         1;
1481       /* Sign-extend bits for this byte. */
1482       unsigned int signMask = sign & ~unusedMSMask;
1483       accum |=
1484         (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
1485       accumSize += HOST_CHAR_BIT - unusedLS;
1486       if (accumSize >= HOST_CHAR_BIT)
1487         {
1488           unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
1489           accumSize -= HOST_CHAR_BIT;
1490           accum >>= HOST_CHAR_BIT;
1491           ntarg -= 1;
1492           targ += delta;
1493         }
1494       srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
1495       unusedLS = 0;
1496       nsrc -= 1;
1497       src += delta;
1498     }
1499   while (ntarg > 0)
1500     {
1501       accum |= sign << accumSize;
1502       unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
1503       accumSize -= HOST_CHAR_BIT;
1504       accum >>= HOST_CHAR_BIT;
1505       ntarg -= 1;
1506       targ += delta;
1507     }
1508
1509   return v;
1510 }
1511
1512 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1513    TARGET, starting at bit offset TARG_OFFSET.  SOURCE and TARGET must
1514    not overlap. */
1515 static void
1516 move_bits (char *target, int targ_offset, char *source, int src_offset, int n)
1517 {
1518   unsigned int accum, mask;
1519   int accum_bits, chunk_size;
1520
1521   target += targ_offset / HOST_CHAR_BIT;
1522   targ_offset %= HOST_CHAR_BIT;
1523   source += src_offset / HOST_CHAR_BIT;
1524   src_offset %= HOST_CHAR_BIT;
1525   if (BITS_BIG_ENDIAN)
1526     {
1527       accum = (unsigned char) *source;
1528       source += 1;
1529       accum_bits = HOST_CHAR_BIT - src_offset;
1530
1531       while (n > 0)
1532         {
1533           int unused_right;
1534           accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
1535           accum_bits += HOST_CHAR_BIT;
1536           source += 1;
1537           chunk_size = HOST_CHAR_BIT - targ_offset;
1538           if (chunk_size > n)
1539             chunk_size = n;
1540           unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
1541           mask = ((1 << chunk_size) - 1) << unused_right;
1542           *target =
1543             (*target & ~mask)
1544             | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
1545           n -= chunk_size;
1546           accum_bits -= chunk_size;
1547           target += 1;
1548           targ_offset = 0;
1549         }
1550     }
1551   else
1552     {
1553       accum = (unsigned char) *source >> src_offset;
1554       source += 1;
1555       accum_bits = HOST_CHAR_BIT - src_offset;
1556
1557       while (n > 0)
1558         {
1559           accum = accum + ((unsigned char) *source << accum_bits);
1560           accum_bits += HOST_CHAR_BIT;
1561           source += 1;
1562           chunk_size = HOST_CHAR_BIT - targ_offset;
1563           if (chunk_size > n)
1564             chunk_size = n;
1565           mask = ((1 << chunk_size) - 1) << targ_offset;
1566           *target = (*target & ~mask) | ((accum << targ_offset) & mask);
1567           n -= chunk_size;
1568           accum_bits -= chunk_size;
1569           accum >>= chunk_size;
1570           target += 1;
1571           targ_offset = 0;
1572         }
1573     }
1574 }
1575
1576
1577 /* Store the contents of FROMVAL into the location of TOVAL.
1578    Return a new value with the location of TOVAL and contents of
1579    FROMVAL.   Handles assignment into packed fields that have
1580    floating-point or non-scalar types. */
1581
1582 static struct value *
1583 ada_value_assign (struct value *toval, struct value *fromval)
1584 {
1585   struct type *type = VALUE_TYPE (toval);
1586   int bits = VALUE_BITSIZE (toval);
1587
1588   if (!toval->modifiable)
1589     error ("Left operand of assignment is not a modifiable lvalue.");
1590
1591   COERCE_REF (toval);
1592
1593   if (VALUE_LVAL (toval) == lval_memory
1594       && bits > 0
1595       && (TYPE_CODE (type) == TYPE_CODE_FLT
1596           || TYPE_CODE (type) == TYPE_CODE_STRUCT))
1597     {
1598       int len =
1599         (VALUE_BITPOS (toval) + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
1600       char *buffer = (char *) alloca (len);
1601       struct value *val;
1602
1603       if (TYPE_CODE (type) == TYPE_CODE_FLT)
1604         fromval = value_cast (type, fromval);
1605
1606       read_memory (VALUE_ADDRESS (toval) + VALUE_OFFSET (toval), buffer, len);
1607       if (BITS_BIG_ENDIAN)
1608         move_bits (buffer, VALUE_BITPOS (toval),
1609                    VALUE_CONTENTS (fromval),
1610                    TYPE_LENGTH (VALUE_TYPE (fromval)) * TARGET_CHAR_BIT -
1611                    bits, bits);
1612       else
1613         move_bits (buffer, VALUE_BITPOS (toval), VALUE_CONTENTS (fromval),
1614                    0, bits);
1615       write_memory (VALUE_ADDRESS (toval) + VALUE_OFFSET (toval), buffer,
1616                     len);
1617
1618       val = value_copy (toval);
1619       memcpy (VALUE_CONTENTS_RAW (val), VALUE_CONTENTS (fromval),
1620               TYPE_LENGTH (type));
1621       VALUE_TYPE (val) = type;
1622
1623       return val;
1624     }
1625
1626   return value_assign (toval, fromval);
1627 }
1628
1629
1630 /* The value of the element of array ARR at the ARITY indices given in IND.
1631    ARR may be either a simple array, GNAT array descriptor, or pointer
1632    thereto.  */
1633
1634 struct value *
1635 ada_value_subscript (struct value *arr, int arity, struct value **ind)
1636 {
1637   int k;
1638   struct value *elt;
1639   struct type *elt_type;
1640
1641   elt = ada_coerce_to_simple_array (arr);
1642
1643   elt_type = check_typedef (VALUE_TYPE (elt));
1644   if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
1645       && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
1646     return value_subscript_packed (elt, arity, ind);
1647
1648   for (k = 0; k < arity; k += 1)
1649     {
1650       if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
1651         error ("too many subscripts (%d expected)", k);
1652       elt = value_subscript (elt, value_pos_atr (ind[k]));
1653     }
1654   return elt;
1655 }
1656
1657 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
1658    value of the element of *ARR at the ARITY indices given in
1659    IND. Does not read the entire array into memory. */
1660
1661 struct value *
1662 ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
1663                          struct value **ind)
1664 {
1665   int k;
1666
1667   for (k = 0; k < arity; k += 1)
1668     {
1669       LONGEST lwb, upb;
1670       struct value *idx;
1671
1672       if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1673         error ("too many subscripts (%d expected)", k);
1674       arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
1675                         value_copy (arr));
1676       get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
1677       if (lwb == 0)
1678         idx = ind[k];
1679       else
1680         idx = value_sub (ind[k], value_from_longest (builtin_type_int, lwb));
1681       arr = value_add (arr, idx);
1682       type = TYPE_TARGET_TYPE (type);
1683     }
1684
1685   return value_ind (arr);
1686 }
1687
1688 /* If type is a record type in the form of a standard GNAT array
1689    descriptor, returns the number of dimensions for type.  If arr is a
1690    simple array, returns the number of "array of"s that prefix its
1691    type designation. Otherwise, returns 0. */
1692
1693 int
1694 ada_array_arity (struct type *type)
1695 {
1696   int arity;
1697
1698   if (type == NULL)
1699     return 0;
1700
1701   type = desc_base_type (type);
1702
1703   arity = 0;
1704   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1705     return desc_arity (desc_bounds_type (type));
1706   else
1707     while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
1708       {
1709         arity += 1;
1710         type = check_typedef (TYPE_TARGET_TYPE (type));
1711       }
1712
1713   return arity;
1714 }
1715
1716 /* If TYPE is a record type in the form of a standard GNAT array
1717    descriptor or a simple array type, returns the element type for
1718    TYPE after indexing by NINDICES indices, or by all indices if
1719    NINDICES is -1. Otherwise, returns NULL. */
1720
1721 struct type *
1722 ada_array_element_type (struct type *type, int nindices)
1723 {
1724   type = desc_base_type (type);
1725
1726   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1727     {
1728       int k;
1729       struct type *p_array_type;
1730
1731       p_array_type = desc_data_type (type);
1732
1733       k = ada_array_arity (type);
1734       if (k == 0)
1735         return NULL;
1736
1737       /* Initially p_array_type = elt_type(*)[]...(k times)...[] */
1738       if (nindices >= 0 && k > nindices)
1739         k = nindices;
1740       p_array_type = TYPE_TARGET_TYPE (p_array_type);
1741       while (k > 0 && p_array_type != NULL)
1742         {
1743           p_array_type = check_typedef (TYPE_TARGET_TYPE (p_array_type));
1744           k -= 1;
1745         }
1746       return p_array_type;
1747     }
1748   else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
1749     {
1750       while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
1751         {
1752           type = TYPE_TARGET_TYPE (type);
1753           nindices -= 1;
1754         }
1755       return type;
1756     }
1757
1758   return NULL;
1759 }
1760
1761 /* The type of nth index in arrays of given type (n numbering from 1).  Does
1762    not examine memory. */
1763
1764 struct type *
1765 ada_index_type (struct type *type, int n)
1766 {
1767   type = desc_base_type (type);
1768
1769   if (n > ada_array_arity (type))
1770     return NULL;
1771
1772   if (ada_is_simple_array (type))
1773     {
1774       int i;
1775
1776       for (i = 1; i < n; i += 1)
1777         type = TYPE_TARGET_TYPE (type);
1778
1779       return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 0));
1780     }
1781   else
1782     return desc_index_type (desc_bounds_type (type), n);
1783 }
1784
1785 /* Given that arr is an array type, returns the lower bound of the
1786    Nth index (numbering from 1) if WHICH is 0, and the upper bound if
1787    WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1788    array-descriptor type.  If TYPEP is non-null, *TYPEP is set to the
1789    bounds type.  It works for other arrays with bounds supplied by
1790    run-time quantities other than discriminants. */
1791
1792 LONGEST
1793 ada_array_bound_from_type (struct type * arr_type, int n, int which,
1794                            struct type ** typep)
1795 {
1796   struct type *type;
1797   struct type *index_type_desc;
1798
1799   if (ada_is_packed_array_type (arr_type))
1800     arr_type = decode_packed_array_type (arr_type);
1801
1802   if (arr_type == NULL || !ada_is_simple_array (arr_type))
1803     {
1804       if (typep != NULL)
1805         *typep = builtin_type_int;
1806       return (LONGEST) - which;
1807     }
1808
1809   if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
1810     type = TYPE_TARGET_TYPE (arr_type);
1811   else
1812     type = arr_type;
1813
1814   index_type_desc = ada_find_parallel_type (type, "___XA");
1815   if (index_type_desc == NULL)
1816     {
1817       struct type *range_type;
1818       struct type *index_type;
1819
1820       while (n > 1)
1821         {
1822           type = TYPE_TARGET_TYPE (type);
1823           n -= 1;
1824         }
1825
1826       range_type = TYPE_INDEX_TYPE (type);
1827       index_type = TYPE_TARGET_TYPE (range_type);
1828       if (TYPE_CODE (index_type) == TYPE_CODE_UNDEF)
1829         index_type = builtin_type_long;
1830       if (typep != NULL)
1831         *typep = index_type;
1832       return
1833         (LONGEST) (which == 0
1834                    ? TYPE_LOW_BOUND (range_type)
1835                    : TYPE_HIGH_BOUND (range_type));
1836     }
1837   else
1838     {
1839       struct type *index_type =
1840         to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, n - 1),
1841                              NULL, TYPE_OBJFILE (arr_type));
1842       if (typep != NULL)
1843         *typep = TYPE_TARGET_TYPE (index_type);
1844       return
1845         (LONGEST) (which == 0
1846                    ? TYPE_LOW_BOUND (index_type)
1847                    : TYPE_HIGH_BOUND (index_type));
1848     }
1849 }
1850
1851 /* Given that arr is an array value, returns the lower bound of the
1852    nth index (numbering from 1) if which is 0, and the upper bound if
1853    which is 1. This routine will also work for arrays with bounds
1854    supplied by run-time quantities other than discriminants. */
1855
1856 struct value *
1857 ada_array_bound (struct value *arr, int n, int which)
1858 {
1859   struct type *arr_type = VALUE_TYPE (arr);
1860
1861   if (ada_is_packed_array_type (arr_type))
1862     return ada_array_bound (decode_packed_array (arr), n, which);
1863   else if (ada_is_simple_array (arr_type))
1864     {
1865       struct type *type;
1866       LONGEST v = ada_array_bound_from_type (arr_type, n, which, &type);
1867       return value_from_longest (type, v);
1868     }
1869   else
1870     return desc_one_bound (desc_bounds (arr), n, which);
1871 }
1872
1873 /* Given that arr is an array value, returns the length of the
1874    nth index.  This routine will also work for arrays with bounds
1875    supplied by run-time quantities other than discriminants. Does not
1876    work for arrays indexed by enumeration types with representation
1877    clauses at the moment. */
1878
1879 struct value *
1880 ada_array_length (struct value *arr, int n)
1881 {
1882   struct type *arr_type = check_typedef (VALUE_TYPE (arr));
1883   struct type *index_type_desc;
1884
1885   if (ada_is_packed_array_type (arr_type))
1886     return ada_array_length (decode_packed_array (arr), n);
1887
1888   if (ada_is_simple_array (arr_type))
1889     {
1890       struct type *type;
1891       LONGEST v =
1892         ada_array_bound_from_type (arr_type, n, 1, &type) -
1893         ada_array_bound_from_type (arr_type, n, 0, NULL) + 1;
1894       return value_from_longest (type, v);
1895     }
1896   else
1897     return
1898       value_from_longest (builtin_type_ada_int,
1899                           value_as_long (desc_one_bound (desc_bounds (arr),
1900                                                          n, 1))
1901                           - value_as_long (desc_one_bound (desc_bounds (arr),
1902                                                            n, 0)) + 1);
1903 }
1904 \f
1905
1906                                 /* Name resolution */
1907
1908 /* The "demangled" name for the user-definable Ada operator corresponding
1909    to op. */
1910
1911 static const char *
1912 ada_op_name (enum exp_opcode op)
1913 {
1914   int i;
1915
1916   for (i = 0; ada_opname_table[i].mangled != NULL; i += 1)
1917     {
1918       if (ada_opname_table[i].op == op)
1919         return ada_opname_table[i].demangled;
1920     }
1921   error ("Could not find operator name for opcode");
1922 }
1923
1924
1925 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
1926    references (OP_UNRESOLVED_VALUES) and converts operators that are
1927    user-defined into appropriate function calls.  If CONTEXT_TYPE is
1928    non-null, it provides a preferred result type [at the moment, only
1929    type void has any effect---causing procedures to be preferred over
1930    functions in calls].  A null CONTEXT_TYPE indicates that a non-void
1931    return type is preferred.  The variable unresolved_names contains a list
1932    of character strings referenced by expout that should be freed.
1933    May change (expand) *EXP.  */
1934
1935 void
1936 ada_resolve (struct expression **expp, struct type *context_type)
1937 {
1938   int pc;
1939   pc = 0;
1940   ada_resolve_subexp (expp, &pc, 1, context_type);
1941 }
1942
1943 /* Resolve the operator of the subexpression beginning at
1944    position *POS of *EXPP. "Resolving" consists of replacing
1945    OP_UNRESOLVED_VALUE with an appropriate OP_VAR_VALUE, replacing
1946    built-in operators with function calls to user-defined operators,
1947    where appropriate, and (when DEPROCEDURE_P is non-zero), converting
1948    function-valued variables into parameterless calls.  May expand
1949    EXP. The CONTEXT_TYPE functions as in ada_resolve, above. */
1950
1951 static struct value *
1952 ada_resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
1953                     struct type *context_type)
1954 {
1955   int pc = *pos;
1956   int i;
1957   struct expression *exp;       /* Convenience: == *expp */
1958   enum exp_opcode op = (*expp)->elts[pc].opcode;
1959   struct value **argvec;        /* Vector of operand types (alloca'ed). */
1960   int nargs;                    /* Number of operands */
1961
1962   argvec = NULL;
1963   nargs = 0;
1964   exp = *expp;
1965
1966   /* Pass one: resolve operands, saving their types and updating *pos. */
1967   switch (op)
1968     {
1969     case OP_VAR_VALUE:
1970       /*    case OP_UNRESOLVED_VALUE: */
1971       /* FIXME:  OP_UNRESOLVED_VALUE should be defined in expression.h */
1972       *pos += 4;
1973       break;
1974
1975     case OP_FUNCALL:
1976       nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
1977       /* FIXME:  OP_UNRESOLVED_VALUE should be defined in expression.h */
1978       /*      if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
1979          {
1980          *pos += 7;
1981
1982          argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 1));
1983          for (i = 0; i < nargs-1; i += 1)
1984          argvec[i] = ada_resolve_subexp (expp, pos, 1, NULL);
1985          argvec[i] = NULL;
1986          }
1987          else
1988          {
1989          *pos += 3;
1990          ada_resolve_subexp (expp, pos, 0, NULL);
1991          for (i = 1; i < nargs; i += 1)
1992          ada_resolve_subexp (expp, pos, 1, NULL);
1993          }
1994        */
1995       exp = *expp;
1996       break;
1997
1998       /* FIXME:  UNOP_QUAL should be defined in expression.h */
1999       /*    case UNOP_QUAL:
2000          nargs = 1;
2001          *pos += 3;
2002          ada_resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
2003          exp = *expp;
2004          break;
2005        */
2006       /* FIXME:  OP_ATTRIBUTE should be defined in expression.h */
2007       /*    case OP_ATTRIBUTE:
2008          nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
2009          *pos += 4;
2010          for (i = 0; i < nargs; i += 1)
2011          ada_resolve_subexp (expp, pos, 1, NULL);
2012          exp = *expp;
2013          break;
2014        */
2015     case UNOP_ADDR:
2016       nargs = 1;
2017       *pos += 1;
2018       ada_resolve_subexp (expp, pos, 0, NULL);
2019       exp = *expp;
2020       break;
2021
2022     case BINOP_ASSIGN:
2023       {
2024         struct value *arg1;
2025         nargs = 2;
2026         *pos += 1;
2027         arg1 = ada_resolve_subexp (expp, pos, 0, NULL);
2028         if (arg1 == NULL)
2029           ada_resolve_subexp (expp, pos, 1, NULL);
2030         else
2031           ada_resolve_subexp (expp, pos, 1, VALUE_TYPE (arg1));
2032         break;
2033       }
2034
2035     default:
2036       switch (op)
2037         {
2038         default:
2039           error ("Unexpected operator during name resolution");
2040         case UNOP_CAST:
2041           /*    case UNOP_MBR:
2042              nargs = 1;
2043              *pos += 3;
2044              break;
2045            */
2046         case BINOP_ADD:
2047         case BINOP_SUB:
2048         case BINOP_MUL:
2049         case BINOP_DIV:
2050         case BINOP_REM:
2051         case BINOP_MOD:
2052         case BINOP_EXP:
2053         case BINOP_CONCAT:
2054         case BINOP_LOGICAL_AND:
2055         case BINOP_LOGICAL_OR:
2056         case BINOP_BITWISE_AND:
2057         case BINOP_BITWISE_IOR:
2058         case BINOP_BITWISE_XOR:
2059
2060         case BINOP_EQUAL:
2061         case BINOP_NOTEQUAL:
2062         case BINOP_LESS:
2063         case BINOP_GTR:
2064         case BINOP_LEQ:
2065         case BINOP_GEQ:
2066
2067         case BINOP_REPEAT:
2068         case BINOP_SUBSCRIPT:
2069         case BINOP_COMMA:
2070           nargs = 2;
2071           *pos += 1;
2072           break;
2073
2074         case UNOP_NEG:
2075         case UNOP_PLUS:
2076         case UNOP_LOGICAL_NOT:
2077         case UNOP_ABS:
2078         case UNOP_IND:
2079           nargs = 1;
2080           *pos += 1;
2081           break;
2082
2083         case OP_LONG:
2084         case OP_DOUBLE:
2085         case OP_VAR_VALUE:
2086           *pos += 4;
2087           break;
2088
2089         case OP_TYPE:
2090         case OP_BOOL:
2091         case OP_LAST:
2092         case OP_REGISTER:
2093         case OP_INTERNALVAR:
2094           *pos += 3;
2095           break;
2096
2097         case UNOP_MEMVAL:
2098           *pos += 3;
2099           nargs = 1;
2100           break;
2101
2102         case STRUCTOP_STRUCT:
2103         case STRUCTOP_PTR:
2104           nargs = 1;
2105           *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2106           break;
2107
2108         case OP_ARRAY:
2109           *pos += 4;
2110           nargs = longest_to_int (exp->elts[pc + 2].longconst) + 1;
2111           nargs -= longest_to_int (exp->elts[pc + 1].longconst);
2112           /* A null array contains one dummy element to give the type. */
2113           /*      if (nargs == 0)
2114              nargs = 1;
2115              break; */
2116
2117         case TERNOP_SLICE:
2118           /* FIXME: TERNOP_MBR should be defined in expression.h */
2119           /*    case TERNOP_MBR:
2120              *pos += 1;
2121              nargs = 3;
2122              break;
2123            */
2124           /* FIXME: BINOP_MBR should be defined in expression.h */
2125           /*    case BINOP_MBR:
2126              *pos += 3;
2127              nargs = 2;
2128              break; */
2129         }
2130
2131       argvec =
2132         (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
2133       for (i = 0; i < nargs; i += 1)
2134         argvec[i] = ada_resolve_subexp (expp, pos, 1, NULL);
2135       argvec[i] = NULL;
2136       exp = *expp;
2137       break;
2138     }
2139
2140   /* Pass two: perform any resolution on principal operator. */
2141   switch (op)
2142     {
2143     default:
2144       break;
2145
2146       /* FIXME:  OP_UNRESOLVED_VALUE should be defined in expression.h */
2147       /*    case OP_UNRESOLVED_VALUE:
2148          {
2149          struct symbol** candidate_syms;
2150          struct block** candidate_blocks;
2151          int n_candidates;
2152
2153          n_candidates = ada_lookup_symbol_list (exp->elts[pc + 2].name,
2154          exp->elts[pc + 1].block,
2155          VAR_DOMAIN,
2156          &candidate_syms,
2157          &candidate_blocks);
2158
2159          if (n_candidates > 1)
2160          { */
2161       /* Types tend to get re-introduced locally, so if there
2162          are any local symbols that are not types, first filter
2163    out all types. *//*
2164    int j;
2165    for (j = 0; j < n_candidates; j += 1)
2166    switch (SYMBOL_CLASS (candidate_syms[j]))
2167    {
2168    case LOC_REGISTER:
2169    case LOC_ARG:
2170    case LOC_REF_ARG:
2171    case LOC_REGPARM:
2172    case LOC_REGPARM_ADDR:
2173    case LOC_LOCAL:
2174    case LOC_LOCAL_ARG:
2175    case LOC_BASEREG:
2176    case LOC_BASEREG_ARG:
2177    case LOC_COMPUTED:
2178    case LOC_COMPUTED_ARG:
2179    goto FoundNonType;
2180    default:
2181    break;
2182    }
2183    FoundNonType:
2184    if (j < n_candidates)
2185    {
2186    j = 0;
2187    while (j < n_candidates)
2188    {
2189    if (SYMBOL_CLASS (candidate_syms[j]) == LOC_TYPEDEF)
2190    {
2191    candidate_syms[j] = candidate_syms[n_candidates-1];
2192    candidate_blocks[j] = candidate_blocks[n_candidates-1];
2193    n_candidates -= 1;
2194    }
2195    else
2196    j += 1;
2197    }
2198    }
2199    }
2200
2201    if (n_candidates == 0)
2202    error ("No definition found for %s",
2203    ada_demangle (exp->elts[pc + 2].name));
2204    else if (n_candidates == 1)
2205    i = 0;
2206    else if (deprocedure_p
2207    && ! is_nonfunction (candidate_syms, n_candidates))
2208    {
2209    i = ada_resolve_function (candidate_syms, candidate_blocks,
2210    n_candidates, NULL, 0,
2211    exp->elts[pc + 2].name, context_type);
2212    if (i < 0)
2213    error ("Could not find a match for %s",
2214    ada_demangle (exp->elts[pc + 2].name));
2215    }
2216    else
2217    {
2218    printf_filtered ("Multiple matches for %s\n",
2219    ada_demangle (exp->elts[pc+2].name));
2220    user_select_syms (candidate_syms, candidate_blocks,
2221    n_candidates, 1);
2222    i = 0;
2223    }
2224
2225    exp->elts[pc].opcode = exp->elts[pc + 3].opcode = OP_VAR_VALUE;
2226    exp->elts[pc + 1].block = candidate_blocks[i];
2227    exp->elts[pc + 2].symbol = candidate_syms[i];
2228    if (innermost_block == NULL ||
2229    contained_in (candidate_blocks[i], innermost_block))
2230    innermost_block = candidate_blocks[i];
2231    } */
2232       /* FALL THROUGH */
2233
2234     case OP_VAR_VALUE:
2235       if (deprocedure_p &&
2236           TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol)) ==
2237           TYPE_CODE_FUNC)
2238         {
2239           replace_operator_with_call (expp, pc, 0, 0,
2240                                       exp->elts[pc + 2].symbol,
2241                                       exp->elts[pc + 1].block);
2242           exp = *expp;
2243         }
2244       break;
2245
2246     case OP_FUNCALL:
2247       {
2248         /* FIXME:  OP_UNRESOLVED_VALUE should be defined in expression.h */
2249         /*      if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
2250            {
2251            struct symbol** candidate_syms;
2252            struct block** candidate_blocks;
2253            int n_candidates;
2254
2255            n_candidates = ada_lookup_symbol_list (exp->elts[pc + 5].name,
2256            exp->elts[pc + 4].block,
2257            VAR_DOMAIN,
2258            &candidate_syms,
2259            &candidate_blocks);
2260            if (n_candidates == 1)
2261            i = 0;
2262            else
2263            {
2264            i = ada_resolve_function (candidate_syms, candidate_blocks,
2265            n_candidates, argvec, nargs-1,
2266            exp->elts[pc + 5].name, context_type);
2267            if (i < 0)
2268            error ("Could not find a match for %s",
2269            ada_demangle (exp->elts[pc + 5].name));
2270            }
2271
2272            exp->elts[pc + 3].opcode = exp->elts[pc + 6].opcode = OP_VAR_VALUE;
2273            exp->elts[pc + 4].block = candidate_blocks[i];
2274            exp->elts[pc + 5].symbol = candidate_syms[i];
2275            if (innermost_block == NULL ||
2276            contained_in (candidate_blocks[i], innermost_block))
2277            innermost_block = candidate_blocks[i];
2278            } */
2279
2280       }
2281       break;
2282     case BINOP_ADD:
2283     case BINOP_SUB:
2284     case BINOP_MUL:
2285     case BINOP_DIV:
2286     case BINOP_REM:
2287     case BINOP_MOD:
2288     case BINOP_CONCAT:
2289     case BINOP_BITWISE_AND:
2290     case BINOP_BITWISE_IOR:
2291     case BINOP_BITWISE_XOR:
2292     case BINOP_EQUAL:
2293     case BINOP_NOTEQUAL:
2294     case BINOP_LESS:
2295     case BINOP_GTR:
2296     case BINOP_LEQ:
2297     case BINOP_GEQ:
2298     case BINOP_EXP:
2299     case UNOP_NEG:
2300     case UNOP_PLUS:
2301     case UNOP_LOGICAL_NOT:
2302     case UNOP_ABS:
2303       if (possible_user_operator_p (op, argvec))
2304         {
2305           struct symbol **candidate_syms;
2306           struct block **candidate_blocks;
2307           int n_candidates;
2308
2309           n_candidates =
2310             ada_lookup_symbol_list (ada_mangle (ada_op_name (op)),
2311                                     (struct block *) NULL, VAR_DOMAIN,
2312                                     &candidate_syms, &candidate_blocks);
2313           i =
2314             ada_resolve_function (candidate_syms, candidate_blocks,
2315                                   n_candidates, argvec, nargs,
2316                                   ada_op_name (op), NULL);
2317           if (i < 0)
2318             break;
2319
2320           replace_operator_with_call (expp, pc, nargs, 1,
2321                                       candidate_syms[i], candidate_blocks[i]);
2322           exp = *expp;
2323         }
2324       break;
2325     }
2326
2327   *pos = pc;
2328   return evaluate_subexp_type (exp, pos);
2329 }
2330
2331 /* Return non-zero if formal type FTYPE matches actual type ATYPE.  If
2332    MAY_DEREF is non-zero, the formal may be a pointer and the actual
2333    a non-pointer. */
2334 /* The term "match" here is rather loose.  The match is heuristic and
2335    liberal.  FIXME: TOO liberal, in fact. */
2336
2337 static int
2338 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
2339 {
2340   CHECK_TYPEDEF (ftype);
2341   CHECK_TYPEDEF (atype);
2342
2343   if (TYPE_CODE (ftype) == TYPE_CODE_REF)
2344     ftype = TYPE_TARGET_TYPE (ftype);
2345   if (TYPE_CODE (atype) == TYPE_CODE_REF)
2346     atype = TYPE_TARGET_TYPE (atype);
2347
2348   if (TYPE_CODE (ftype) == TYPE_CODE_VOID
2349       || TYPE_CODE (atype) == TYPE_CODE_VOID)
2350     return 1;
2351
2352   switch (TYPE_CODE (ftype))
2353     {
2354     default:
2355       return 1;
2356     case TYPE_CODE_PTR:
2357       if (TYPE_CODE (atype) == TYPE_CODE_PTR)
2358         return ada_type_match (TYPE_TARGET_TYPE (ftype),
2359                                TYPE_TARGET_TYPE (atype), 0);
2360       else
2361         return (may_deref &&
2362                 ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
2363     case TYPE_CODE_INT:
2364     case TYPE_CODE_ENUM:
2365     case TYPE_CODE_RANGE:
2366       switch (TYPE_CODE (atype))
2367         {
2368         case TYPE_CODE_INT:
2369         case TYPE_CODE_ENUM:
2370         case TYPE_CODE_RANGE:
2371           return 1;
2372         default:
2373           return 0;
2374         }
2375
2376     case TYPE_CODE_ARRAY:
2377       return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
2378               || ada_is_array_descriptor (atype));
2379
2380     case TYPE_CODE_STRUCT:
2381       if (ada_is_array_descriptor (ftype))
2382         return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
2383                 || ada_is_array_descriptor (atype));
2384       else
2385         return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
2386                 && !ada_is_array_descriptor (atype));
2387
2388     case TYPE_CODE_UNION:
2389     case TYPE_CODE_FLT:
2390       return (TYPE_CODE (atype) == TYPE_CODE (ftype));
2391     }
2392 }
2393
2394 /* Return non-zero if the formals of FUNC "sufficiently match" the
2395    vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
2396    may also be an enumeral, in which case it is treated as a 0-
2397    argument function. */
2398
2399 static int
2400 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
2401 {
2402   int i;
2403   struct type *func_type = SYMBOL_TYPE (func);
2404
2405   if (SYMBOL_CLASS (func) == LOC_CONST &&
2406       TYPE_CODE (func_type) == TYPE_CODE_ENUM)
2407     return (n_actuals == 0);
2408   else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
2409     return 0;
2410
2411   if (TYPE_NFIELDS (func_type) != n_actuals)
2412     return 0;
2413
2414   for (i = 0; i < n_actuals; i += 1)
2415     {
2416       struct type *ftype = check_typedef (TYPE_FIELD_TYPE (func_type, i));
2417       struct type *atype = check_typedef (VALUE_TYPE (actuals[i]));
2418
2419       if (!ada_type_match (TYPE_FIELD_TYPE (func_type, i),
2420                            VALUE_TYPE (actuals[i]), 1))
2421         return 0;
2422     }
2423   return 1;
2424 }
2425
2426 /* False iff function type FUNC_TYPE definitely does not produce a value
2427    compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
2428    FUNC_TYPE is not a valid function type with a non-null return type
2429    or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */
2430
2431 static int
2432 return_match (struct type *func_type, struct type *context_type)
2433 {
2434   struct type *return_type;
2435
2436   if (func_type == NULL)
2437     return 1;
2438
2439   /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2440   /*  if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
2441      return_type = base_type (TYPE_TARGET_TYPE (func_type));
2442      else
2443      return_type = base_type (func_type); */
2444   if (return_type == NULL)
2445     return 1;
2446
2447   /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2448   /*  context_type = base_type (context_type); */
2449
2450   if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
2451     return context_type == NULL || return_type == context_type;
2452   else if (context_type == NULL)
2453     return TYPE_CODE (return_type) != TYPE_CODE_VOID;
2454   else
2455     return TYPE_CODE (return_type) == TYPE_CODE (context_type);
2456 }
2457
2458
2459 /* Return the index in SYMS[0..NSYMS-1] of symbol for the
2460    function (if any) that matches the types of the NARGS arguments in
2461    ARGS.  If CONTEXT_TYPE is non-null, and there is at least one match
2462    that returns type CONTEXT_TYPE, then eliminate other matches.  If
2463    CONTEXT_TYPE is null, prefer a non-void-returning function.
2464    Asks the user if there is more than one match remaining.  Returns -1
2465    if there is no such symbol or none is selected.  NAME is used
2466    solely for messages.   May re-arrange and modify SYMS in
2467    the process; the index returned is for the modified vector.  BLOCKS
2468    is modified in parallel to SYMS. */
2469
2470 int
2471 ada_resolve_function (struct symbol *syms[], struct block *blocks[],
2472                       int nsyms, struct value **args, int nargs,
2473                       const char *name, struct type *context_type)
2474 {
2475   int k;
2476   int m;                        /* Number of hits */
2477   struct type *fallback;
2478   struct type *return_type;
2479
2480   return_type = context_type;
2481   if (context_type == NULL)
2482     fallback = builtin_type_void;
2483   else
2484     fallback = NULL;
2485
2486   m = 0;
2487   while (1)
2488     {
2489       for (k = 0; k < nsyms; k += 1)
2490         {
2491           struct type *type = check_typedef (SYMBOL_TYPE (syms[k]));
2492
2493           if (ada_args_match (syms[k], args, nargs)
2494               && return_match (SYMBOL_TYPE (syms[k]), return_type))
2495             {
2496               syms[m] = syms[k];
2497               if (blocks != NULL)
2498                 blocks[m] = blocks[k];
2499               m += 1;
2500             }
2501         }
2502       if (m > 0 || return_type == fallback)
2503         break;
2504       else
2505         return_type = fallback;
2506     }
2507
2508   if (m == 0)
2509     return -1;
2510   else if (m > 1)
2511     {
2512       printf_filtered ("Multiple matches for %s\n", name);
2513       user_select_syms (syms, blocks, m, 1);
2514       return 0;
2515     }
2516   return 0;
2517 }
2518
2519 /* Returns true (non-zero) iff demangled name N0 should appear before N1 */
2520 /* in a listing of choices during disambiguation (see sort_choices, below). */
2521 /* The idea is that overloadings of a subprogram name from the */
2522 /* same package should sort in their source order.  We settle for ordering */
2523 /* such symbols by their trailing number (__N  or $N). */
2524 static int
2525 mangled_ordered_before (char *N0, char *N1)
2526 {
2527   if (N1 == NULL)
2528     return 0;
2529   else if (N0 == NULL)
2530     return 1;
2531   else
2532     {
2533       int k0, k1;
2534       for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
2535         ;
2536       for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
2537         ;
2538       if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
2539           && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
2540         {
2541           int n0, n1;
2542           n0 = k0;
2543           while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
2544             n0 -= 1;
2545           n1 = k1;
2546           while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
2547             n1 -= 1;
2548           if (n0 == n1 && DEPRECATED_STREQN (N0, N1, n0))
2549             return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
2550         }
2551       return (strcmp (N0, N1) < 0);
2552     }
2553 }
2554
2555 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by their */
2556 /* mangled names, rearranging BLOCKS[0..NSYMS-1] according to the same */
2557 /* permutation. */
2558 static void
2559 sort_choices (struct symbol *syms[], struct block *blocks[], int nsyms)
2560 {
2561   int i, j;
2562   for (i = 1; i < nsyms; i += 1)
2563     {
2564       struct symbol *sym = syms[i];
2565       struct block *block = blocks[i];
2566       int j;
2567
2568       for (j = i - 1; j >= 0; j -= 1)
2569         {
2570           if (mangled_ordered_before (DEPRECATED_SYMBOL_NAME (syms[j]),
2571                                       DEPRECATED_SYMBOL_NAME (sym)))
2572             break;
2573           syms[j + 1] = syms[j];
2574           blocks[j + 1] = blocks[j];
2575         }
2576       syms[j + 1] = sym;
2577       blocks[j + 1] = block;
2578     }
2579 }
2580
2581 /* Given a list of NSYMS symbols in SYMS and corresponding blocks in */
2582 /* BLOCKS, select up to MAX_RESULTS>0 by asking the user (if */
2583 /* necessary), returning the number selected, and setting the first */
2584 /* elements of SYMS and BLOCKS to the selected symbols and */
2585 /* corresponding blocks.  Error if no symbols selected.   BLOCKS may */
2586 /* be NULL, in which case it is ignored. */
2587
2588 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
2589    to be re-integrated one of these days. */
2590
2591 int
2592 user_select_syms (struct symbol *syms[], struct block *blocks[], int nsyms,
2593                   int max_results)
2594 {
2595   int i;
2596   int *chosen = (int *) alloca (sizeof (int) * nsyms);
2597   int n_chosen;
2598   int first_choice = (max_results == 1) ? 1 : 2;
2599
2600   if (max_results < 1)
2601     error ("Request to select 0 symbols!");
2602   if (nsyms <= 1)
2603     return nsyms;
2604
2605   printf_unfiltered ("[0] cancel\n");
2606   if (max_results > 1)
2607     printf_unfiltered ("[1] all\n");
2608
2609   sort_choices (syms, blocks, nsyms);
2610
2611   for (i = 0; i < nsyms; i += 1)
2612     {
2613       if (syms[i] == NULL)
2614         continue;
2615
2616       if (SYMBOL_CLASS (syms[i]) == LOC_BLOCK)
2617         {
2618           struct symtab_and_line sal = find_function_start_sal (syms[i], 1);
2619           printf_unfiltered ("[%d] %s at %s:%d\n",
2620                              i + first_choice,
2621                              SYMBOL_PRINT_NAME (syms[i]),
2622                              sal.symtab == NULL
2623                              ? "<no source file available>"
2624                              : sal.symtab->filename, sal.line);
2625           continue;
2626         }
2627       else
2628         {
2629           int is_enumeral =
2630             (SYMBOL_CLASS (syms[i]) == LOC_CONST
2631              && SYMBOL_TYPE (syms[i]) != NULL
2632              && TYPE_CODE (SYMBOL_TYPE (syms[i])) == TYPE_CODE_ENUM);
2633           struct symtab *symtab = symtab_for_sym (syms[i]);
2634
2635           if (SYMBOL_LINE (syms[i]) != 0 && symtab != NULL)
2636             printf_unfiltered ("[%d] %s at %s:%d\n",
2637                                i + first_choice,
2638                                SYMBOL_PRINT_NAME (syms[i]),
2639                                symtab->filename, SYMBOL_LINE (syms[i]));
2640           else if (is_enumeral && TYPE_NAME (SYMBOL_TYPE (syms[i])) != NULL)
2641             {
2642               printf_unfiltered ("[%d] ", i + first_choice);
2643               ada_print_type (SYMBOL_TYPE (syms[i]), NULL, gdb_stdout, -1, 0);
2644               printf_unfiltered ("'(%s) (enumeral)\n",
2645                                  SYMBOL_PRINT_NAME (syms[i]));
2646             }
2647           else if (symtab != NULL)
2648             printf_unfiltered (is_enumeral
2649                                ? "[%d] %s in %s (enumeral)\n"
2650                                : "[%d] %s at %s:?\n",
2651                                i + first_choice,
2652                                SYMBOL_PRINT_NAME (syms[i]),
2653                                symtab->filename);
2654           else
2655             printf_unfiltered (is_enumeral
2656                                ? "[%d] %s (enumeral)\n"
2657                                : "[%d] %s at ?\n",
2658                                i + first_choice,
2659                                SYMBOL_PRINT_NAME (syms[i]));
2660         }
2661     }
2662
2663   n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
2664                              "overload-choice");
2665
2666   for (i = 0; i < n_chosen; i += 1)
2667     {
2668       syms[i] = syms[chosen[i]];
2669       if (blocks != NULL)
2670         blocks[i] = blocks[chosen[i]];
2671     }
2672
2673   return n_chosen;
2674 }
2675
2676 /* Read and validate a set of numeric choices from the user in the
2677    range 0 .. N_CHOICES-1. Place the results in increasing
2678    order in CHOICES[0 .. N-1], and return N.
2679
2680    The user types choices as a sequence of numbers on one line
2681    separated by blanks, encoding them as follows:
2682
2683      + A choice of 0 means to cancel the selection, throwing an error.
2684      + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
2685      + The user chooses k by typing k+IS_ALL_CHOICE+1.
2686
2687    The user is not allowed to choose more than MAX_RESULTS values.
2688
2689    ANNOTATION_SUFFIX, if present, is used to annotate the input
2690    prompts (for use with the -f switch). */
2691
2692 int
2693 get_selections (int *choices, int n_choices, int max_results,
2694                 int is_all_choice, char *annotation_suffix)
2695 {
2696   int i;
2697   char *args;
2698   const char *prompt;
2699   int n_chosen;
2700   int first_choice = is_all_choice ? 2 : 1;
2701
2702   prompt = getenv ("PS2");
2703   if (prompt == NULL)
2704     prompt = ">";
2705
2706   printf_unfiltered ("%s ", prompt);
2707   gdb_flush (gdb_stdout);
2708
2709   args = command_line_input ((char *) NULL, 0, annotation_suffix);
2710
2711   if (args == NULL)
2712     error_no_arg ("one or more choice numbers");
2713
2714   n_chosen = 0;
2715
2716   /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
2717      order, as given in args.   Choices are validated. */
2718   while (1)
2719     {
2720       char *args2;
2721       int choice, j;
2722
2723       while (isspace (*args))
2724         args += 1;
2725       if (*args == '\0' && n_chosen == 0)
2726         error_no_arg ("one or more choice numbers");
2727       else if (*args == '\0')
2728         break;
2729
2730       choice = strtol (args, &args2, 10);
2731       if (args == args2 || choice < 0
2732           || choice > n_choices + first_choice - 1)
2733         error ("Argument must be choice number");
2734       args = args2;
2735
2736       if (choice == 0)
2737         error ("cancelled");
2738
2739       if (choice < first_choice)
2740         {
2741           n_chosen = n_choices;
2742           for (j = 0; j < n_choices; j += 1)
2743             choices[j] = j;
2744           break;
2745         }
2746       choice -= first_choice;
2747
2748       for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
2749         {
2750         }
2751
2752       if (j < 0 || choice != choices[j])
2753         {
2754           int k;
2755           for (k = n_chosen - 1; k > j; k -= 1)
2756             choices[k + 1] = choices[k];
2757           choices[j + 1] = choice;
2758           n_chosen += 1;
2759         }
2760     }
2761
2762   if (n_chosen > max_results)
2763     error ("Select no more than %d of the above", max_results);
2764
2765   return n_chosen;
2766 }
2767
2768 /* Replace the operator of length OPLEN at position PC in *EXPP with a call */
2769 /* on the function identified by SYM and BLOCK, and taking NARGS */
2770 /* arguments.  Update *EXPP as needed to hold more space. */
2771
2772 static void
2773 replace_operator_with_call (struct expression **expp, int pc, int nargs,
2774                             int oplen, struct symbol *sym,
2775                             struct block *block)
2776 {
2777   /* A new expression, with 6 more elements (3 for funcall, 4 for function
2778      symbol, -oplen for operator being replaced). */
2779   struct expression *newexp = (struct expression *)
2780     xmalloc (sizeof (struct expression)
2781              + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
2782   struct expression *exp = *expp;
2783
2784   newexp->nelts = exp->nelts + 7 - oplen;
2785   newexp->language_defn = exp->language_defn;
2786   memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
2787   memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
2788           EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
2789
2790   newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
2791   newexp->elts[pc + 1].longconst = (LONGEST) nargs;
2792
2793   newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
2794   newexp->elts[pc + 4].block = block;
2795   newexp->elts[pc + 5].symbol = sym;
2796
2797   *expp = newexp;
2798   xfree (exp);
2799 }
2800
2801 /* Type-class predicates */
2802
2803 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type), or */
2804 /* FLOAT.) */
2805
2806 static int
2807 numeric_type_p (struct type *type)
2808 {
2809   if (type == NULL)
2810     return 0;
2811   else
2812     {
2813       switch (TYPE_CODE (type))
2814         {
2815         case TYPE_CODE_INT:
2816         case TYPE_CODE_FLT:
2817           return 1;
2818         case TYPE_CODE_RANGE:
2819           return (type == TYPE_TARGET_TYPE (type)
2820                   || numeric_type_p (TYPE_TARGET_TYPE (type)));
2821         default:
2822           return 0;
2823         }
2824     }
2825 }
2826
2827 /* True iff TYPE is integral (an INT or RANGE of INTs). */
2828
2829 static int
2830 integer_type_p (struct type *type)
2831 {
2832   if (type == NULL)
2833     return 0;
2834   else
2835     {
2836       switch (TYPE_CODE (type))
2837         {
2838         case TYPE_CODE_INT:
2839           return 1;
2840         case TYPE_CODE_RANGE:
2841           return (type == TYPE_TARGET_TYPE (type)
2842                   || integer_type_p (TYPE_TARGET_TYPE (type)));
2843         default:
2844           return 0;
2845         }
2846     }
2847 }
2848
2849 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
2850
2851 static int
2852 scalar_type_p (struct type *type)
2853 {
2854   if (type == NULL)
2855     return 0;
2856   else
2857     {
2858       switch (TYPE_CODE (type))
2859         {
2860         case TYPE_CODE_INT:
2861         case TYPE_CODE_RANGE:
2862         case TYPE_CODE_ENUM:
2863         case TYPE_CODE_FLT:
2864           return 1;
2865         default:
2866           return 0;
2867         }
2868     }
2869 }
2870
2871 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
2872
2873 static int
2874 discrete_type_p (struct type *type)
2875 {
2876   if (type == NULL)
2877     return 0;
2878   else
2879     {
2880       switch (TYPE_CODE (type))
2881         {
2882         case TYPE_CODE_INT:
2883         case TYPE_CODE_RANGE:
2884         case TYPE_CODE_ENUM:
2885           return 1;
2886         default:
2887           return 0;
2888         }
2889     }
2890 }
2891
2892 /* Returns non-zero if OP with operatands in the vector ARGS could be
2893    a user-defined function. Errs on the side of pre-defined operators
2894    (i.e., result 0). */
2895
2896 static int
2897 possible_user_operator_p (enum exp_opcode op, struct value *args[])
2898 {
2899   struct type *type0 = check_typedef (VALUE_TYPE (args[0]));
2900   struct type *type1 =
2901     (args[1] == NULL) ? NULL : check_typedef (VALUE_TYPE (args[1]));
2902
2903   switch (op)
2904     {
2905     default:
2906       return 0;
2907
2908     case BINOP_ADD:
2909     case BINOP_SUB:
2910     case BINOP_MUL:
2911     case BINOP_DIV:
2912       return (!(numeric_type_p (type0) && numeric_type_p (type1)));
2913
2914     case BINOP_REM:
2915     case BINOP_MOD:
2916     case BINOP_BITWISE_AND:
2917     case BINOP_BITWISE_IOR:
2918     case BINOP_BITWISE_XOR:
2919       return (!(integer_type_p (type0) && integer_type_p (type1)));
2920
2921     case BINOP_EQUAL:
2922     case BINOP_NOTEQUAL:
2923     case BINOP_LESS:
2924     case BINOP_GTR:
2925     case BINOP_LEQ:
2926     case BINOP_GEQ:
2927       return (!(scalar_type_p (type0) && scalar_type_p (type1)));
2928
2929     case BINOP_CONCAT:
2930       return ((TYPE_CODE (type0) != TYPE_CODE_ARRAY &&
2931                (TYPE_CODE (type0) != TYPE_CODE_PTR ||
2932                 TYPE_CODE (TYPE_TARGET_TYPE (type0))
2933                 != TYPE_CODE_ARRAY))
2934               || (TYPE_CODE (type1) != TYPE_CODE_ARRAY &&
2935                   (TYPE_CODE (type1) != TYPE_CODE_PTR ||
2936                    TYPE_CODE (TYPE_TARGET_TYPE (type1)) != TYPE_CODE_ARRAY)));
2937
2938     case BINOP_EXP:
2939       return (!(numeric_type_p (type0) && integer_type_p (type1)));
2940
2941     case UNOP_NEG:
2942     case UNOP_PLUS:
2943     case UNOP_LOGICAL_NOT:
2944     case UNOP_ABS:
2945       return (!numeric_type_p (type0));
2946
2947     }
2948 }
2949 \f
2950                                 /* Renaming */
2951
2952 /** NOTE: In the following, we assume that a renaming type's name may
2953  *  have an ___XD suffix.  It would be nice if this went away at some
2954  *  point. */
2955
2956 /* If TYPE encodes a renaming, returns the renaming suffix, which
2957  * is XR for an object renaming, XRP for a procedure renaming, XRE for
2958  * an exception renaming, and XRS for a subprogram renaming.  Returns
2959  * NULL if NAME encodes none of these. */
2960 const char *
2961 ada_renaming_type (struct type *type)
2962 {
2963   if (type != NULL && TYPE_CODE (type) == TYPE_CODE_ENUM)
2964     {
2965       const char *name = type_name_no_tag (type);
2966       const char *suffix = (name == NULL) ? NULL : strstr (name, "___XR");
2967       if (suffix == NULL
2968           || (suffix[5] != '\000' && strchr ("PES_", suffix[5]) == NULL))
2969         return NULL;
2970       else
2971         return suffix + 3;
2972     }
2973   else
2974     return NULL;
2975 }
2976
2977 /* Return non-zero iff SYM encodes an object renaming. */
2978 int
2979 ada_is_object_renaming (struct symbol *sym)
2980 {
2981   const char *renaming_type = ada_renaming_type (SYMBOL_TYPE (sym));
2982   return renaming_type != NULL
2983     && (renaming_type[2] == '\0' || renaming_type[2] == '_');
2984 }
2985
2986 /* Assuming that SYM encodes a non-object renaming, returns the original
2987  * name of the renamed entity.   The name is good until the end of
2988  * parsing. */
2989 const char *
2990 ada_simple_renamed_entity (struct symbol *sym)
2991 {
2992   struct type *type;
2993   const char *raw_name;
2994   int len;
2995   char *result;
2996
2997   type = SYMBOL_TYPE (sym);
2998   if (type == NULL || TYPE_NFIELDS (type) < 1)
2999     error ("Improperly encoded renaming.");
3000
3001   raw_name = TYPE_FIELD_NAME (type, 0);
3002   len = (raw_name == NULL ? 0 : strlen (raw_name)) - 5;
3003   if (len <= 0)
3004     error ("Improperly encoded renaming.");
3005
3006   result = xmalloc (len + 1);
3007   /* FIXME: add_name_string_cleanup should be defined in parse.c */
3008   /*  add_name_string_cleanup (result); */
3009   strncpy (result, raw_name, len);
3010   result[len] = '\000';
3011   return result;
3012 }
3013 \f
3014
3015                                 /* Evaluation: Function Calls */
3016
3017 /* Copy VAL onto the stack, using and updating *SP as the stack
3018    pointer. Return VAL as an lvalue. */
3019
3020 static struct value *
3021 place_on_stack (struct value *val, CORE_ADDR *sp)
3022 {
3023   CORE_ADDR old_sp = *sp;
3024
3025 #ifdef DEPRECATED_STACK_ALIGN
3026   *sp = push_bytes (*sp, VALUE_CONTENTS_RAW (val),
3027                     DEPRECATED_STACK_ALIGN (TYPE_LENGTH
3028                                  (check_typedef (VALUE_TYPE (val)))));
3029 #else
3030   *sp = push_bytes (*sp, VALUE_CONTENTS_RAW (val),
3031                     TYPE_LENGTH (check_typedef (VALUE_TYPE (val))));
3032 #endif
3033
3034   VALUE_LVAL (val) = lval_memory;
3035   if (INNER_THAN (1, 2))
3036     VALUE_ADDRESS (val) = *sp;
3037   else
3038     VALUE_ADDRESS (val) = old_sp;
3039
3040   return val;
3041 }
3042
3043 /* Return the value ACTUAL, converted to be an appropriate value for a
3044    formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
3045    allocating any necessary descriptors (fat pointers), or copies of
3046    values not residing in memory, updating it as needed. */
3047
3048 static struct value *
3049 convert_actual (struct value *actual, struct type *formal_type0,
3050                 CORE_ADDR *sp)
3051 {
3052   struct type *actual_type = check_typedef (VALUE_TYPE (actual));
3053   struct type *formal_type = check_typedef (formal_type0);
3054   struct type *formal_target =
3055     TYPE_CODE (formal_type) == TYPE_CODE_PTR
3056     ? check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
3057   struct type *actual_target =
3058     TYPE_CODE (actual_type) == TYPE_CODE_PTR
3059     ? check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
3060
3061   if (ada_is_array_descriptor (formal_target)
3062       && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
3063     return make_array_descriptor (formal_type, actual, sp);
3064   else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR)
3065     {
3066       if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
3067           && ada_is_array_descriptor (actual_target))
3068         return desc_data (actual);
3069       else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
3070         {
3071           if (VALUE_LVAL (actual) != lval_memory)
3072             {
3073               struct value *val;
3074               actual_type = check_typedef (VALUE_TYPE (actual));
3075               val = allocate_value (actual_type);
3076               memcpy ((char *) VALUE_CONTENTS_RAW (val),
3077                       (char *) VALUE_CONTENTS (actual),
3078                       TYPE_LENGTH (actual_type));
3079               actual = place_on_stack (val, sp);
3080             }
3081           return value_addr (actual);
3082         }
3083     }
3084   else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
3085     return ada_value_ind (actual);
3086
3087   return actual;
3088 }
3089
3090
3091 /* Push a descriptor of type TYPE for array value ARR on the stack at
3092    *SP, updating *SP to reflect the new descriptor.  Return either
3093    an lvalue representing the new descriptor, or (if TYPE is a pointer-
3094    to-descriptor type rather than a descriptor type), a struct value*
3095    representing a pointer to this descriptor. */
3096
3097 static struct value *
3098 make_array_descriptor (struct type *type, struct value *arr, CORE_ADDR *sp)
3099 {
3100   struct type *bounds_type = desc_bounds_type (type);
3101   struct type *desc_type = desc_base_type (type);
3102   struct value *descriptor = allocate_value (desc_type);
3103   struct value *bounds = allocate_value (bounds_type);
3104   CORE_ADDR bounds_addr;
3105   int i;
3106
3107   for (i = ada_array_arity (check_typedef (VALUE_TYPE (arr))); i > 0; i -= 1)
3108     {
3109       modify_general_field (VALUE_CONTENTS (bounds),
3110                             value_as_long (ada_array_bound (arr, i, 0)),
3111                             desc_bound_bitpos (bounds_type, i, 0),
3112                             desc_bound_bitsize (bounds_type, i, 0));
3113       modify_general_field (VALUE_CONTENTS (bounds),
3114                             value_as_long (ada_array_bound (arr, i, 1)),
3115                             desc_bound_bitpos (bounds_type, i, 1),
3116                             desc_bound_bitsize (bounds_type, i, 1));
3117     }
3118
3119   bounds = place_on_stack (bounds, sp);
3120
3121   modify_general_field (VALUE_CONTENTS (descriptor),
3122                         arr,
3123                         fat_pntr_data_bitpos (desc_type),
3124                         fat_pntr_data_bitsize (desc_type));
3125   modify_general_field (VALUE_CONTENTS (descriptor),
3126                         VALUE_ADDRESS (bounds),
3127                         fat_pntr_bounds_bitpos (desc_type),
3128                         fat_pntr_bounds_bitsize (desc_type));
3129
3130   descriptor = place_on_stack (descriptor, sp);
3131
3132   if (TYPE_CODE (type) == TYPE_CODE_PTR)
3133     return value_addr (descriptor);
3134   else
3135     return descriptor;
3136 }
3137
3138
3139 /* Assuming a dummy frame has been established on the target, perform any
3140    conversions needed for calling function FUNC on the NARGS actual
3141    parameters in ARGS, other than standard C conversions.   Does
3142    nothing if FUNC does not have Ada-style prototype data, or if NARGS
3143    does not match the number of arguments expected.   Use *SP as a
3144    stack pointer for additional data that must be pushed, updating its
3145    value as needed. */
3146
3147 void
3148 ada_convert_actuals (struct value *func, int nargs, struct value *args[],
3149                      CORE_ADDR *sp)
3150 {
3151   int i;
3152
3153   if (TYPE_NFIELDS (VALUE_TYPE (func)) == 0
3154       || nargs != TYPE_NFIELDS (VALUE_TYPE (func)))
3155     return;
3156
3157   for (i = 0; i < nargs; i += 1)
3158     args[i] =
3159       convert_actual (args[i], TYPE_FIELD_TYPE (VALUE_TYPE (func), i), sp);
3160 }
3161 \f
3162
3163                                 /* Symbol Lookup */
3164
3165
3166 /* The vectors of symbols and blocks ultimately returned from */
3167 /* ada_lookup_symbol_list. */
3168
3169 /* Current size of defn_symbols and defn_blocks */
3170 static size_t defn_vector_size = 0;
3171
3172 /* Current number of symbols found. */
3173 static int ndefns = 0;
3174
3175 static struct symbol **defn_symbols = NULL;
3176 static struct block **defn_blocks = NULL;
3177
3178 /* Return the result of a standard (literal, C-like) lookup of NAME in
3179  * given DOMAIN. */
3180
3181 static struct symbol *
3182 standard_lookup (const char *name, domain_enum domain)
3183 {
3184   struct symbol *sym;
3185   sym = lookup_symbol (name, (struct block *) NULL, domain, 0, NULL);
3186   return sym;
3187 }
3188
3189
3190 /* Non-zero iff there is at least one non-function/non-enumeral symbol */
3191 /* in SYMS[0..N-1].  We treat enumerals as functions, since they */
3192 /* contend in overloading in the same way. */
3193 static int
3194 is_nonfunction (struct symbol *syms[], int n)
3195 {
3196   int i;
3197
3198   for (i = 0; i < n; i += 1)
3199     if (TYPE_CODE (SYMBOL_TYPE (syms[i])) != TYPE_CODE_FUNC
3200         && TYPE_CODE (SYMBOL_TYPE (syms[i])) != TYPE_CODE_ENUM)
3201       return 1;
3202
3203   return 0;
3204 }
3205
3206 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3207    struct types.  Otherwise, they may not. */
3208
3209 static int
3210 equiv_types (struct type *type0, struct type *type1)
3211 {
3212   if (type0 == type1)
3213     return 1;
3214   if (type0 == NULL || type1 == NULL
3215       || TYPE_CODE (type0) != TYPE_CODE (type1))
3216     return 0;
3217   if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
3218        || TYPE_CODE (type0) == TYPE_CODE_ENUM)
3219       && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
3220       && DEPRECATED_STREQ (ada_type_name (type0), ada_type_name (type1)))
3221     return 1;
3222
3223   return 0;
3224 }
3225
3226 /* True iff SYM0 represents the same entity as SYM1, or one that is
3227    no more defined than that of SYM1. */
3228
3229 static int
3230 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
3231 {
3232   if (sym0 == sym1)
3233     return 1;
3234   if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
3235       || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
3236     return 0;
3237
3238   switch (SYMBOL_CLASS (sym0))
3239     {
3240     case LOC_UNDEF:
3241       return 1;
3242     case LOC_TYPEDEF:
3243       {
3244         struct type *type0 = SYMBOL_TYPE (sym0);
3245         struct type *type1 = SYMBOL_TYPE (sym1);
3246         char *name0 = DEPRECATED_SYMBOL_NAME (sym0);
3247         char *name1 = DEPRECATED_SYMBOL_NAME (sym1);
3248         int len0 = strlen (name0);
3249         return
3250           TYPE_CODE (type0) == TYPE_CODE (type1)
3251           && (equiv_types (type0, type1)
3252               || (len0 < strlen (name1) && DEPRECATED_STREQN (name0, name1, len0)
3253                   && DEPRECATED_STREQN (name1 + len0, "___XV", 5)));
3254       }
3255     case LOC_CONST:
3256       return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
3257         && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
3258     default:
3259       return 0;
3260     }
3261 }
3262
3263 /* Append SYM to the end of defn_symbols, and BLOCK to the end of
3264    defn_blocks, updating ndefns, and expanding defn_symbols and
3265    defn_blocks as needed.   Do not include SYM if it is a duplicate.  */
3266
3267 static void
3268 add_defn_to_vec (struct symbol *sym, struct block *block)
3269 {
3270   int i;
3271   size_t tmp;
3272
3273   if (SYMBOL_TYPE (sym) != NULL)
3274     CHECK_TYPEDEF (SYMBOL_TYPE (sym));
3275   for (i = 0; i < ndefns; i += 1)
3276     {
3277       if (lesseq_defined_than (sym, defn_symbols[i]))
3278         return;
3279       else if (lesseq_defined_than (defn_symbols[i], sym))
3280         {
3281           defn_symbols[i] = sym;
3282           defn_blocks[i] = block;
3283           return;
3284         }
3285     }
3286
3287   tmp = defn_vector_size;
3288   GROW_VECT (defn_symbols, tmp, ndefns + 2);
3289   GROW_VECT (defn_blocks, defn_vector_size, ndefns + 2);
3290
3291   defn_symbols[ndefns] = sym;
3292   defn_blocks[ndefns] = block;
3293   ndefns += 1;
3294 }
3295
3296 /* Look, in partial_symtab PST, for symbol NAME in given domain.
3297    Check the global symbols if GLOBAL, the static symbols if not.  Do
3298    wild-card match if WILD. */
3299
3300 static struct partial_symbol *
3301 ada_lookup_partial_symbol (struct partial_symtab *pst, const char *name,
3302                            int global, domain_enum domain, int wild)
3303 {
3304   struct partial_symbol **start;
3305   int name_len = strlen (name);
3306   int length = (global ? pst->n_global_syms : pst->n_static_syms);
3307   int i;
3308
3309   if (length == 0)
3310     {
3311       return (NULL);
3312     }
3313
3314   start = (global ?
3315            pst->objfile->global_psymbols.list + pst->globals_offset :
3316            pst->objfile->static_psymbols.list + pst->statics_offset);
3317
3318   if (wild)
3319     {
3320       for (i = 0; i < length; i += 1)
3321         {
3322           struct partial_symbol *psym = start[i];
3323
3324           if (SYMBOL_DOMAIN (psym) == domain &&
3325               wild_match (name, name_len, DEPRECATED_SYMBOL_NAME (psym)))
3326             return psym;
3327         }
3328       return NULL;
3329     }
3330   else
3331     {
3332       if (global)
3333         {
3334           int U;
3335           i = 0;
3336           U = length - 1;
3337           while (U - i > 4)
3338             {
3339               int M = (U + i) >> 1;
3340               struct partial_symbol *psym = start[M];
3341               if (DEPRECATED_SYMBOL_NAME (psym)[0] < name[0])
3342                 i = M + 1;
3343               else if (DEPRECATED_SYMBOL_NAME (psym)[0] > name[0])
3344                 U = M - 1;
3345               else if (strcmp (DEPRECATED_SYMBOL_NAME (psym), name) < 0)
3346                 i = M + 1;
3347               else
3348                 U = M;
3349             }
3350         }
3351       else
3352         i = 0;
3353
3354       while (i < length)
3355         {
3356           struct partial_symbol *psym = start[i];
3357
3358           if (SYMBOL_DOMAIN (psym) == domain)
3359             {
3360               int cmp = strncmp (name, DEPRECATED_SYMBOL_NAME (psym), name_len);
3361
3362               if (cmp < 0)
3363                 {
3364                   if (global)
3365                     break;
3366                 }
3367               else if (cmp == 0
3368                        && is_name_suffix (DEPRECATED_SYMBOL_NAME (psym) + name_len))
3369                 return psym;
3370             }
3371           i += 1;
3372         }
3373
3374       if (global)
3375         {
3376           int U;
3377           i = 0;
3378           U = length - 1;
3379           while (U - i > 4)
3380             {
3381               int M = (U + i) >> 1;
3382               struct partial_symbol *psym = start[M];
3383               if (DEPRECATED_SYMBOL_NAME (psym)[0] < '_')
3384                 i = M + 1;
3385               else if (DEPRECATED_SYMBOL_NAME (psym)[0] > '_')
3386                 U = M - 1;
3387               else if (strcmp (DEPRECATED_SYMBOL_NAME (psym), "_ada_") < 0)
3388                 i = M + 1;
3389               else
3390                 U = M;
3391             }
3392         }
3393       else
3394         i = 0;
3395
3396       while (i < length)
3397         {
3398           struct partial_symbol *psym = start[i];
3399
3400           if (SYMBOL_DOMAIN (psym) == domain)
3401             {
3402               int cmp;
3403
3404               cmp = (int) '_' - (int) DEPRECATED_SYMBOL_NAME (psym)[0];
3405               if (cmp == 0)
3406                 {
3407                   cmp = strncmp ("_ada_", DEPRECATED_SYMBOL_NAME (psym), 5);
3408                   if (cmp == 0)
3409                     cmp = strncmp (name, DEPRECATED_SYMBOL_NAME (psym) + 5, name_len);
3410                 }
3411
3412               if (cmp < 0)
3413                 {
3414                   if (global)
3415                     break;
3416                 }
3417               else if (cmp == 0
3418                        && is_name_suffix (DEPRECATED_SYMBOL_NAME (psym) + name_len + 5))
3419                 return psym;
3420             }
3421           i += 1;
3422         }
3423
3424     }
3425   return NULL;
3426 }
3427
3428
3429 /* Find a symbol table containing symbol SYM or NULL if none.  */
3430 static struct symtab *
3431 symtab_for_sym (struct symbol *sym)
3432 {
3433   struct symtab *s;
3434   struct objfile *objfile;
3435   struct block *b;
3436   struct symbol *tmp_sym;
3437   struct dict_iterator iter;
3438   int j;
3439
3440   ALL_SYMTABS (objfile, s)
3441   {
3442     switch (SYMBOL_CLASS (sym))
3443       {
3444       case LOC_CONST:
3445       case LOC_STATIC:
3446       case LOC_TYPEDEF:
3447       case LOC_REGISTER:
3448       case LOC_LABEL:
3449       case LOC_BLOCK:
3450       case LOC_CONST_BYTES:
3451         b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
3452         ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
3453           return s;
3454         b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
3455         ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
3456           return s;
3457         break;
3458       default:
3459         break;
3460       }
3461     switch (SYMBOL_CLASS (sym))
3462       {
3463       case LOC_REGISTER:
3464       case LOC_ARG:
3465       case LOC_REF_ARG:
3466       case LOC_REGPARM:
3467       case LOC_REGPARM_ADDR:
3468       case LOC_LOCAL:
3469       case LOC_TYPEDEF:
3470       case LOC_LOCAL_ARG:
3471       case LOC_BASEREG:
3472       case LOC_BASEREG_ARG:
3473       case LOC_COMPUTED:
3474       case LOC_COMPUTED_ARG:
3475         for (j = FIRST_LOCAL_BLOCK;
3476              j < BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s)); j += 1)
3477           {
3478             b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), j);
3479             ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
3480               return s;
3481           }
3482         break;
3483       default:
3484         break;
3485       }
3486   }
3487   return NULL;
3488 }
3489
3490 /* Return a minimal symbol matching NAME according to Ada demangling
3491    rules. Returns NULL if there is no such minimal symbol. */
3492
3493 struct minimal_symbol *
3494 ada_lookup_minimal_symbol (const char *name)
3495 {
3496   struct objfile *objfile;
3497   struct minimal_symbol *msymbol;
3498   int wild_match = (strstr (name, "__") == NULL);
3499
3500   ALL_MSYMBOLS (objfile, msymbol)
3501   {
3502     if (ada_match_name (DEPRECATED_SYMBOL_NAME (msymbol), name, wild_match)
3503         && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
3504       return msymbol;
3505   }
3506
3507   return NULL;
3508 }
3509
3510 /* For all subprograms that statically enclose the subprogram of the
3511  * selected frame, add symbols matching identifier NAME in DOMAIN
3512  * and their blocks to vectors *defn_symbols and *defn_blocks, as for
3513  * ada_add_block_symbols (q.v.).   If WILD, treat as NAME with a
3514  * wildcard prefix.  At the moment, this function uses a heuristic to
3515  * find the frames of enclosing subprograms: it treats the
3516  * pointer-sized value at location 0 from the local-variable base of a
3517  * frame as a static link, and then searches up the call stack for a
3518  * frame with that same local-variable base. */
3519 static void
3520 add_symbols_from_enclosing_procs (const char *name, domain_enum domain,
3521                                   int wild_match)
3522 {
3523 #ifdef i386
3524   static struct symbol static_link_sym;
3525   static struct symbol *static_link;
3526
3527   struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
3528   struct frame_info *frame;
3529   struct frame_info *target_frame;
3530
3531   if (static_link == NULL)
3532     {
3533       /* Initialize the local variable symbol that stands for the
3534        * static link (when it exists). */
3535       static_link = &static_link_sym;
3536       DEPRECATED_SYMBOL_NAME (static_link) = "";
3537       SYMBOL_LANGUAGE (static_link) = language_unknown;
3538       SYMBOL_CLASS (static_link) = LOC_LOCAL;
3539       SYMBOL_DOMAIN (static_link) = VAR_DOMAIN;
3540       SYMBOL_TYPE (static_link) = lookup_pointer_type (builtin_type_void);
3541       SYMBOL_VALUE (static_link) =
3542         -(long) TYPE_LENGTH (SYMBOL_TYPE (static_link));
3543     }
3544
3545   frame = deprecated_selected_frame;
3546   while (frame != NULL && ndefns == 0)
3547     {
3548       struct block *block;
3549       struct value *target_link_val = read_var_value (static_link, frame);
3550       CORE_ADDR target_link;
3551
3552       if (target_link_val == NULL)
3553         break;
3554       QUIT;
3555
3556       target_link = target_link_val;
3557       do
3558         {
3559           QUIT;
3560           frame = get_prev_frame (frame);
3561         }
3562       while (frame != NULL && DEPRECATED_FRAME_LOCALS_ADDRESS (frame) != target_link);
3563
3564       if (frame == NULL)
3565         break;
3566
3567       block = get_frame_block (frame, 0);
3568       while (block != NULL && block_function (block) != NULL && ndefns == 0)
3569         {
3570           ada_add_block_symbols (block, name, domain, NULL, wild_match);
3571
3572           block = BLOCK_SUPERBLOCK (block);
3573         }
3574     }
3575
3576   do_cleanups (old_chain);
3577 #endif
3578 }
3579
3580 /* True if TYPE is definitely an artificial type supplied to a symbol
3581  * for which no debugging information was given in the symbol file. */
3582 static int
3583 is_nondebugging_type (struct type *type)
3584 {
3585   char *name = ada_type_name (type);
3586   return (name != NULL && DEPRECATED_STREQ (name, "<variable, no debug info>"));
3587 }
3588
3589 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
3590  * duplicate other symbols in the list.  (The only case I know of where
3591  * this happens is when object files containing stabs-in-ecoff are
3592  * linked with files containing ordinary ecoff debugging symbols (or no
3593  * debugging symbols)). Modifies SYMS to squeeze out deleted symbols,
3594  * and applies the same modification to BLOCKS to maintain the
3595  * correspondence between SYMS[i] and BLOCKS[i].  Returns the number
3596  * of symbols in the modified list. */
3597 static int
3598 remove_extra_symbols (struct symbol **syms, struct block **blocks, int nsyms)
3599 {
3600   int i, j;
3601
3602   i = 0;
3603   while (i < nsyms)
3604     {
3605       if (DEPRECATED_SYMBOL_NAME (syms[i]) != NULL
3606           && SYMBOL_CLASS (syms[i]) == LOC_STATIC
3607           && is_nondebugging_type (SYMBOL_TYPE (syms[i])))
3608         {
3609           for (j = 0; j < nsyms; j += 1)
3610             {
3611               if (i != j
3612                   && DEPRECATED_SYMBOL_NAME (syms[j]) != NULL
3613                   && DEPRECATED_STREQ (DEPRECATED_SYMBOL_NAME (syms[i]), DEPRECATED_SYMBOL_NAME (syms[j]))
3614                   && SYMBOL_CLASS (syms[i]) == SYMBOL_CLASS (syms[j])
3615                   && SYMBOL_VALUE_ADDRESS (syms[i])
3616                   == SYMBOL_VALUE_ADDRESS (syms[j]))
3617                 {
3618                   int k;
3619                   for (k = i + 1; k < nsyms; k += 1)
3620                     {
3621                       syms[k - 1] = syms[k];
3622                       blocks[k - 1] = blocks[k];
3623                     }
3624                   nsyms -= 1;
3625                   goto NextSymbol;
3626                 }
3627             }
3628         }
3629       i += 1;
3630     NextSymbol:
3631       ;
3632     }
3633   return nsyms;
3634 }
3635
3636 /* Find symbols in DOMAIN matching NAME, in BLOCK0 and enclosing
3637    scope and in global scopes, returning the number of matches.  Sets
3638    *SYMS to point to a vector of matching symbols, with *BLOCKS
3639    pointing to the vector of corresponding blocks in which those
3640    symbols reside.  These two vectors are transient---good only to the
3641    next call of ada_lookup_symbol_list.  Any non-function/non-enumeral symbol
3642    match within the nest of blocks whose innermost member is BLOCK0,
3643    is the outermost match returned (no other matches in that or
3644    enclosing blocks is returned).  If there are any matches in or
3645    surrounding BLOCK0, then these alone are returned. */
3646
3647 int
3648 ada_lookup_symbol_list (const char *name, struct block *block0,
3649                         domain_enum domain, struct symbol ***syms,
3650                         struct block ***blocks)
3651 {
3652   struct symbol *sym;
3653   struct symtab *s;
3654   struct partial_symtab *ps;
3655   struct blockvector *bv;
3656   struct objfile *objfile;
3657   struct block *b;
3658   struct block *block;
3659   struct minimal_symbol *msymbol;
3660   int wild_match = (strstr (name, "__") == NULL);
3661   int cacheIfUnique;
3662
3663 #ifdef TIMING
3664   markTimeStart (0);
3665 #endif
3666
3667   ndefns = 0;
3668   cacheIfUnique = 0;
3669
3670   /* Search specified block and its superiors.  */
3671
3672   block = block0;
3673   while (block != NULL)
3674     {
3675       ada_add_block_symbols (block, name, domain, NULL, wild_match);
3676
3677       /* If we found a non-function match, assume that's the one. */
3678       if (is_nonfunction (defn_symbols, ndefns))
3679         goto done;
3680
3681       block = BLOCK_SUPERBLOCK (block);
3682     }
3683
3684   /* If we found ANY matches in the specified BLOCK, we're done. */
3685
3686   if (ndefns > 0)
3687     goto done;
3688
3689   cacheIfUnique = 1;
3690
3691   /* Now add symbols from all global blocks: symbol tables, minimal symbol
3692      tables, and psymtab's */
3693
3694   ALL_SYMTABS (objfile, s)
3695   {
3696     QUIT;
3697     if (!s->primary)
3698       continue;
3699     bv = BLOCKVECTOR (s);
3700     block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
3701     ada_add_block_symbols (block, name, domain, objfile, wild_match);
3702   }
3703
3704   if (domain == VAR_DOMAIN)
3705     {
3706       ALL_MSYMBOLS (objfile, msymbol)
3707       {
3708         if (ada_match_name (DEPRECATED_SYMBOL_NAME (msymbol), name, wild_match))
3709           {
3710             switch (MSYMBOL_TYPE (msymbol))
3711               {
3712               case mst_solib_trampoline:
3713                 break;
3714               default:
3715                 s = find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol));
3716                 if (s != NULL)
3717                   {
3718                     int old_ndefns = ndefns;
3719                     QUIT;
3720                     bv = BLOCKVECTOR (s);
3721                     block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
3722                     ada_add_block_symbols (block,
3723                                            DEPRECATED_SYMBOL_NAME (msymbol),
3724                                            domain, objfile, wild_match);
3725                     if (ndefns == old_ndefns)
3726                       {
3727                         block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
3728                         ada_add_block_symbols (block,
3729                                                DEPRECATED_SYMBOL_NAME (msymbol),
3730                                                domain, objfile,
3731                                                wild_match);
3732                       }
3733                   }
3734               }
3735           }
3736       }
3737     }
3738
3739   ALL_PSYMTABS (objfile, ps)
3740   {
3741     QUIT;
3742     if (!ps->readin
3743         && ada_lookup_partial_symbol (ps, name, 1, domain, wild_match))
3744       {
3745         s = PSYMTAB_TO_SYMTAB (ps);
3746         if (!s->primary)
3747           continue;
3748         bv = BLOCKVECTOR (s);
3749         block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
3750         ada_add_block_symbols (block, name, domain, objfile, wild_match);
3751       }
3752   }
3753
3754   /* Now add symbols from all per-file blocks if we've gotten no hits.
3755      (Not strictly correct, but perhaps better than an error).
3756      Do the symtabs first, then check the psymtabs */
3757
3758   if (ndefns == 0)
3759     {
3760
3761       ALL_SYMTABS (objfile, s)
3762       {
3763         QUIT;
3764         if (!s->primary)
3765           continue;
3766         bv = BLOCKVECTOR (s);
3767         block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
3768         ada_add_block_symbols (block, name, domain, objfile, wild_match);
3769       }
3770
3771       ALL_PSYMTABS (objfile, ps)
3772       {
3773         QUIT;
3774         if (!ps->readin
3775             && ada_lookup_partial_symbol (ps, name, 0, domain, wild_match))
3776           {
3777             s = PSYMTAB_TO_SYMTAB (ps);
3778             bv = BLOCKVECTOR (s);
3779             if (!s->primary)
3780               continue;
3781             block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
3782             ada_add_block_symbols (block, name, domain,
3783                                    objfile, wild_match);
3784           }
3785       }
3786     }
3787
3788   /* Finally, we try to find NAME as a local symbol in some lexically
3789      enclosing block.  We do this last, expecting this case to be
3790      rare. */
3791   if (ndefns == 0)
3792     {
3793       add_symbols_from_enclosing_procs (name, domain, wild_match);
3794       if (ndefns > 0)
3795         goto done;
3796     }
3797
3798 done:
3799   ndefns = remove_extra_symbols (defn_symbols, defn_blocks, ndefns);
3800
3801
3802   *syms = defn_symbols;
3803   *blocks = defn_blocks;
3804 #ifdef TIMING
3805   markTimeStop (0);
3806 #endif
3807   return ndefns;
3808 }
3809
3810 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
3811  * scope and in global scopes, or NULL if none.  NAME is folded to
3812  * lower case first, unless it is surrounded in single quotes.
3813  * Otherwise, the result is as for ada_lookup_symbol_list, but is
3814  * disambiguated by user query if needed. */
3815
3816 struct symbol *
3817 ada_lookup_symbol (const char *name, struct block *block0,
3818                    domain_enum domain)
3819 {
3820   struct symbol **candidate_syms;
3821   struct block **candidate_blocks;
3822   int n_candidates;
3823
3824   n_candidates = ada_lookup_symbol_list (name,
3825                                          block0, domain,
3826                                          &candidate_syms, &candidate_blocks);
3827
3828   if (n_candidates == 0)
3829     return NULL;
3830   else if (n_candidates != 1)
3831     user_select_syms (candidate_syms, candidate_blocks, n_candidates, 1);
3832
3833   return candidate_syms[0];
3834 }
3835
3836
3837 /* True iff STR is a possible encoded suffix of a normal Ada name
3838  * that is to be ignored for matching purposes.  Suffixes of parallel
3839  * names (e.g., XVE) are not included here.  Currently, the possible suffixes
3840  * are given by the regular expression:
3841  *        (X[nb]*)?(__[0-9]+|\$[0-9]+|___(LJM|X([FDBUP].*|R[^T]?)))?$
3842  *
3843  */
3844 static int
3845 is_name_suffix (const char *str)
3846 {
3847   int k;
3848   if (str[0] == 'X')
3849     {
3850       str += 1;
3851       while (str[0] != '_' && str[0] != '\0')
3852         {
3853           if (str[0] != 'n' && str[0] != 'b')
3854             return 0;
3855           str += 1;
3856         }
3857     }
3858   if (str[0] == '\000')
3859     return 1;
3860   if (str[0] == '_')
3861     {
3862       if (str[1] != '_' || str[2] == '\000')
3863         return 0;
3864       if (str[2] == '_')
3865         {
3866           if (DEPRECATED_STREQ (str + 3, "LJM"))
3867             return 1;
3868           if (str[3] != 'X')
3869             return 0;
3870           if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B' ||
3871               str[4] == 'U' || str[4] == 'P')
3872             return 1;
3873           if (str[4] == 'R' && str[5] != 'T')
3874             return 1;
3875           return 0;
3876         }
3877       for (k = 2; str[k] != '\0'; k += 1)
3878         if (!isdigit (str[k]))
3879           return 0;
3880       return 1;
3881     }
3882   if (str[0] == '$' && str[1] != '\000')
3883     {
3884       for (k = 1; str[k] != '\0'; k += 1)
3885         if (!isdigit (str[k]))
3886           return 0;
3887       return 1;
3888     }
3889   return 0;
3890 }
3891
3892 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
3893  * PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1.  Ignores
3894  * informational suffixes of NAME (i.e., for which is_name_suffix is
3895  * true). */
3896 static int
3897 wild_match (const char *patn, int patn_len, const char *name)
3898 {
3899   int name_len;
3900   int s, e;
3901
3902   name_len = strlen (name);
3903   if (name_len >= patn_len + 5 && DEPRECATED_STREQN (name, "_ada_", 5)
3904       && DEPRECATED_STREQN (patn, name + 5, patn_len)
3905       && is_name_suffix (name + patn_len + 5))
3906     return 1;
3907
3908   while (name_len >= patn_len)
3909     {
3910       if (DEPRECATED_STREQN (patn, name, patn_len) && is_name_suffix (name + patn_len))
3911         return 1;
3912       do
3913         {
3914           name += 1;
3915           name_len -= 1;
3916         }
3917       while (name_len > 0
3918              && name[0] != '.' && (name[0] != '_' || name[1] != '_'));
3919       if (name_len <= 0)
3920         return 0;
3921       if (name[0] == '_')
3922         {
3923           if (!islower (name[2]))
3924             return 0;
3925           name += 2;
3926           name_len -= 2;
3927         }
3928       else
3929         {
3930           if (!islower (name[1]))
3931             return 0;
3932           name += 1;
3933           name_len -= 1;
3934         }
3935     }
3936
3937   return 0;
3938 }
3939
3940
3941 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
3942    vector *defn_symbols, updating *defn_symbols (if necessary), *SZ (the size of
3943    the vector *defn_symbols), and *ndefns (the number of symbols
3944    currently stored in *defn_symbols).  If WILD, treat as NAME with a
3945    wildcard prefix. OBJFILE is the section containing BLOCK. */
3946
3947 static void
3948 ada_add_block_symbols (struct block *block, const char *name,
3949                        domain_enum domain, struct objfile *objfile,
3950                        int wild)
3951 {
3952   struct dict_iterator iter;
3953   int name_len = strlen (name);
3954   /* A matching argument symbol, if any. */
3955   struct symbol *arg_sym;
3956   /* Set true when we find a matching non-argument symbol */
3957   int found_sym;
3958   struct symbol *sym;
3959
3960   arg_sym = NULL;
3961   found_sym = 0;
3962   if (wild)
3963     {
3964       struct symbol *sym;
3965       ALL_BLOCK_SYMBOLS (block, iter, sym)
3966       {
3967         if (SYMBOL_DOMAIN (sym) == domain &&
3968             wild_match (name, name_len, DEPRECATED_SYMBOL_NAME (sym)))
3969           {
3970             switch (SYMBOL_CLASS (sym))
3971               {
3972               case LOC_ARG:
3973               case LOC_LOCAL_ARG:
3974               case LOC_REF_ARG:
3975               case LOC_REGPARM:
3976               case LOC_REGPARM_ADDR:
3977               case LOC_BASEREG_ARG:
3978               case LOC_COMPUTED_ARG:
3979                 arg_sym = sym;
3980                 break;
3981               case LOC_UNRESOLVED:
3982                 continue;
3983               default:
3984                 found_sym = 1;
3985                 fill_in_ada_prototype (sym);
3986                 add_defn_to_vec (fixup_symbol_section (sym, objfile), block);
3987                 break;
3988               }
3989           }
3990       }
3991     }
3992   else
3993     {
3994       ALL_BLOCK_SYMBOLS (block, iter, sym)
3995           {
3996             if (SYMBOL_DOMAIN (sym) == domain)
3997               {
3998                 int cmp = strncmp (name, DEPRECATED_SYMBOL_NAME (sym), name_len);
3999
4000                 if (cmp == 0
4001                     && is_name_suffix (DEPRECATED_SYMBOL_NAME (sym) + name_len))
4002                   {
4003                     switch (SYMBOL_CLASS (sym))
4004                       {
4005                       case LOC_ARG:
4006                       case LOC_LOCAL_ARG:
4007                       case LOC_REF_ARG:
4008                       case LOC_REGPARM:
4009                       case LOC_REGPARM_ADDR:
4010                       case LOC_BASEREG_ARG:
4011                       case LOC_COMPUTED_ARG:
4012                         arg_sym = sym;
4013                         break;
4014                       case LOC_UNRESOLVED:
4015                         break;
4016                       default:
4017                         found_sym = 1;
4018                         fill_in_ada_prototype (sym);
4019                         add_defn_to_vec (fixup_symbol_section (sym, objfile),
4020                                          block);
4021                         break;
4022                       }
4023                   }
4024               }
4025           }
4026     }
4027
4028   if (!found_sym && arg_sym != NULL)
4029     {
4030       fill_in_ada_prototype (arg_sym);
4031       add_defn_to_vec (fixup_symbol_section (arg_sym, objfile), block);
4032     }
4033
4034   if (!wild)
4035     {
4036       arg_sym = NULL;
4037       found_sym = 0;
4038
4039       ALL_BLOCK_SYMBOLS (block, iter, sym)
4040           {
4041             if (SYMBOL_DOMAIN (sym) == domain)
4042               {
4043                 int cmp;
4044
4045                 cmp = (int) '_' - (int) DEPRECATED_SYMBOL_NAME (sym)[0];
4046                 if (cmp == 0)
4047                   {
4048                     cmp = strncmp ("_ada_", DEPRECATED_SYMBOL_NAME (sym), 5);
4049                     if (cmp == 0)
4050                       cmp = strncmp (name, DEPRECATED_SYMBOL_NAME (sym) + 5, name_len);
4051                   }
4052
4053                 if (cmp == 0
4054                     && is_name_suffix (DEPRECATED_SYMBOL_NAME (sym) + name_len + 5))
4055                   {
4056                     switch (SYMBOL_CLASS (sym))
4057                       {
4058                       case LOC_ARG:
4059                       case LOC_LOCAL_ARG:
4060                       case LOC_REF_ARG:
4061                       case LOC_REGPARM:
4062                       case LOC_REGPARM_ADDR:
4063                       case LOC_BASEREG_ARG:
4064                       case LOC_COMPUTED_ARG:
4065                         arg_sym = sym;
4066                         break;
4067                       case LOC_UNRESOLVED:
4068                         break;
4069                       default:
4070                         found_sym = 1;
4071                         fill_in_ada_prototype (sym);
4072                         add_defn_to_vec (fixup_symbol_section (sym, objfile),
4073                                          block);
4074                         break;
4075                       }
4076                   }
4077               }
4078           }
4079
4080       /* NOTE: This really shouldn't be needed for _ada_ symbols.
4081          They aren't parameters, right? */
4082       if (!found_sym && arg_sym != NULL)
4083         {
4084           fill_in_ada_prototype (arg_sym);
4085           add_defn_to_vec (fixup_symbol_section (arg_sym, objfile), block);
4086         }
4087     }
4088 }
4089 \f
4090
4091                                 /* Function Types */
4092
4093 /* Assuming that SYM is the symbol for a function, fill in its type
4094    with prototype information, if it is not already there.  */
4095
4096 static void
4097 fill_in_ada_prototype (struct symbol *func)
4098 {
4099   struct block *b;
4100   int nargs, nsyms;
4101   struct dict_iterator iter;
4102   struct type *ftype;
4103   struct type *rtype;
4104   size_t max_fields;
4105   struct symbol *sym;
4106
4107   if (func == NULL
4108       || TYPE_CODE (SYMBOL_TYPE (func)) != TYPE_CODE_FUNC
4109       || TYPE_FIELDS (SYMBOL_TYPE (func)) != NULL)
4110     return;
4111
4112   /* We make each function type unique, so that each may have its own */
4113   /* parameter types.  This particular way of doing so wastes space: */
4114   /* it would be nicer to build the argument types while the original */
4115   /* function type is being built (FIXME). */
4116   rtype = check_typedef (TYPE_TARGET_TYPE (SYMBOL_TYPE (func)));
4117   ftype = alloc_type (TYPE_OBJFILE (SYMBOL_TYPE (func)));
4118   make_function_type (rtype, &ftype);
4119   SYMBOL_TYPE (func) = ftype;
4120
4121   b = SYMBOL_BLOCK_VALUE (func);
4122
4123   nargs = 0;
4124   max_fields = 8;
4125   TYPE_FIELDS (ftype) =
4126     (struct field *) xmalloc (sizeof (struct field) * max_fields);
4127   ALL_BLOCK_SYMBOLS (b, iter, sym)
4128   {
4129     GROW_VECT (TYPE_FIELDS (ftype), max_fields, nargs + 1);
4130
4131     switch (SYMBOL_CLASS (sym))
4132       {
4133       case LOC_REF_ARG:
4134       case LOC_REGPARM_ADDR:
4135         TYPE_FIELD_BITPOS (ftype, nargs) = nargs;
4136         TYPE_FIELD_BITSIZE (ftype, nargs) = 0;
4137         TYPE_FIELD_STATIC_KIND (ftype, nargs) = 0;
4138         TYPE_FIELD_TYPE (ftype, nargs) =
4139           lookup_pointer_type (check_typedef (SYMBOL_TYPE (sym)));
4140         TYPE_FIELD_NAME (ftype, nargs) = DEPRECATED_SYMBOL_NAME (sym);
4141         nargs += 1;
4142
4143         break;
4144
4145       case LOC_ARG:
4146       case LOC_REGPARM:
4147       case LOC_LOCAL_ARG:
4148       case LOC_BASEREG_ARG:
4149       case LOC_COMPUTED_ARG:
4150         TYPE_FIELD_BITPOS (ftype, nargs) = nargs;
4151         TYPE_FIELD_BITSIZE (ftype, nargs) = 0;
4152         TYPE_FIELD_STATIC_KIND (ftype, nargs) = 0;
4153         TYPE_FIELD_TYPE (ftype, nargs) = check_typedef (SYMBOL_TYPE (sym));
4154         TYPE_FIELD_NAME (ftype, nargs) = DEPRECATED_SYMBOL_NAME (sym);
4155         nargs += 1;
4156
4157         break;
4158
4159       default:
4160         break;
4161       }
4162   }
4163
4164   /* Re-allocate fields vector; if there are no fields, make the */
4165   /* fields pointer non-null anyway, to mark that this function type */
4166   /* has been filled in. */
4167
4168   TYPE_NFIELDS (ftype) = nargs;
4169   if (nargs == 0)
4170     {
4171       static struct field dummy_field = { 0, 0, 0, 0 };
4172       xfree (TYPE_FIELDS (ftype));
4173       TYPE_FIELDS (ftype) = &dummy_field;
4174     }
4175   else
4176     {
4177       struct field *fields =
4178         (struct field *) TYPE_ALLOC (ftype, nargs * sizeof (struct field));
4179       memcpy ((char *) fields,
4180               (char *) TYPE_FIELDS (ftype), nargs * sizeof (struct field));
4181       xfree (TYPE_FIELDS (ftype));
4182       TYPE_FIELDS (ftype) = fields;
4183     }
4184 }
4185 \f
4186
4187                                 /* Breakpoint-related */
4188
4189 char no_symtab_msg[] =
4190   "No symbol table is loaded.  Use the \"file\" command.";
4191
4192 /* Assuming that LINE is pointing at the beginning of an argument to
4193    'break', return a pointer to the delimiter for the initial segment
4194    of that name.  This is the first ':', ' ', or end of LINE.
4195 */
4196 char *
4197 ada_start_decode_line_1 (char *line)
4198 {
4199   /* [NOTE: strpbrk would be more elegant, but I am reluctant to be
4200      the first to use such a library function in GDB code.] */
4201   char *p;
4202   for (p = line; *p != '\000' && *p != ' ' && *p != ':'; p += 1)
4203     ;
4204   return p;
4205 }
4206
4207 /* *SPEC points to a function and line number spec (as in a break
4208    command), following any initial file name specification.
4209
4210    Return all symbol table/line specfications (sals) consistent with the
4211    information in *SPEC and FILE_TABLE in the
4212    following sense:
4213      + FILE_TABLE is null, or the sal refers to a line in the file
4214        named by FILE_TABLE.
4215      + If *SPEC points to an argument with a trailing ':LINENUM',
4216        then the sal refers to that line (or one following it as closely as
4217        possible).
4218      + If *SPEC does not start with '*', the sal is in a function with
4219        that name.
4220
4221    Returns with 0 elements if no matching non-minimal symbols found.
4222
4223    If *SPEC begins with a function name of the form <NAME>, then NAME
4224    is taken as a literal name; otherwise the function name is subject
4225    to the usual mangling.
4226
4227    *SPEC is updated to point after the function/line number specification.
4228
4229    FUNFIRSTLINE is non-zero if we desire the first line of real code
4230    in each function (this is ignored in the presence of a LINENUM spec.).
4231
4232    If CANONICAL is non-NULL, and if any of the sals require a
4233    'canonical line spec', then *CANONICAL is set to point to an array
4234    of strings, corresponding to and equal in length to the returned
4235    list of sals, such that (*CANONICAL)[i] is non-null and contains a
4236    canonical line spec for the ith returned sal, if needed.  If no
4237    canonical line specs are required and CANONICAL is non-null,
4238    *CANONICAL is set to NULL.
4239
4240    A 'canonical line spec' is simply a name (in the format of the
4241    breakpoint command) that uniquely identifies a breakpoint position,
4242    with no further contextual information or user selection.  It is
4243    needed whenever the file name, function name, and line number
4244    information supplied is insufficient for this unique
4245    identification.  Currently overloaded functions, the name '*',
4246    or static functions without a filename yield a canonical line spec.
4247    The array and the line spec strings are allocated on the heap; it
4248    is the caller's responsibility to free them.   */
4249
4250 struct symtabs_and_lines
4251 ada_finish_decode_line_1 (char **spec, struct symtab *file_table,
4252                           int funfirstline, char ***canonical)
4253 {
4254   struct symbol **symbols;
4255   struct block **blocks;
4256   struct block *block;
4257   int n_matches, i, line_num;
4258   struct symtabs_and_lines selected;
4259   struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
4260   char *name;
4261
4262   int len;
4263   char *lower_name;
4264   char *unquoted_name;
4265
4266   if (file_table == NULL)
4267     block = get_selected_block (NULL);
4268   else
4269     block = BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table), STATIC_BLOCK);
4270
4271   if (canonical != NULL)
4272     *canonical = (char **) NULL;
4273
4274   name = *spec;
4275   if (**spec == '*')
4276     *spec += 1;
4277   else
4278     {
4279       while (**spec != '\000' &&
4280              !strchr (ada_completer_word_break_characters, **spec))
4281         *spec += 1;
4282     }
4283   len = *spec - name;
4284
4285   line_num = -1;
4286   if (file_table != NULL && (*spec)[0] == ':' && isdigit ((*spec)[1]))
4287     {
4288       line_num = strtol (*spec + 1, spec, 10);
4289       while (**spec == ' ' || **spec == '\t')
4290         *spec += 1;
4291     }
4292
4293   if (name[0] == '*')
4294     {
4295       if (line_num == -1)
4296         error ("Wild-card function with no line number or file name.");
4297
4298       return all_sals_for_line (file_table->filename, line_num, canonical);
4299     }
4300
4301   if (name[0] == '\'')
4302     {
4303       name += 1;
4304       len -= 2;
4305     }
4306
4307   if (name[0] == '<')
4308     {
4309       unquoted_name = (char *) alloca (len - 1);
4310       memcpy (unquoted_name, name + 1, len - 2);
4311       unquoted_name[len - 2] = '\000';
4312       lower_name = NULL;
4313     }
4314   else
4315     {
4316       unquoted_name = (char *) alloca (len + 1);
4317       memcpy (unquoted_name, name, len);
4318       unquoted_name[len] = '\000';
4319       lower_name = (char *) alloca (len + 1);
4320       for (i = 0; i < len; i += 1)
4321         lower_name[i] = tolower (name[i]);
4322       lower_name[len] = '\000';
4323     }
4324
4325   n_matches = 0;
4326   if (lower_name != NULL)
4327     n_matches = ada_lookup_symbol_list (ada_mangle (lower_name), block,
4328                                         VAR_DOMAIN, &symbols, &blocks);
4329   if (n_matches == 0)
4330     n_matches = ada_lookup_symbol_list (unquoted_name, block,
4331                                         VAR_DOMAIN, &symbols, &blocks);
4332   if (n_matches == 0 && line_num >= 0)
4333     error ("No line number information found for %s.", unquoted_name);
4334   else if (n_matches == 0)
4335     {
4336 #ifdef HPPA_COMPILER_BUG
4337       /* FIXME: See comment in symtab.c::decode_line_1 */
4338 #undef volatile
4339       volatile struct symtab_and_line val;
4340 #define volatile                /*nothing */
4341 #else
4342       struct symtab_and_line val;
4343 #endif
4344       struct minimal_symbol *msymbol;
4345
4346       init_sal (&val);
4347
4348       msymbol = NULL;
4349       if (lower_name != NULL)
4350         msymbol = ada_lookup_minimal_symbol (ada_mangle (lower_name));
4351       if (msymbol == NULL)
4352         msymbol = ada_lookup_minimal_symbol (unquoted_name);
4353       if (msymbol != NULL)
4354         {
4355           val.pc = SYMBOL_VALUE_ADDRESS (msymbol);
4356           val.section = SYMBOL_BFD_SECTION (msymbol);
4357           if (funfirstline)
4358             {
4359               val.pc += FUNCTION_START_OFFSET;
4360               SKIP_PROLOGUE (val.pc);
4361             }
4362           selected.sals = (struct symtab_and_line *)
4363             xmalloc (sizeof (struct symtab_and_line));
4364           selected.sals[0] = val;
4365           selected.nelts = 1;
4366           return selected;
4367         }
4368
4369       if (!have_full_symbols () &&
4370           !have_partial_symbols () && !have_minimal_symbols ())
4371         error (no_symtab_msg);
4372
4373       error ("Function \"%s\" not defined.", unquoted_name);
4374       return selected;          /* for lint */
4375     }
4376
4377   if (line_num >= 0)
4378     {
4379       return
4380         find_sal_from_funcs_and_line (file_table->filename, line_num,
4381                                       symbols, n_matches);
4382     }
4383   else
4384     {
4385       selected.nelts =
4386         user_select_syms (symbols, blocks, n_matches, n_matches);
4387     }
4388
4389   selected.sals = (struct symtab_and_line *)
4390     xmalloc (sizeof (struct symtab_and_line) * selected.nelts);
4391   memset (selected.sals, 0, selected.nelts * sizeof (selected.sals[i]));
4392   make_cleanup (xfree, selected.sals);
4393
4394   i = 0;
4395   while (i < selected.nelts)
4396     {
4397       if (SYMBOL_CLASS (symbols[i]) == LOC_BLOCK)
4398         selected.sals[i] = find_function_start_sal (symbols[i], funfirstline);
4399       else if (SYMBOL_LINE (symbols[i]) != 0)
4400         {
4401           selected.sals[i].symtab = symtab_for_sym (symbols[i]);
4402           selected.sals[i].line = SYMBOL_LINE (symbols[i]);
4403         }
4404       else if (line_num >= 0)
4405         {
4406           /* Ignore this choice */
4407           symbols[i] = symbols[selected.nelts - 1];
4408           blocks[i] = blocks[selected.nelts - 1];
4409           selected.nelts -= 1;
4410           continue;
4411         }
4412       else
4413         error ("Line number not known for symbol \"%s\"", unquoted_name);
4414       i += 1;
4415     }
4416
4417   if (canonical != NULL && (line_num >= 0 || n_matches > 1))
4418     {
4419       *canonical = (char **) xmalloc (sizeof (char *) * selected.nelts);
4420       for (i = 0; i < selected.nelts; i += 1)
4421         (*canonical)[i] =
4422           extended_canonical_line_spec (selected.sals[i],
4423                                         SYMBOL_PRINT_NAME (symbols[i]));
4424     }
4425
4426   discard_cleanups (old_chain);
4427   return selected;
4428 }
4429
4430 /* The (single) sal corresponding to line LINE_NUM in a symbol table
4431    with file name FILENAME that occurs in one of the functions listed
4432    in SYMBOLS[0 .. NSYMS-1]. */
4433 static struct symtabs_and_lines
4434 find_sal_from_funcs_and_line (const char *filename, int line_num,
4435                               struct symbol **symbols, int nsyms)
4436 {
4437   struct symtabs_and_lines sals;
4438   int best_index, best;
4439   struct linetable *best_linetable;
4440   struct objfile *objfile;
4441   struct symtab *s;
4442   struct symtab *best_symtab;
4443
4444   read_all_symtabs (filename);
4445
4446   best_index = 0;
4447   best_linetable = NULL;
4448   best_symtab = NULL;
4449   best = 0;
4450   ALL_SYMTABS (objfile, s)
4451   {
4452     struct linetable *l;
4453     int ind, exact;
4454
4455     QUIT;
4456
4457     if (!DEPRECATED_STREQ (filename, s->filename))
4458       continue;
4459     l = LINETABLE (s);
4460     ind = find_line_in_linetable (l, line_num, symbols, nsyms, &exact);
4461     if (ind >= 0)
4462       {
4463         if (exact)
4464           {
4465             best_index = ind;
4466             best_linetable = l;
4467             best_symtab = s;
4468             goto done;
4469           }
4470         if (best == 0 || l->item[ind].line < best)
4471           {
4472             best = l->item[ind].line;
4473             best_index = ind;
4474             best_linetable = l;
4475             best_symtab = s;
4476           }
4477       }
4478   }
4479
4480   if (best == 0)
4481     error ("Line number not found in designated function.");
4482
4483 done:
4484
4485   sals.nelts = 1;
4486   sals.sals = (struct symtab_and_line *) xmalloc (sizeof (sals.sals[0]));
4487
4488   init_sal (&sals.sals[0]);
4489
4490   sals.sals[0].line = best_linetable->item[best_index].line;
4491   sals.sals[0].pc = best_linetable->item[best_index].pc;
4492   sals.sals[0].symtab = best_symtab;
4493
4494   return sals;
4495 }
4496
4497 /* Return the index in LINETABLE of the best match for LINE_NUM whose
4498    pc falls within one of the functions denoted by SYMBOLS[0..NSYMS-1].
4499    Set *EXACTP to the 1 if the match is exact, and 0 otherwise. */
4500 static int
4501 find_line_in_linetable (struct linetable *linetable, int line_num,
4502                         struct symbol **symbols, int nsyms, int *exactp)
4503 {
4504   int i, len, best_index, best;
4505
4506   if (line_num <= 0 || linetable == NULL)
4507     return -1;
4508
4509   len = linetable->nitems;
4510   for (i = 0, best_index = -1, best = 0; i < len; i += 1)
4511     {
4512       int k;
4513       struct linetable_entry *item = &(linetable->item[i]);
4514
4515       for (k = 0; k < nsyms; k += 1)
4516         {
4517           if (symbols[k] != NULL && SYMBOL_CLASS (symbols[k]) == LOC_BLOCK
4518               && item->pc >= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols[k]))
4519               && item->pc < BLOCK_END (SYMBOL_BLOCK_VALUE (symbols[k])))
4520             goto candidate;
4521         }
4522       continue;
4523
4524     candidate:
4525
4526       if (item->line == line_num)
4527         {
4528           *exactp = 1;
4529           return i;
4530         }
4531
4532       if (item->line > line_num && (best == 0 || item->line < best))
4533         {
4534           best = item->line;
4535           best_index = i;
4536         }
4537     }
4538
4539   *exactp = 0;
4540   return best_index;
4541 }
4542
4543 /* Find the smallest k >= LINE_NUM such that k is a line number in
4544    LINETABLE, and k falls strictly within a named function that begins at
4545    or before LINE_NUM.  Return -1 if there is no such k. */
4546 static int
4547 nearest_line_number_in_linetable (struct linetable *linetable, int line_num)
4548 {
4549   int i, len, best;
4550
4551   if (line_num <= 0 || linetable == NULL || linetable->nitems == 0)
4552     return -1;
4553   len = linetable->nitems;
4554
4555   i = 0;
4556   best = INT_MAX;
4557   while (i < len)
4558     {
4559       int k;
4560       struct linetable_entry *item = &(linetable->item[i]);
4561
4562       if (item->line >= line_num && item->line < best)
4563         {
4564           char *func_name;
4565           CORE_ADDR start, end;
4566
4567           func_name = NULL;
4568           find_pc_partial_function (item->pc, &func_name, &start, &end);
4569
4570           if (func_name != NULL && item->pc < end)
4571             {
4572               if (item->line == line_num)
4573                 return line_num;
4574               else
4575                 {
4576                   struct symbol *sym =
4577                     standard_lookup (func_name, VAR_DOMAIN);
4578                   if (is_plausible_func_for_line (sym, line_num))
4579                     best = item->line;
4580                   else
4581                     {
4582                       do
4583                         i += 1;
4584                       while (i < len && linetable->item[i].pc < end);
4585                       continue;
4586                     }
4587                 }
4588             }
4589         }
4590
4591       i += 1;
4592     }
4593
4594   return (best == INT_MAX) ? -1 : best;
4595 }
4596
4597
4598 /* Return the next higher index, k, into LINETABLE such that k > IND,
4599    entry k in LINETABLE has a line number equal to LINE_NUM, k
4600    corresponds to a PC that is in a function different from that
4601    corresponding to IND, and falls strictly within a named function
4602    that begins at a line at or preceding STARTING_LINE.
4603    Return -1 if there is no such k.
4604    IND == -1 corresponds to no function. */
4605
4606 static int
4607 find_next_line_in_linetable (struct linetable *linetable, int line_num,
4608                              int starting_line, int ind)
4609 {
4610   int i, len;
4611
4612   if (line_num <= 0 || linetable == NULL || ind >= linetable->nitems)
4613     return -1;
4614   len = linetable->nitems;
4615
4616   if (ind >= 0)
4617     {
4618       CORE_ADDR start, end;
4619
4620       if (find_pc_partial_function (linetable->item[ind].pc,
4621                                     (char **) NULL, &start, &end))
4622         {
4623           while (ind < len && linetable->item[ind].pc < end)
4624             ind += 1;
4625         }
4626       else
4627         ind += 1;
4628     }
4629   else
4630     ind = 0;
4631
4632   i = ind;
4633   while (i < len)
4634     {
4635       int k;
4636       struct linetable_entry *item = &(linetable->item[i]);
4637
4638       if (item->line >= line_num)
4639         {
4640           char *func_name;
4641           CORE_ADDR start, end;
4642
4643           func_name = NULL;
4644           find_pc_partial_function (item->pc, &func_name, &start, &end);
4645
4646           if (func_name != NULL && item->pc < end)
4647             {
4648               if (item->line == line_num)
4649                 {
4650                   struct symbol *sym =
4651                     standard_lookup (func_name, VAR_DOMAIN);
4652                   if (is_plausible_func_for_line (sym, starting_line))
4653                     return i;
4654                   else
4655                     {
4656                       while ((i + 1) < len && linetable->item[i + 1].pc < end)
4657                         i += 1;
4658                     }
4659                 }
4660             }
4661         }
4662       i += 1;
4663     }
4664
4665   return -1;
4666 }
4667
4668 /* True iff function symbol SYM starts somewhere at or before line #
4669    LINE_NUM. */
4670 static int
4671 is_plausible_func_for_line (struct symbol *sym, int line_num)
4672 {
4673   struct symtab_and_line start_sal;
4674
4675   if (sym == NULL)
4676     return 0;
4677
4678   start_sal = find_function_start_sal (sym, 0);
4679
4680   return (start_sal.line != 0 && line_num >= start_sal.line);
4681 }
4682
4683 static void
4684 debug_print_lines (struct linetable *lt)
4685 {
4686   int i;
4687
4688   if (lt == NULL)
4689     return;
4690
4691   fprintf (stderr, "\t");
4692   for (i = 0; i < lt->nitems; i += 1)
4693     fprintf (stderr, "(%d->%p) ", lt->item[i].line, (void *) lt->item[i].pc);
4694   fprintf (stderr, "\n");
4695 }
4696
4697 static void
4698 debug_print_block (struct block *b)
4699 {
4700   struct dict_iterator iter;
4701   struct symbol *sym;
4702
4703   fprintf (stderr, "Block: %p; [0x%lx, 0x%lx]",
4704            b, BLOCK_START (b), BLOCK_END (b));
4705   if (BLOCK_FUNCTION (b) != NULL)
4706     fprintf (stderr, " Function: %s", DEPRECATED_SYMBOL_NAME (BLOCK_FUNCTION (b)));
4707   fprintf (stderr, "\n");
4708   fprintf (stderr, "\t    Superblock: %p\n", BLOCK_SUPERBLOCK (b));
4709   fprintf (stderr, "\t    Symbols:");
4710   ALL_BLOCK_SYMBOLS (b, iter, sym)
4711   {
4712     fprintf (stderr, " %s", DEPRECATED_SYMBOL_NAME (sym));
4713   }
4714   fprintf (stderr, "\n");
4715 }
4716
4717 static void
4718 debug_print_blocks (struct blockvector *bv)
4719 {
4720   int i;
4721
4722   if (bv == NULL)
4723     return;
4724   for (i = 0; i < BLOCKVECTOR_NBLOCKS (bv); i += 1)
4725     {
4726       fprintf (stderr, "%6d. ", i);
4727       debug_print_block (BLOCKVECTOR_BLOCK (bv, i));
4728     }
4729 }
4730
4731 static void
4732 debug_print_symtab (struct symtab *s)
4733 {
4734   fprintf (stderr, "Symtab %p\n    File: %s; Dir: %s\n", s,
4735            s->filename, s->dirname);
4736   fprintf (stderr, "    Blockvector: %p, Primary: %d\n",
4737            BLOCKVECTOR (s), s->primary);
4738   debug_print_blocks (BLOCKVECTOR (s));
4739   fprintf (stderr, "    Line table: %p\n", LINETABLE (s));
4740   debug_print_lines (LINETABLE (s));
4741 }
4742
4743 /* Read in all symbol tables corresponding to partial symbol tables
4744    with file name FILENAME. */
4745 static void
4746 read_all_symtabs (const char *filename)
4747 {
4748   struct partial_symtab *ps;
4749   struct objfile *objfile;
4750
4751   ALL_PSYMTABS (objfile, ps)
4752   {
4753     QUIT;
4754
4755     if (DEPRECATED_STREQ (filename, ps->filename))
4756       PSYMTAB_TO_SYMTAB (ps);
4757   }
4758 }
4759
4760 /* All sals corresponding to line LINE_NUM in a symbol table from file
4761    FILENAME, as filtered by the user.  If CANONICAL is not null, set
4762    it to a corresponding array of canonical line specs. */
4763 static struct symtabs_and_lines
4764 all_sals_for_line (const char *filename, int line_num, char ***canonical)
4765 {
4766   struct symtabs_and_lines result;
4767   struct objfile *objfile;
4768   struct symtab *s;
4769   struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
4770   size_t len;
4771
4772   read_all_symtabs (filename);
4773
4774   result.sals =
4775     (struct symtab_and_line *) xmalloc (4 * sizeof (result.sals[0]));
4776   result.nelts = 0;
4777   len = 4;
4778   make_cleanup (free_current_contents, &result.sals);
4779
4780   ALL_SYMTABS (objfile, s)
4781   {
4782     int ind, target_line_num;
4783
4784     QUIT;
4785
4786     if (!DEPRECATED_STREQ (s->filename, filename))
4787       continue;
4788
4789     target_line_num =
4790       nearest_line_number_in_linetable (LINETABLE (s), line_num);
4791     if (target_line_num == -1)
4792       continue;
4793
4794     ind = -1;
4795     while (1)
4796       {
4797         ind =
4798           find_next_line_in_linetable (LINETABLE (s),
4799                                        target_line_num, line_num, ind);
4800
4801         if (ind < 0)
4802           break;
4803
4804         GROW_VECT (result.sals, len, result.nelts + 1);
4805         init_sal (&result.sals[result.nelts]);
4806         result.sals[result.nelts].line = LINETABLE (s)->item[ind].line;
4807         result.sals[result.nelts].pc = LINETABLE (s)->item[ind].pc;
4808         result.sals[result.nelts].symtab = s;
4809         result.nelts += 1;
4810       }
4811   }
4812
4813   if (canonical != NULL || result.nelts > 1)
4814     {
4815       int k;
4816       char **func_names = (char **) alloca (result.nelts * sizeof (char *));
4817       int first_choice = (result.nelts > 1) ? 2 : 1;
4818       int n;
4819       int *choices = (int *) alloca (result.nelts * sizeof (int));
4820
4821       for (k = 0; k < result.nelts; k += 1)
4822         {
4823           find_pc_partial_function (result.sals[k].pc, &func_names[k],
4824                                     (CORE_ADDR *) NULL, (CORE_ADDR *) NULL);
4825           if (func_names[k] == NULL)
4826             error ("Could not find function for one or more breakpoints.");
4827         }
4828
4829       if (result.nelts > 1)
4830         {
4831           printf_unfiltered ("[0] cancel\n");
4832           if (result.nelts > 1)
4833             printf_unfiltered ("[1] all\n");
4834           for (k = 0; k < result.nelts; k += 1)
4835             printf_unfiltered ("[%d] %s\n", k + first_choice,
4836                                ada_demangle (func_names[k]));
4837
4838           n = get_selections (choices, result.nelts, result.nelts,
4839                               result.nelts > 1, "instance-choice");
4840
4841           for (k = 0; k < n; k += 1)
4842             {
4843               result.sals[k] = result.sals[choices[k]];
4844               func_names[k] = func_names[choices[k]];
4845             }
4846           result.nelts = n;
4847         }
4848
4849       if (canonical != NULL)
4850         {
4851           *canonical = (char **) xmalloc (result.nelts * sizeof (char **));
4852           make_cleanup (xfree, *canonical);
4853           for (k = 0; k < result.nelts; k += 1)
4854             {
4855               (*canonical)[k] =
4856                 extended_canonical_line_spec (result.sals[k], func_names[k]);
4857               if ((*canonical)[k] == NULL)
4858                 error ("Could not locate one or more breakpoints.");
4859               make_cleanup (xfree, (*canonical)[k]);
4860             }
4861         }
4862     }
4863
4864   discard_cleanups (old_chain);
4865   return result;
4866 }
4867
4868
4869 /* A canonical line specification of the form FILE:NAME:LINENUM for
4870    symbol table and line data SAL.  NULL if insufficient
4871    information. The caller is responsible for releasing any space
4872    allocated. */
4873
4874 static char *
4875 extended_canonical_line_spec (struct symtab_and_line sal, const char *name)
4876 {
4877   char *r;
4878
4879   if (sal.symtab == NULL || sal.symtab->filename == NULL || sal.line <= 0)
4880     return NULL;
4881
4882   r = (char *) xmalloc (strlen (name) + strlen (sal.symtab->filename)
4883                         + sizeof (sal.line) * 3 + 3);
4884   sprintf (r, "%s:'%s':%d", sal.symtab->filename, name, sal.line);
4885   return r;
4886 }
4887
4888 #if 0
4889 int begin_bnum = -1;
4890 #endif
4891 int begin_annotate_level = 0;
4892
4893 static void
4894 begin_cleanup (void *dummy)
4895 {
4896   begin_annotate_level = 0;
4897 }
4898
4899 static void
4900 begin_command (char *args, int from_tty)
4901 {
4902   struct minimal_symbol *msym;
4903   CORE_ADDR main_program_name_addr;
4904   char main_program_name[1024];
4905   struct cleanup *old_chain = make_cleanup (begin_cleanup, NULL);
4906   begin_annotate_level = 2;
4907
4908   /* Check that there is a program to debug */
4909   if (!have_full_symbols () && !have_partial_symbols ())
4910     error ("No symbol table is loaded.  Use the \"file\" command.");
4911
4912   /* Check that we are debugging an Ada program */
4913   /*  if (ada_update_initial_language (language_unknown, NULL) != language_ada)
4914      error ("Cannot find the Ada initialization procedure.  Is this an Ada main program?");
4915    */
4916   /* FIXME: language_ada should be defined in defs.h */
4917
4918   /* Get the address of the name of the main procedure */
4919   msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
4920
4921   if (msym != NULL)
4922     {
4923       main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
4924       if (main_program_name_addr == 0)
4925         error ("Invalid address for Ada main program name.");
4926
4927       /* Read the name of the main procedure */
4928       extract_string (main_program_name_addr, main_program_name);
4929
4930       /* Put a temporary breakpoint in the Ada main program and run */
4931       do_command ("tbreak ", main_program_name, 0);
4932       do_command ("run ", args, 0);
4933     }
4934   else
4935     {
4936       /* If we could not find the symbol containing the name of the
4937          main program, that means that the compiler that was used to build
4938          was not recent enough. In that case, we fallback to the previous
4939          mechanism, which is a little bit less reliable, but has proved to work
4940          in most cases. The only cases where it will fail is when the user
4941          has set some breakpoints which will be hit before the end of the
4942          begin command processing (eg in the initialization code).
4943
4944          The begining of the main Ada subprogram is located by breaking
4945          on the adainit procedure. Since we know that the binder generates
4946          the call to this procedure exactly 2 calls before the call to the
4947          Ada main subprogram, it is then easy to put a breakpoint on this
4948          Ada main subprogram once we hit adainit.
4949        */
4950       do_command ("tbreak adainit", 0);
4951       do_command ("run ", args, 0);
4952       do_command ("up", 0);
4953       do_command ("tbreak +2", 0);
4954       do_command ("continue", 0);
4955       do_command ("step", 0);
4956     }
4957
4958   do_cleanups (old_chain);
4959 }
4960
4961 int
4962 is_ada_runtime_file (char *filename)
4963 {
4964   return (DEPRECATED_STREQN (filename, "s-", 2) ||
4965           DEPRECATED_STREQN (filename, "a-", 2) ||
4966           DEPRECATED_STREQN (filename, "g-", 2) || DEPRECATED_STREQN (filename, "i-", 2));
4967 }
4968
4969 /* find the first frame that contains debugging information and that is not
4970    part of the Ada run-time, starting from fi and moving upward. */
4971
4972 int
4973 find_printable_frame (struct frame_info *fi, int level)
4974 {
4975   struct symtab_and_line sal;
4976
4977   for (; fi != NULL; level += 1, fi = get_prev_frame (fi))
4978     {
4979       find_frame_sal (fi, &sal);
4980       if (sal.symtab && !is_ada_runtime_file (sal.symtab->filename))
4981         {
4982 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
4983           /* libpthread.so contains some debugging information that prevents us
4984              from finding the right frame */
4985
4986           if (sal.symtab->objfile &&
4987               DEPRECATED_STREQ (sal.symtab->objfile->name, "/usr/shlib/libpthread.so"))
4988             continue;
4989 #endif
4990           deprecated_selected_frame = fi;
4991           break;
4992         }
4993     }
4994
4995   return level;
4996 }
4997
4998 void
4999 ada_report_exception_break (struct breakpoint *b)
5000 {
5001   /* FIXME: break_on_exception should be defined in breakpoint.h */
5002   /*  if (b->break_on_exception == 1)
5003      {
5004      /* Assume that cond has 16 elements, the 15th
5005    being the exception *//*
5006    if (b->cond && b->cond->nelts == 16)
5007    {
5008    ui_out_text (uiout, "on ");
5009    ui_out_field_string (uiout, "exception",
5010    SYMBOL_NAME (b->cond->elts[14].symbol));
5011    }
5012    else
5013    ui_out_text (uiout, "on all exceptions");
5014    }
5015    else if (b->break_on_exception == 2)
5016    ui_out_text (uiout, "on unhandled exception");
5017    else if (b->break_on_exception == 3)
5018    ui_out_text (uiout, "on assert failure");
5019    #else
5020    if (b->break_on_exception == 1)
5021    { */
5022   /* Assume that cond has 16 elements, the 15th
5023    being the exception *//*
5024    if (b->cond && b->cond->nelts == 16)
5025    {
5026    fputs_filtered ("on ", gdb_stdout);
5027    fputs_filtered (SYMBOL_NAME
5028    (b->cond->elts[14].symbol), gdb_stdout);
5029    }
5030    else
5031    fputs_filtered ("on all exceptions", gdb_stdout);
5032    }
5033    else if (b->break_on_exception == 2)
5034    fputs_filtered ("on unhandled exception", gdb_stdout);
5035    else if (b->break_on_exception == 3)
5036    fputs_filtered ("on assert failure", gdb_stdout);
5037  */
5038 }
5039
5040 int
5041 ada_is_exception_sym (struct symbol *sym)
5042 {
5043   char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
5044
5045   return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
5046           && SYMBOL_CLASS (sym) != LOC_BLOCK
5047           && SYMBOL_CLASS (sym) != LOC_CONST
5048           && type_name != NULL && DEPRECATED_STREQ (type_name, "exception"));
5049 }
5050
5051 int
5052 ada_maybe_exception_partial_symbol (struct partial_symbol *sym)
5053 {
5054   return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
5055           && SYMBOL_CLASS (sym) != LOC_BLOCK
5056           && SYMBOL_CLASS (sym) != LOC_CONST);
5057 }
5058
5059 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5060    into equivalent form.  Return resulting argument string. Set
5061    *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5062    break on unhandled, 3 for assert, 0 otherwise. */
5063 char *
5064 ada_breakpoint_rewrite (char *arg, int *break_on_exceptionp)
5065 {
5066   if (arg == NULL)
5067     return arg;
5068   *break_on_exceptionp = 0;
5069   /* FIXME: language_ada should be defined in defs.h */
5070   /*  if (current_language->la_language == language_ada
5071      && DEPRECATED_STREQN (arg, "exception", 9) &&
5072      (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5073      {
5074      char *tok, *end_tok;
5075      int toklen;
5076
5077      *break_on_exceptionp = 1;
5078
5079      tok = arg+9;
5080      while (*tok == ' ' || *tok == '\t')
5081      tok += 1;
5082
5083      end_tok = tok;
5084
5085      while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5086      end_tok += 1;
5087
5088      toklen = end_tok - tok;
5089
5090      arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5091      "long_integer(e) = long_integer(&)")
5092      + toklen + 1);
5093      make_cleanup (xfree, arg);
5094      if (toklen == 0)
5095      strcpy (arg, "__gnat_raise_nodefer_with_msg");
5096      else if (DEPRECATED_STREQN (tok, "unhandled", toklen))
5097      {
5098      *break_on_exceptionp = 2;
5099      strcpy (arg, "__gnat_unhandled_exception");
5100      }
5101      else
5102      {
5103      sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5104      "long_integer(e) = long_integer(&%.*s)",
5105      toklen, tok);
5106      }
5107      }
5108      else if (current_language->la_language == language_ada
5109      && DEPRECATED_STREQN (arg, "assert", 6) &&
5110      (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5111      {
5112      char *tok = arg + 6;
5113
5114      *break_on_exceptionp = 3;
5115
5116      arg = (char*)
5117      xmalloc (sizeof ("system__assertions__raise_assert_failure")
5118      + strlen (tok) + 1);
5119      make_cleanup (xfree, arg);
5120      sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5121      }
5122    */
5123   return arg;
5124 }
5125 \f
5126
5127                                 /* Field Access */
5128
5129 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5130    to be invisible to users. */
5131
5132 int
5133 ada_is_ignored_field (struct type *type, int field_num)
5134 {
5135   if (field_num < 0 || field_num > TYPE_NFIELDS (type))
5136     return 1;
5137   else
5138     {
5139       const char *name = TYPE_FIELD_NAME (type, field_num);
5140       return (name == NULL
5141               || (name[0] == '_' && !DEPRECATED_STREQN (name, "_parent", 7)));
5142     }
5143 }
5144
5145 /* True iff structure type TYPE has a tag field. */
5146
5147 int
5148 ada_is_tagged_type (struct type *type)
5149 {
5150   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5151     return 0;
5152
5153   return (ada_lookup_struct_elt_type (type, "_tag", 1, NULL) != NULL);
5154 }
5155
5156 /* The type of the tag on VAL. */
5157
5158 struct type *
5159 ada_tag_type (struct value *val)
5160 {
5161   return ada_lookup_struct_elt_type (VALUE_TYPE (val), "_tag", 0, NULL);
5162 }
5163
5164 /* The value of the tag on VAL. */
5165
5166 struct value *
5167 ada_value_tag (struct value *val)
5168 {
5169   return ada_value_struct_elt (val, "_tag", "record");
5170 }
5171
5172 /* The parent type of TYPE, or NULL if none. */
5173
5174 struct type *
5175 ada_parent_type (struct type *type)
5176 {
5177   int i;
5178
5179   CHECK_TYPEDEF (type);
5180
5181   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5182     return NULL;
5183
5184   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5185     if (ada_is_parent_field (type, i))
5186       return check_typedef (TYPE_FIELD_TYPE (type, i));
5187
5188   return NULL;
5189 }
5190
5191 /* True iff field number FIELD_NUM of structure type TYPE contains the
5192    parent-type (inherited) fields of a derived type.  Assumes TYPE is
5193    a structure type with at least FIELD_NUM+1 fields. */
5194
5195 int
5196 ada_is_parent_field (struct type *type, int field_num)
5197 {
5198   const char *name = TYPE_FIELD_NAME (check_typedef (type), field_num);
5199   return (name != NULL &&
5200           (DEPRECATED_STREQN (name, "PARENT", 6) || DEPRECATED_STREQN (name, "_parent", 7)));
5201 }
5202
5203 /* True iff field number FIELD_NUM of structure type TYPE is a
5204    transparent wrapper field (which should be silently traversed when doing
5205    field selection and flattened when printing).  Assumes TYPE is a
5206    structure type with at least FIELD_NUM+1 fields.  Such fields are always
5207    structures. */
5208
5209 int
5210 ada_is_wrapper_field (struct type *type, int field_num)
5211 {
5212   const char *name = TYPE_FIELD_NAME (type, field_num);
5213   return (name != NULL
5214           && (DEPRECATED_STREQN (name, "PARENT", 6) || DEPRECATED_STREQ (name, "REP")
5215               || DEPRECATED_STREQN (name, "_parent", 7)
5216               || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
5217 }
5218
5219 /* True iff field number FIELD_NUM of structure or union type TYPE
5220    is a variant wrapper.  Assumes TYPE is a structure type with at least
5221    FIELD_NUM+1 fields. */
5222
5223 int
5224 ada_is_variant_part (struct type *type, int field_num)
5225 {
5226   struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5227   return (TYPE_CODE (field_type) == TYPE_CODE_UNION
5228           || (is_dynamic_field (type, field_num)
5229               && TYPE_CODE (TYPE_TARGET_TYPE (field_type)) ==
5230               TYPE_CODE_UNION));
5231 }
5232
5233 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5234    whose discriminants are contained in the record type OUTER_TYPE,
5235    returns the type of the controlling discriminant for the variant.  */
5236
5237 struct type *
5238 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
5239 {
5240   char *name = ada_variant_discrim_name (var_type);
5241   struct type *type = ada_lookup_struct_elt_type (outer_type, name, 1, NULL);
5242   if (type == NULL)
5243     return builtin_type_int;
5244   else
5245     return type;
5246 }
5247
5248 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5249    valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5250    represents a 'when others' clause; otherwise 0. */
5251
5252 int
5253 ada_is_others_clause (struct type *type, int field_num)
5254 {
5255   const char *name = TYPE_FIELD_NAME (type, field_num);
5256   return (name != NULL && name[0] == 'O');
5257 }
5258
5259 /* Assuming that TYPE0 is the type of the variant part of a record,
5260    returns the name of the discriminant controlling the variant.  The
5261    value is valid until the next call to ada_variant_discrim_name. */
5262
5263 char *
5264 ada_variant_discrim_name (struct type *type0)
5265 {
5266   static char *result = NULL;
5267   static size_t result_len = 0;
5268   struct type *type;
5269   const char *name;
5270   const char *discrim_end;
5271   const char *discrim_start;
5272
5273   if (TYPE_CODE (type0) == TYPE_CODE_PTR)
5274     type = TYPE_TARGET_TYPE (type0);
5275   else
5276     type = type0;
5277
5278   name = ada_type_name (type);
5279
5280   if (name == NULL || name[0] == '\000')
5281     return "";
5282
5283   for (discrim_end = name + strlen (name) - 6; discrim_end != name;
5284        discrim_end -= 1)
5285     {
5286       if (DEPRECATED_STREQN (discrim_end, "___XVN", 6))
5287         break;
5288     }
5289   if (discrim_end == name)
5290     return "";
5291
5292   for (discrim_start = discrim_end; discrim_start != name + 3;
5293        discrim_start -= 1)
5294     {
5295       if (discrim_start == name + 1)
5296         return "";
5297       if ((discrim_start > name + 3 && DEPRECATED_STREQN (discrim_start - 3, "___", 3))
5298           || discrim_start[-1] == '.')
5299         break;
5300     }
5301
5302   GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
5303   strncpy (result, discrim_start, discrim_end - discrim_start);
5304   result[discrim_end - discrim_start] = '\0';
5305   return result;
5306 }
5307
5308 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5309    position of the character just past the number scanned in *NEW_K,
5310    if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.  Return 1
5311    if there was a valid number at the given position, and 0 otherwise.  A
5312    "subtype-encoded" number consists of the absolute value in decimal,
5313    followed by the letter 'm' to indicate a negative number.  Assumes 0m
5314    does not occur. */
5315
5316 int
5317 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
5318 {
5319   ULONGEST RU;
5320
5321   if (!isdigit (str[k]))
5322     return 0;
5323
5324   /* Do it the hard way so as not to make any assumption about
5325      the relationship of unsigned long (%lu scan format code) and
5326      LONGEST. */
5327   RU = 0;
5328   while (isdigit (str[k]))
5329     {
5330       RU = RU * 10 + (str[k] - '0');
5331       k += 1;
5332     }
5333
5334   if (str[k] == 'm')
5335     {
5336       if (R != NULL)
5337         *R = (-(LONGEST) (RU - 1)) - 1;
5338       k += 1;
5339     }
5340   else if (R != NULL)
5341     *R = (LONGEST) RU;
5342
5343   /* NOTE on the above: Technically, C does not say what the results of
5344      - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5345      number representable as a LONGEST (although either would probably work
5346      in most implementations).  When RU>0, the locution in the then branch
5347      above is always equivalent to the negative of RU. */
5348
5349   if (new_k != NULL)
5350     *new_k = k;
5351   return 1;
5352 }
5353
5354 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5355    and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5356    in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5357
5358 int
5359 ada_in_variant (LONGEST val, struct type *type, int field_num)
5360 {
5361   const char *name = TYPE_FIELD_NAME (type, field_num);
5362   int p;
5363
5364   p = 0;
5365   while (1)
5366     {
5367       switch (name[p])
5368         {
5369         case '\0':
5370           return 0;
5371         case 'S':
5372           {
5373             LONGEST W;
5374             if (!ada_scan_number (name, p + 1, &W, &p))
5375               return 0;
5376             if (val == W)
5377               return 1;
5378             break;
5379           }
5380         case 'R':
5381           {
5382             LONGEST L, U;
5383             if (!ada_scan_number (name, p + 1, &L, &p)
5384                 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
5385               return 0;
5386             if (val >= L && val <= U)
5387               return 1;
5388             break;
5389           }
5390         case 'O':
5391           return 1;
5392         default:
5393           return 0;
5394         }
5395     }
5396 }
5397
5398 /* Given a value ARG1 (offset by OFFSET bytes)
5399    of a struct or union type ARG_TYPE,
5400    extract and return the value of one of its (non-static) fields.
5401    FIELDNO says which field.   Differs from value_primitive_field only
5402    in that it can handle packed values of arbitrary type. */
5403
5404 struct value *
5405 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
5406                            struct type *arg_type)
5407 {
5408   struct value *v;
5409   struct type *type;
5410
5411   CHECK_TYPEDEF (arg_type);
5412   type = TYPE_FIELD_TYPE (arg_type, fieldno);
5413
5414   /* Handle packed fields */
5415
5416   if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
5417     {
5418       int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
5419       int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
5420
5421       return ada_value_primitive_packed_val (arg1, VALUE_CONTENTS (arg1),
5422                                              offset + bit_pos / 8,
5423                                              bit_pos % 8, bit_size, type);
5424     }
5425   else
5426     return value_primitive_field (arg1, offset, fieldno, arg_type);
5427 }
5428
5429
5430 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5431    and search in it assuming it has (class) type TYPE.
5432    If found, return value, else return NULL.
5433
5434    Searches recursively through wrapper fields (e.g., '_parent'). */
5435
5436 struct value *
5437 ada_search_struct_field (char *name, struct value *arg, int offset,
5438                          struct type *type)
5439 {
5440   int i;
5441   CHECK_TYPEDEF (type);
5442
5443   for (i = TYPE_NFIELDS (type) - 1; i >= 0; i -= 1)
5444     {
5445       char *t_field_name = TYPE_FIELD_NAME (type, i);
5446
5447       if (t_field_name == NULL)
5448         continue;
5449
5450       else if (field_name_match (t_field_name, name))
5451         return ada_value_primitive_field (arg, offset, i, type);
5452
5453       else if (ada_is_wrapper_field (type, i))
5454         {
5455           struct value *v = ada_search_struct_field (name, arg,
5456                                                      offset +
5457                                                      TYPE_FIELD_BITPOS (type,
5458                                                                         i) /
5459                                                      8,
5460                                                      TYPE_FIELD_TYPE (type,
5461                                                                       i));
5462           if (v != NULL)
5463             return v;
5464         }
5465
5466       else if (ada_is_variant_part (type, i))
5467         {
5468           int j;
5469           struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, i));
5470           int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
5471
5472           for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
5473             {
5474               struct value *v = ada_search_struct_field (name, arg,
5475                                                          var_offset
5476                                                          +
5477                                                          TYPE_FIELD_BITPOS
5478                                                          (field_type, j) / 8,
5479                                                          TYPE_FIELD_TYPE
5480                                                          (field_type, j));
5481               if (v != NULL)
5482                 return v;
5483             }
5484         }
5485     }
5486   return NULL;
5487 }
5488
5489 /* Given ARG, a value of type (pointer to a)* structure/union,
5490    extract the component named NAME from the ultimate target structure/union
5491    and return it as a value with its appropriate type.
5492
5493    The routine searches for NAME among all members of the structure itself
5494    and (recursively) among all members of any wrapper members
5495    (e.g., '_parent').
5496
5497    ERR is a name (for use in error messages) that identifies the class
5498    of entity that ARG is supposed to be. */
5499
5500 struct value *
5501 ada_value_struct_elt (struct value *arg, char *name, char *err)
5502 {
5503   struct type *t;
5504   struct value *v;
5505
5506   arg = ada_coerce_ref (arg);
5507   t = check_typedef (VALUE_TYPE (arg));
5508
5509   /* Follow pointers until we get to a non-pointer.  */
5510
5511   while (TYPE_CODE (t) == TYPE_CODE_PTR || TYPE_CODE (t) == TYPE_CODE_REF)
5512     {
5513       arg = ada_value_ind (arg);
5514       t = check_typedef (VALUE_TYPE (arg));
5515     }
5516
5517   if (TYPE_CODE (t) != TYPE_CODE_STRUCT && TYPE_CODE (t) != TYPE_CODE_UNION)
5518     error ("Attempt to extract a component of a value that is not a %s.",
5519            err);
5520
5521   v = ada_search_struct_field (name, arg, 0, t);
5522   if (v == NULL)
5523     error ("There is no member named %s.", name);
5524
5525   return v;
5526 }
5527
5528 /* Given a type TYPE, look up the type of the component of type named NAME.
5529    If DISPP is non-null, add its byte displacement from the beginning of a
5530    structure (pointed to by a value) of type TYPE to *DISPP (does not
5531    work for packed fields).
5532
5533    Matches any field whose name has NAME as a prefix, possibly
5534    followed by "___".
5535
5536    TYPE can be either a struct or union, or a pointer or reference to
5537    a struct or union.  If it is a pointer or reference, its target
5538    type is automatically used.
5539
5540    Looks recursively into variant clauses and parent types.
5541
5542    If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5543
5544 struct type *
5545 ada_lookup_struct_elt_type (struct type *type, char *name, int noerr,
5546                             int *dispp)
5547 {
5548   int i;
5549
5550   if (name == NULL)
5551     goto BadName;
5552
5553   while (1)
5554     {
5555       CHECK_TYPEDEF (type);
5556       if (TYPE_CODE (type) != TYPE_CODE_PTR
5557           && TYPE_CODE (type) != TYPE_CODE_REF)
5558         break;
5559       type = TYPE_TARGET_TYPE (type);
5560     }
5561
5562   if (TYPE_CODE (type) != TYPE_CODE_STRUCT &&
5563       TYPE_CODE (type) != TYPE_CODE_UNION)
5564     {
5565       target_terminal_ours ();
5566       gdb_flush (gdb_stdout);
5567       fprintf_unfiltered (gdb_stderr, "Type ");
5568       type_print (type, "", gdb_stderr, -1);
5569       error (" is not a structure or union type");
5570     }
5571
5572   type = to_static_fixed_type (type);
5573
5574   for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5575     {
5576       char *t_field_name = TYPE_FIELD_NAME (type, i);
5577       struct type *t;
5578       int disp;
5579
5580       if (t_field_name == NULL)
5581         continue;
5582
5583       else if (field_name_match (t_field_name, name))
5584         {
5585           if (dispp != NULL)
5586             *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
5587           return check_typedef (TYPE_FIELD_TYPE (type, i));
5588         }
5589
5590       else if (ada_is_wrapper_field (type, i))
5591         {
5592           disp = 0;
5593           t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
5594                                           1, &disp);
5595           if (t != NULL)
5596             {
5597               if (dispp != NULL)
5598                 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
5599               return t;
5600             }
5601         }
5602
5603       else if (ada_is_variant_part (type, i))
5604         {
5605           int j;
5606           struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, i));
5607
5608           for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
5609             {
5610               disp = 0;
5611               t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
5612                                               name, 1, &disp);
5613               if (t != NULL)
5614                 {
5615                   if (dispp != NULL)
5616                     *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
5617                   return t;
5618                 }
5619             }
5620         }
5621
5622     }
5623
5624 BadName:
5625   if (!noerr)
5626     {
5627       target_terminal_ours ();
5628       gdb_flush (gdb_stdout);
5629       fprintf_unfiltered (gdb_stderr, "Type ");
5630       type_print (type, "", gdb_stderr, -1);
5631       fprintf_unfiltered (gdb_stderr, " has no component named ");
5632       error ("%s", name == NULL ? "<null>" : name);
5633     }
5634
5635   return NULL;
5636 }
5637
5638 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5639    within a value of type OUTER_TYPE that is stored in GDB at
5640    OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5641    numbering from 0) is applicable.  Returns -1 if none are. */
5642
5643 int
5644 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
5645                            char *outer_valaddr)
5646 {
5647   int others_clause;
5648   int i;
5649   int disp;
5650   struct type *discrim_type;
5651   char *discrim_name = ada_variant_discrim_name (var_type);
5652   LONGEST discrim_val;
5653
5654   disp = 0;
5655   discrim_type =
5656     ada_lookup_struct_elt_type (outer_type, discrim_name, 1, &disp);
5657   if (discrim_type == NULL)
5658     return -1;
5659   discrim_val = unpack_long (discrim_type, outer_valaddr + disp);
5660
5661   others_clause = -1;
5662   for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
5663     {
5664       if (ada_is_others_clause (var_type, i))
5665         others_clause = i;
5666       else if (ada_in_variant (discrim_val, var_type, i))
5667         return i;
5668     }
5669
5670   return others_clause;
5671 }
5672 \f
5673
5674
5675                                 /* Dynamic-Sized Records */
5676
5677 /* Strategy: The type ostensibly attached to a value with dynamic size
5678    (i.e., a size that is not statically recorded in the debugging
5679    data) does not accurately reflect the size or layout of the value.
5680    Our strategy is to convert these values to values with accurate,
5681    conventional types that are constructed on the fly. */
5682
5683 /* There is a subtle and tricky problem here.  In general, we cannot
5684    determine the size of dynamic records without its data.  However,
5685    the 'struct value' data structure, which GDB uses to represent
5686    quantities in the inferior process (the target), requires the size
5687    of the type at the time of its allocation in order to reserve space
5688    for GDB's internal copy of the data.  That's why the
5689    'to_fixed_xxx_type' routines take (target) addresses as parameters,
5690    rather than struct value*s.
5691
5692    However, GDB's internal history variables ($1, $2, etc.) are
5693    struct value*s containing internal copies of the data that are not, in
5694    general, the same as the data at their corresponding addresses in
5695    the target.  Fortunately, the types we give to these values are all
5696    conventional, fixed-size types (as per the strategy described
5697    above), so that we don't usually have to perform the
5698    'to_fixed_xxx_type' conversions to look at their values.
5699    Unfortunately, there is one exception: if one of the internal
5700    history variables is an array whose elements are unconstrained
5701    records, then we will need to create distinct fixed types for each
5702    element selected.  */
5703
5704 /* The upshot of all of this is that many routines take a (type, host
5705    address, target address) triple as arguments to represent a value.
5706    The host address, if non-null, is supposed to contain an internal
5707    copy of the relevant data; otherwise, the program is to consult the
5708    target at the target address. */
5709
5710 /* Assuming that VAL0 represents a pointer value, the result of
5711    dereferencing it.  Differs from value_ind in its treatment of
5712    dynamic-sized types. */
5713
5714 struct value *
5715 ada_value_ind (struct value *val0)
5716 {
5717   struct value *val = unwrap_value (value_ind (val0));
5718   return ada_to_fixed_value (VALUE_TYPE (val), 0,
5719                              VALUE_ADDRESS (val) + VALUE_OFFSET (val), val);
5720 }
5721
5722 /* The value resulting from dereferencing any "reference to"
5723  * qualifiers on VAL0. */
5724 static struct value *
5725 ada_coerce_ref (struct value *val0)
5726 {
5727   if (TYPE_CODE (VALUE_TYPE (val0)) == TYPE_CODE_REF)
5728     {
5729       struct value *val = val0;
5730       COERCE_REF (val);
5731       val = unwrap_value (val);
5732       return ada_to_fixed_value (VALUE_TYPE (val), 0,
5733                                  VALUE_ADDRESS (val) + VALUE_OFFSET (val),
5734                                  val);
5735     }
5736   else
5737     return val0;
5738 }
5739
5740 /* Return OFF rounded upward if necessary to a multiple of
5741    ALIGNMENT (a power of 2). */
5742
5743 static unsigned int
5744 align_value (unsigned int off, unsigned int alignment)
5745 {
5746   return (off + alignment - 1) & ~(alignment - 1);
5747 }
5748
5749 /* Return the additional bit offset required by field F of template
5750    type TYPE. */
5751
5752 static unsigned int
5753 field_offset (struct type *type, int f)
5754 {
5755   int n = TYPE_FIELD_BITPOS (type, f);
5756   /* Kludge (temporary?) to fix problem with dwarf output. */
5757   if (n < 0)
5758     return (unsigned int) n & 0xffff;
5759   else
5760     return n;
5761 }
5762
5763
5764 /* Return the bit alignment required for field #F of template type TYPE. */
5765
5766 static unsigned int
5767 field_alignment (struct type *type, int f)
5768 {
5769   const char *name = TYPE_FIELD_NAME (type, f);
5770   int len = (name == NULL) ? 0 : strlen (name);
5771   int align_offset;
5772
5773   if (len < 8 || !isdigit (name[len - 1]))
5774     return TARGET_CHAR_BIT;
5775
5776   if (isdigit (name[len - 2]))
5777     align_offset = len - 2;
5778   else
5779     align_offset = len - 1;
5780
5781   if (align_offset < 7 || !DEPRECATED_STREQN ("___XV", name + align_offset - 6, 5))
5782     return TARGET_CHAR_BIT;
5783
5784   return atoi (name + align_offset) * TARGET_CHAR_BIT;
5785 }
5786
5787 /* Find a type named NAME.  Ignores ambiguity.  */
5788 struct type *
5789 ada_find_any_type (const char *name)
5790 {
5791   struct symbol *sym;
5792
5793   sym = standard_lookup (name, VAR_DOMAIN);
5794   if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5795     return SYMBOL_TYPE (sym);
5796
5797   sym = standard_lookup (name, STRUCT_DOMAIN);
5798   if (sym != NULL)
5799     return SYMBOL_TYPE (sym);
5800
5801   return NULL;
5802 }
5803
5804 /* Because of GNAT encoding conventions, several GDB symbols may match a
5805    given type name. If the type denoted by TYPE0 is to be preferred to
5806    that of TYPE1 for purposes of type printing, return non-zero;
5807    otherwise return 0. */
5808 int
5809 ada_prefer_type (struct type *type0, struct type *type1)
5810 {
5811   if (type1 == NULL)
5812     return 1;
5813   else if (type0 == NULL)
5814     return 0;
5815   else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
5816     return 1;
5817   else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
5818     return 0;
5819   else if (ada_is_packed_array_type (type0))
5820     return 1;
5821   else if (ada_is_array_descriptor (type0)
5822            && !ada_is_array_descriptor (type1))
5823     return 1;
5824   else if (ada_renaming_type (type0) != NULL
5825            && ada_renaming_type (type1) == NULL)
5826     return 1;
5827   return 0;
5828 }
5829
5830 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5831    null, its TYPE_TAG_NAME.  Null if TYPE is null. */
5832 char *
5833 ada_type_name (struct type *type)
5834 {
5835   if (type == NULL)
5836     return NULL;
5837   else if (TYPE_NAME (type) != NULL)
5838     return TYPE_NAME (type);
5839   else
5840     return TYPE_TAG_NAME (type);
5841 }
5842
5843 /* Find a parallel type to TYPE whose name is formed by appending
5844    SUFFIX to the name of TYPE. */
5845
5846 struct type *
5847 ada_find_parallel_type (struct type *type, const char *suffix)
5848 {
5849   static char *name;
5850   static size_t name_len = 0;
5851   struct symbol **syms;
5852   struct block **blocks;
5853   int nsyms;
5854   int len;
5855   char *typename = ada_type_name (type);
5856
5857   if (typename == NULL)
5858     return NULL;
5859
5860   len = strlen (typename);
5861
5862   GROW_VECT (name, name_len, len + strlen (suffix) + 1);
5863
5864   strcpy (name, typename);
5865   strcpy (name + len, suffix);
5866
5867   return ada_find_any_type (name);
5868 }
5869
5870
5871 /* If TYPE is a variable-size record type, return the corresponding template
5872    type describing its fields.  Otherwise, return NULL. */
5873
5874 static struct type *
5875 dynamic_template_type (struct type *type)
5876 {
5877   CHECK_TYPEDEF (type);
5878
5879   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
5880       || ada_type_name (type) == NULL)
5881     return NULL;
5882   else
5883     {
5884       int len = strlen (ada_type_name (type));
5885       if (len > 6 && DEPRECATED_STREQ (ada_type_name (type) + len - 6, "___XVE"))
5886         return type;
5887       else
5888         return ada_find_parallel_type (type, "___XVE");
5889     }
5890 }
5891
5892 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5893    non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5894
5895 static int
5896 is_dynamic_field (struct type *templ_type, int field_num)
5897 {
5898   const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5899   return name != NULL
5900     && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
5901     && strstr (name, "___XVL") != NULL;
5902 }
5903
5904 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
5905    contains a variant part. */
5906
5907 static int
5908 contains_variant_part (struct type *type)
5909 {
5910   int f;
5911
5912   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
5913       || TYPE_NFIELDS (type) <= 0)
5914     return 0;
5915   return ada_is_variant_part (type, TYPE_NFIELDS (type) - 1);
5916 }
5917
5918 /* A record type with no fields, . */
5919 static struct type *
5920 empty_record (struct objfile *objfile)
5921 {
5922   struct type *type = alloc_type (objfile);
5923   TYPE_CODE (type) = TYPE_CODE_STRUCT;
5924   TYPE_NFIELDS (type) = 0;
5925   TYPE_FIELDS (type) = NULL;
5926   TYPE_NAME (type) = "<empty>";
5927   TYPE_TAG_NAME (type) = NULL;
5928   TYPE_FLAGS (type) = 0;
5929   TYPE_LENGTH (type) = 0;
5930   return type;
5931 }
5932
5933 /* An ordinary record type (with fixed-length fields) that describes
5934    the value of type TYPE at VALADDR or ADDRESS (see comments at
5935    the beginning of this section) VAL according to GNAT conventions.
5936    DVAL0 should describe the (portion of a) record that contains any
5937    necessary discriminants.  It should be NULL if VALUE_TYPE (VAL) is
5938    an outer-level type (i.e., as opposed to a branch of a variant.)  A
5939    variant field (unless unchecked) is replaced by a particular branch
5940    of the variant. */
5941 /* NOTE: Limitations: For now, we assume that dynamic fields and
5942  * variants occupy whole numbers of bytes.  However, they need not be
5943  * byte-aligned.  */
5944
5945 static struct type *
5946 template_to_fixed_record_type (struct type *type, char *valaddr,
5947                                CORE_ADDR address, struct value *dval0)
5948 {
5949   struct value *mark = value_mark ();
5950   struct value *dval;
5951   struct type *rtype;
5952   int nfields, bit_len;
5953   long off;
5954   int f;
5955
5956   nfields = TYPE_NFIELDS (type);
5957   rtype = alloc_type (TYPE_OBJFILE (type));
5958   TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
5959   INIT_CPLUS_SPECIFIC (rtype);
5960   TYPE_NFIELDS (rtype) = nfields;
5961   TYPE_FIELDS (rtype) = (struct field *)
5962     TYPE_ALLOC (rtype, nfields * sizeof (struct field));
5963   memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
5964   TYPE_NAME (rtype) = ada_type_name (type);
5965   TYPE_TAG_NAME (rtype) = NULL;
5966   /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
5967      gdbtypes.h */
5968   /*  TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
5969
5970   off = 0;
5971   bit_len = 0;
5972   for (f = 0; f < nfields; f += 1)
5973     {
5974       int fld_bit_len, bit_incr;
5975       off =
5976         align_value (off,
5977                      field_alignment (type, f)) + TYPE_FIELD_BITPOS (type, f);
5978       /* NOTE: used to use field_offset above, but that causes
5979        * problems with really negative bit positions.  So, let's
5980        * rediscover why we needed field_offset and fix it properly. */
5981       TYPE_FIELD_BITPOS (rtype, f) = off;
5982       TYPE_FIELD_BITSIZE (rtype, f) = 0;
5983       TYPE_FIELD_STATIC_KIND (rtype, f) = 0;
5984
5985       if (ada_is_variant_part (type, f))
5986         {
5987           struct type *branch_type;
5988
5989           if (dval0 == NULL)
5990             dval = value_from_contents_and_address (rtype, valaddr, address);
5991           else
5992             dval = dval0;
5993
5994           branch_type =
5995             to_fixed_variant_branch_type
5996             (TYPE_FIELD_TYPE (type, f),
5997              cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
5998              cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
5999           if (branch_type == NULL)
6000             TYPE_NFIELDS (rtype) -= 1;
6001           else
6002             {
6003               TYPE_FIELD_TYPE (rtype, f) = branch_type;
6004               TYPE_FIELD_NAME (rtype, f) = "S";
6005             }
6006           bit_incr = 0;
6007           fld_bit_len =
6008             TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6009         }
6010       else if (is_dynamic_field (type, f))
6011         {
6012           if (dval0 == NULL)
6013             dval = value_from_contents_and_address (rtype, valaddr, address);
6014           else
6015             dval = dval0;
6016
6017           TYPE_FIELD_TYPE (rtype, f) =
6018             ada_to_fixed_type
6019             (ada_get_base_type
6020              (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))),
6021              cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6022              cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
6023           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6024           bit_incr = fld_bit_len =
6025             TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6026         }
6027       else
6028         {
6029           TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
6030           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6031           if (TYPE_FIELD_BITSIZE (type, f) > 0)
6032             bit_incr = fld_bit_len =
6033               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
6034           else
6035             bit_incr = fld_bit_len =
6036               TYPE_LENGTH (TYPE_FIELD_TYPE (type, f)) * TARGET_CHAR_BIT;
6037         }
6038       if (off + fld_bit_len > bit_len)
6039         bit_len = off + fld_bit_len;
6040       off += bit_incr;
6041       TYPE_LENGTH (rtype) = bit_len / TARGET_CHAR_BIT;
6042     }
6043   TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype), TYPE_LENGTH (type));
6044
6045   value_free_to_mark (mark);
6046   if (TYPE_LENGTH (rtype) > varsize_limit)
6047     error ("record type with dynamic size is larger than varsize-limit");
6048   return rtype;
6049 }
6050
6051 /* As for template_to_fixed_record_type, but uses no run-time values.
6052    As a result, this type can only be approximate, but that's OK,
6053    since it is used only for type determinations.   Works on both
6054    structs and unions.
6055    Representation note: to save space, we memoize the result of this
6056    function in the TYPE_TARGET_TYPE of the template type. */
6057
6058 static struct type *
6059 template_to_static_fixed_type (struct type *templ_type)
6060 {
6061   struct type *type;
6062   int nfields;
6063   int f;
6064
6065   if (TYPE_TARGET_TYPE (templ_type) != NULL)
6066     return TYPE_TARGET_TYPE (templ_type);
6067
6068   nfields = TYPE_NFIELDS (templ_type);
6069   TYPE_TARGET_TYPE (templ_type) = type =
6070     alloc_type (TYPE_OBJFILE (templ_type));
6071   TYPE_CODE (type) = TYPE_CODE (templ_type);
6072   INIT_CPLUS_SPECIFIC (type);
6073   TYPE_NFIELDS (type) = nfields;
6074   TYPE_FIELDS (type) = (struct field *)
6075     TYPE_ALLOC (type, nfields * sizeof (struct field));
6076   memset (TYPE_FIELDS (type), 0, sizeof (struct field) * nfields);
6077   TYPE_NAME (type) = ada_type_name (templ_type);
6078   TYPE_TAG_NAME (type) = NULL;
6079   /* FIXME:  TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6080   /*  TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6081   TYPE_LENGTH (type) = 0;
6082
6083   for (f = 0; f < nfields; f += 1)
6084     {
6085       TYPE_FIELD_BITPOS (type, f) = 0;
6086       TYPE_FIELD_BITSIZE (type, f) = 0;
6087       TYPE_FIELD_STATIC_KIND (type, f) = 0;
6088
6089       if (is_dynamic_field (templ_type, f))
6090         {
6091           TYPE_FIELD_TYPE (type, f) =
6092             to_static_fixed_type (TYPE_TARGET_TYPE
6093                                   (TYPE_FIELD_TYPE (templ_type, f)));
6094           TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (templ_type, f);
6095         }
6096       else
6097         {
6098           TYPE_FIELD_TYPE (type, f) =
6099             check_typedef (TYPE_FIELD_TYPE (templ_type, f));
6100           TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (templ_type, f);
6101         }
6102     }
6103
6104   return type;
6105 }
6106
6107 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6108    part -- in which the variant part is replaced with the appropriate
6109    branch. */
6110 static struct type *
6111 to_record_with_fixed_variant_part (struct type *type, char *valaddr,
6112                                    CORE_ADDR address, struct value *dval)
6113 {
6114   struct value *mark = value_mark ();
6115   struct type *rtype;
6116   struct type *branch_type;
6117   int nfields = TYPE_NFIELDS (type);
6118
6119   if (dval == NULL)
6120     return type;
6121
6122   rtype = alloc_type (TYPE_OBJFILE (type));
6123   TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6124   INIT_CPLUS_SPECIFIC (type);
6125   TYPE_NFIELDS (rtype) = TYPE_NFIELDS (type);
6126   TYPE_FIELDS (rtype) =
6127     (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6128   memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
6129           sizeof (struct field) * nfields);
6130   TYPE_NAME (rtype) = ada_type_name (type);
6131   TYPE_TAG_NAME (rtype) = NULL;
6132   /* FIXME:  TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6133   /*  TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6134   TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
6135
6136   branch_type =
6137     to_fixed_variant_branch_type
6138     (TYPE_FIELD_TYPE (type, nfields - 1),
6139      cond_offset_host (valaddr,
6140                        TYPE_FIELD_BITPOS (type,
6141                                           nfields - 1) / TARGET_CHAR_BIT),
6142      cond_offset_target (address,
6143                          TYPE_FIELD_BITPOS (type,
6144                                             nfields - 1) / TARGET_CHAR_BIT),
6145      dval);
6146   if (branch_type == NULL)
6147     {
6148       TYPE_NFIELDS (rtype) -= 1;
6149       TYPE_LENGTH (rtype) -=
6150         TYPE_LENGTH (TYPE_FIELD_TYPE (type, nfields - 1));
6151     }
6152   else
6153     {
6154       TYPE_FIELD_TYPE (rtype, nfields - 1) = branch_type;
6155       TYPE_FIELD_NAME (rtype, nfields - 1) = "S";
6156       TYPE_FIELD_BITSIZE (rtype, nfields - 1) = 0;
6157       TYPE_FIELD_STATIC_KIND (rtype, nfields - 1) = 0;
6158       TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
6159       -TYPE_LENGTH (TYPE_FIELD_TYPE (type, nfields - 1));
6160     }
6161
6162   return rtype;
6163 }
6164
6165 /* An ordinary record type (with fixed-length fields) that describes
6166    the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6167    beginning of this section].   Any necessary discriminants' values
6168    should be in DVAL, a record value; it should be NULL if the object
6169    at ADDR itself contains any necessary  discriminant values.  A
6170    variant field (unless unchecked) is replaced by a particular branch
6171    of the variant. */
6172
6173 static struct type *
6174 to_fixed_record_type (struct type *type0, char *valaddr, CORE_ADDR address,
6175                       struct value *dval)
6176 {
6177   struct type *templ_type;
6178
6179   /* FIXME:  TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6180   /*  if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6181      return type0;
6182    */
6183   templ_type = dynamic_template_type (type0);
6184
6185   if (templ_type != NULL)
6186     return template_to_fixed_record_type (templ_type, valaddr, address, dval);
6187   else if (contains_variant_part (type0))
6188     return to_record_with_fixed_variant_part (type0, valaddr, address, dval);
6189   else
6190     {
6191       /* FIXME:  TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6192       /*      TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6193       return type0;
6194     }
6195
6196 }
6197
6198 /* An ordinary record type (with fixed-length fields) that describes
6199    the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6200    union type.  Any necessary discriminants' values should be in DVAL,
6201    a record value.  That is, this routine selects the appropriate
6202    branch of the union at ADDR according to the discriminant value
6203    indicated in the union's type name. */
6204
6205 static struct type *
6206 to_fixed_variant_branch_type (struct type *var_type0, char *valaddr,
6207                               CORE_ADDR address, struct value *dval)
6208 {
6209   int which;
6210   struct type *templ_type;
6211   struct type *var_type;
6212
6213   if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
6214     var_type = TYPE_TARGET_TYPE (var_type0);
6215   else
6216     var_type = var_type0;
6217
6218   templ_type = ada_find_parallel_type (var_type, "___XVU");
6219
6220   if (templ_type != NULL)
6221     var_type = templ_type;
6222
6223   which =
6224     ada_which_variant_applies (var_type,
6225                                VALUE_TYPE (dval), VALUE_CONTENTS (dval));
6226
6227   if (which < 0)
6228     return empty_record (TYPE_OBJFILE (var_type));
6229   else if (is_dynamic_field (var_type, which))
6230     return
6231       to_fixed_record_type
6232       (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
6233        valaddr, address, dval);
6234   else if (contains_variant_part (TYPE_FIELD_TYPE (var_type, which)))
6235     return
6236       to_fixed_record_type
6237       (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
6238   else
6239     return TYPE_FIELD_TYPE (var_type, which);
6240 }
6241
6242 /* Assuming that TYPE0 is an array type describing the type of a value
6243    at ADDR, and that DVAL describes a record containing any
6244    discriminants used in TYPE0, returns a type for the value that
6245    contains no dynamic components (that is, no components whose sizes
6246    are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
6247    true, gives an error message if the resulting type's size is over
6248    varsize_limit.
6249 */
6250
6251 static struct type *
6252 to_fixed_array_type (struct type *type0, struct value *dval,
6253                      int ignore_too_big)
6254 {
6255   struct type *index_type_desc;
6256   struct type *result;
6257
6258   /* FIXME:  TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6259 /*  if (ada_is_packed_array_type (type0)  /* revisit? *//*
6260    || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6261    return type0; */
6262
6263   index_type_desc = ada_find_parallel_type (type0, "___XA");
6264   if (index_type_desc == NULL)
6265     {
6266       struct type *elt_type0 = check_typedef (TYPE_TARGET_TYPE (type0));
6267       /* NOTE: elt_type---the fixed version of elt_type0---should never
6268        * depend on the contents of the array in properly constructed
6269        * debugging data. */
6270       struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval);
6271
6272       if (elt_type0 == elt_type)
6273         result = type0;
6274       else
6275         result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
6276                                     elt_type, TYPE_INDEX_TYPE (type0));
6277     }
6278   else
6279     {
6280       int i;
6281       struct type *elt_type0;
6282
6283       elt_type0 = type0;
6284       for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
6285         elt_type0 = TYPE_TARGET_TYPE (elt_type0);
6286
6287       /* NOTE: result---the fixed version of elt_type0---should never
6288        * depend on the contents of the array in properly constructed
6289        * debugging data. */
6290       result = ada_to_fixed_type (check_typedef (elt_type0), 0, 0, dval);
6291       for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
6292         {
6293           struct type *range_type =
6294             to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, i),
6295                                  dval, TYPE_OBJFILE (type0));
6296           result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
6297                                       result, range_type);
6298         }
6299       if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
6300         error ("array type with dynamic size is larger than varsize-limit");
6301     }
6302
6303 /* FIXME:  TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6304 /*  TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6305   return result;
6306 }
6307
6308
6309 /* A standard type (containing no dynamically sized components)
6310    corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6311    DVAL describes a record containing any discriminants used in TYPE0,
6312    and may be NULL if there are none. */
6313
6314 struct type *
6315 ada_to_fixed_type (struct type *type, char *valaddr, CORE_ADDR address,
6316                    struct value *dval)
6317 {
6318   CHECK_TYPEDEF (type);
6319   switch (TYPE_CODE (type))
6320     {
6321     default:
6322       return type;
6323     case TYPE_CODE_STRUCT:
6324       return to_fixed_record_type (type, valaddr, address, NULL);
6325     case TYPE_CODE_ARRAY:
6326       return to_fixed_array_type (type, dval, 0);
6327     case TYPE_CODE_UNION:
6328       if (dval == NULL)
6329         return type;
6330       else
6331         return to_fixed_variant_branch_type (type, valaddr, address, dval);
6332     }
6333 }
6334
6335 /* A standard (static-sized) type corresponding as well as possible to
6336    TYPE0, but based on no runtime data. */
6337
6338 static struct type *
6339 to_static_fixed_type (struct type *type0)
6340 {
6341   struct type *type;
6342
6343   if (type0 == NULL)
6344     return NULL;
6345
6346   /* FIXME:  TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6347   /*  if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6348      return type0;
6349    */
6350   CHECK_TYPEDEF (type0);
6351
6352   switch (TYPE_CODE (type0))
6353     {
6354     default:
6355       return type0;
6356     case TYPE_CODE_STRUCT:
6357       type = dynamic_template_type (type0);
6358       if (type != NULL)
6359         return template_to_static_fixed_type (type);
6360       return type0;
6361     case TYPE_CODE_UNION:
6362       type = ada_find_parallel_type (type0, "___XVU");
6363       if (type != NULL)
6364         return template_to_static_fixed_type (type);
6365       return type0;
6366     }
6367 }
6368
6369 /* A static approximation of TYPE with all type wrappers removed. */
6370 static struct type *
6371 static_unwrap_type (struct type *type)
6372 {
6373   if (ada_is_aligner_type (type))
6374     {
6375       struct type *type1 = TYPE_FIELD_TYPE (check_typedef (type), 0);
6376       if (ada_type_name (type1) == NULL)
6377         TYPE_NAME (type1) = ada_type_name (type);
6378
6379       return static_unwrap_type (type1);
6380     }
6381   else
6382     {
6383       struct type *raw_real_type = ada_get_base_type (type);
6384       if (raw_real_type == type)
6385         return type;
6386       else
6387         return to_static_fixed_type (raw_real_type);
6388     }
6389 }
6390
6391 /* In some cases, incomplete and private types require
6392    cross-references that are not resolved as records (for example,
6393       type Foo;
6394       type FooP is access Foo;
6395       V: FooP;
6396       type Foo is array ...;
6397    ). In these cases, since there is no mechanism for producing
6398    cross-references to such types, we instead substitute for FooP a
6399    stub enumeration type that is nowhere resolved, and whose tag is
6400    the name of the actual type.  Call these types "non-record stubs". */
6401
6402 /* A type equivalent to TYPE that is not a non-record stub, if one
6403    exists, otherwise TYPE. */
6404 struct type *
6405 ada_completed_type (struct type *type)
6406 {
6407   CHECK_TYPEDEF (type);
6408   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
6409       || (TYPE_FLAGS (type) & TYPE_FLAG_STUB) == 0
6410       || TYPE_TAG_NAME (type) == NULL)
6411     return type;
6412   else
6413     {
6414       char *name = TYPE_TAG_NAME (type);
6415       struct type *type1 = ada_find_any_type (name);
6416       return (type1 == NULL) ? type : type1;
6417     }
6418 }
6419
6420 /* A value representing the data at VALADDR/ADDRESS as described by
6421    type TYPE0, but with a standard (static-sized) type that correctly
6422    describes it.  If VAL0 is not NULL and TYPE0 already is a standard
6423    type, then return VAL0 [this feature is simply to avoid redundant
6424    creation of struct values]. */
6425
6426 struct value *
6427 ada_to_fixed_value (struct type *type0, char *valaddr, CORE_ADDR address,
6428                     struct value *val0)
6429 {
6430   struct type *type = ada_to_fixed_type (type0, valaddr, address, NULL);
6431   if (type == type0 && val0 != NULL)
6432     return val0;
6433   else
6434     return value_from_contents_and_address (type, valaddr, address);
6435 }
6436
6437 /* A value representing VAL, but with a standard (static-sized) type
6438    chosen to approximate the real type of VAL as well as possible, but
6439    without consulting any runtime values.  For Ada dynamic-sized
6440    types, therefore, the type of the result is likely to be inaccurate. */
6441
6442 struct value *
6443 ada_to_static_fixed_value (struct value *val)
6444 {
6445   struct type *type =
6446     to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val)));
6447   if (type == VALUE_TYPE (val))
6448     return val;
6449   else
6450     return coerce_unspec_val_to_type (val, 0, type);
6451 }
6452 \f
6453
6454
6455
6456
6457 /* Attributes */
6458
6459 /* Table mapping attribute numbers to names */
6460 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6461
6462 static const char *attribute_names[] = {
6463   "<?>",
6464
6465   "first",
6466   "last",
6467   "length",
6468   "image",
6469   "img",
6470   "max",
6471   "min",
6472   "pos" "tag",
6473   "val",
6474
6475   0
6476 };
6477
6478 const char *
6479 ada_attribute_name (int n)
6480 {
6481   if (n > 0 && n < (int) ATR_END)
6482     return attribute_names[n];
6483   else
6484     return attribute_names[0];
6485 }
6486
6487 /* Evaluate the 'POS attribute applied to ARG. */
6488
6489 static struct value *
6490 value_pos_atr (struct value *arg)
6491 {
6492   struct type *type = VALUE_TYPE (arg);
6493
6494   if (!discrete_type_p (type))
6495     error ("'POS only defined on discrete types");
6496
6497   if (TYPE_CODE (type) == TYPE_CODE_ENUM)
6498     {
6499       int i;
6500       LONGEST v = value_as_long (arg);
6501
6502       for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6503         {
6504           if (v == TYPE_FIELD_BITPOS (type, i))
6505             return value_from_longest (builtin_type_ada_int, i);
6506         }
6507       error ("enumeration value is invalid: can't find 'POS");
6508     }
6509   else
6510     return value_from_longest (builtin_type_ada_int, value_as_long (arg));
6511 }
6512
6513 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6514
6515 static struct value *
6516 value_val_atr (struct type *type, struct value *arg)
6517 {
6518   if (!discrete_type_p (type))
6519     error ("'VAL only defined on discrete types");
6520   if (!integer_type_p (VALUE_TYPE (arg)))
6521     error ("'VAL requires integral argument");
6522
6523   if (TYPE_CODE (type) == TYPE_CODE_ENUM)
6524     {
6525       long pos = value_as_long (arg);
6526       if (pos < 0 || pos >= TYPE_NFIELDS (type))
6527         error ("argument to 'VAL out of range");
6528       return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
6529     }
6530   else
6531     return value_from_longest (type, value_as_long (arg));
6532 }
6533 \f
6534
6535                                 /* Evaluation */
6536
6537 /* True if TYPE appears to be an Ada character type.
6538  * [At the moment, this is true only for Character and Wide_Character;
6539  * It is a heuristic test that could stand improvement]. */
6540
6541 int
6542 ada_is_character_type (struct type *type)
6543 {
6544   const char *name = ada_type_name (type);
6545   return
6546     name != NULL
6547     && (TYPE_CODE (type) == TYPE_CODE_CHAR
6548         || TYPE_CODE (type) == TYPE_CODE_INT
6549         || TYPE_CODE (type) == TYPE_CODE_RANGE)
6550     && (DEPRECATED_STREQ (name, "character") || DEPRECATED_STREQ (name, "wide_character")
6551         || DEPRECATED_STREQ (name, "unsigned char"));
6552 }
6553
6554 /* True if TYPE appears to be an Ada string type. */
6555
6556 int
6557 ada_is_string_type (struct type *type)
6558 {
6559   CHECK_TYPEDEF (type);
6560   if (type != NULL
6561       && TYPE_CODE (type) != TYPE_CODE_PTR
6562       && (ada_is_simple_array (type) || ada_is_array_descriptor (type))
6563       && ada_array_arity (type) == 1)
6564     {
6565       struct type *elttype = ada_array_element_type (type, 1);
6566
6567       return ada_is_character_type (elttype);
6568     }
6569   else
6570     return 0;
6571 }
6572
6573
6574 /* True if TYPE is a struct type introduced by the compiler to force the
6575    alignment of a value.  Such types have a single field with a
6576    distinctive name. */
6577
6578 int
6579 ada_is_aligner_type (struct type *type)
6580 {
6581   CHECK_TYPEDEF (type);
6582   return (TYPE_CODE (type) == TYPE_CODE_STRUCT
6583           && TYPE_NFIELDS (type) == 1
6584           && DEPRECATED_STREQ (TYPE_FIELD_NAME (type, 0), "F"));
6585 }
6586
6587 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6588    the parallel type. */
6589
6590 struct type *
6591 ada_get_base_type (struct type *raw_type)
6592 {
6593   struct type *real_type_namer;
6594   struct type *raw_real_type;
6595   struct type *real_type;
6596
6597   if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
6598     return raw_type;
6599
6600   real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
6601   if (real_type_namer == NULL
6602       || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
6603       || TYPE_NFIELDS (real_type_namer) != 1)
6604     return raw_type;
6605
6606   raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
6607   if (raw_real_type == NULL)
6608     return raw_type;
6609   else
6610     return raw_real_type;
6611 }
6612
6613 /* The type of value designated by TYPE, with all aligners removed. */
6614
6615 struct type *
6616 ada_aligned_type (struct type *type)
6617 {
6618   if (ada_is_aligner_type (type))
6619     return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
6620   else
6621     return ada_get_base_type (type);
6622 }
6623
6624
6625 /* The address of the aligned value in an object at address VALADDR
6626    having type TYPE.  Assumes ada_is_aligner_type (TYPE). */
6627
6628 char *
6629 ada_aligned_value_addr (struct type *type, char *valaddr)
6630 {
6631   if (ada_is_aligner_type (type))
6632     return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
6633                                    valaddr +
6634                                    TYPE_FIELD_BITPOS (type,
6635                                                       0) / TARGET_CHAR_BIT);
6636   else
6637     return valaddr;
6638 }
6639
6640 /* The printed representation of an enumeration literal with encoded
6641    name NAME. The value is good to the next call of ada_enum_name. */
6642 const char *
6643 ada_enum_name (const char *name)
6644 {
6645   char *tmp;
6646
6647   while (1)
6648     {
6649       if ((tmp = strstr (name, "__")) != NULL)
6650         name = tmp + 2;
6651       else if ((tmp = strchr (name, '.')) != NULL)
6652         name = tmp + 1;
6653       else
6654         break;
6655     }
6656
6657   if (name[0] == 'Q')
6658     {
6659       static char result[16];
6660       int v;
6661       if (name[1] == 'U' || name[1] == 'W')
6662         {
6663           if (sscanf (name + 2, "%x", &v) != 1)
6664             return name;
6665         }
6666       else
6667         return name;
6668
6669       if (isascii (v) && isprint (v))
6670         sprintf (result, "'%c'", v);
6671       else if (name[1] == 'U')
6672         sprintf (result, "[\"%02x\"]", v);
6673       else
6674         sprintf (result, "[\"%04x\"]", v);
6675
6676       return result;
6677     }
6678   else
6679     return name;
6680 }
6681
6682 static struct value *
6683 evaluate_subexp (struct type *expect_type, struct expression *exp, int *pos,
6684                  enum noside noside)
6685 {
6686   return (*exp->language_defn->evaluate_exp) (expect_type, exp, pos, noside);
6687 }
6688
6689 /* Evaluate the subexpression of EXP starting at *POS as for
6690    evaluate_type, updating *POS to point just past the evaluated
6691    expression. */
6692
6693 static struct value *
6694 evaluate_subexp_type (struct expression *exp, int *pos)
6695 {
6696   return (*exp->language_defn->evaluate_exp)
6697     (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
6698 }
6699
6700 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6701    value it wraps. */
6702
6703 static struct value *
6704 unwrap_value (struct value *val)
6705 {
6706   struct type *type = check_typedef (VALUE_TYPE (val));
6707   if (ada_is_aligner_type (type))
6708     {
6709       struct value *v = value_struct_elt (&val, NULL, "F",
6710                                           NULL, "internal structure");
6711       struct type *val_type = check_typedef (VALUE_TYPE (v));
6712       if (ada_type_name (val_type) == NULL)
6713         TYPE_NAME (val_type) = ada_type_name (type);
6714
6715       return unwrap_value (v);
6716     }
6717   else
6718     {
6719       struct type *raw_real_type =
6720         ada_completed_type (ada_get_base_type (type));
6721
6722       if (type == raw_real_type)
6723         return val;
6724
6725       return
6726         coerce_unspec_val_to_type
6727         (val, 0, ada_to_fixed_type (raw_real_type, 0,
6728                                     VALUE_ADDRESS (val) + VALUE_OFFSET (val),
6729                                     NULL));
6730     }
6731 }
6732
6733 static struct value *
6734 cast_to_fixed (struct type *type, struct value *arg)
6735 {
6736   LONGEST val;
6737
6738   if (type == VALUE_TYPE (arg))
6739     return arg;
6740   else if (ada_is_fixed_point_type (VALUE_TYPE (arg)))
6741     val = ada_float_to_fixed (type,
6742                               ada_fixed_to_float (VALUE_TYPE (arg),
6743                                                   value_as_long (arg)));
6744   else
6745     {
6746       DOUBLEST argd =
6747         value_as_double (value_cast (builtin_type_double, value_copy (arg)));
6748       val = ada_float_to_fixed (type, argd);
6749     }
6750
6751   return value_from_longest (type, val);
6752 }
6753
6754 static struct value *
6755 cast_from_fixed_to_double (struct value *arg)
6756 {
6757   DOUBLEST val = ada_fixed_to_float (VALUE_TYPE (arg),
6758                                      value_as_long (arg));
6759   return value_from_double (builtin_type_double, val);
6760 }
6761
6762 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6763  * return the converted value. */
6764 static struct value *
6765 coerce_for_assign (struct type *type, struct value *val)
6766 {
6767   struct type *type2 = VALUE_TYPE (val);
6768   if (type == type2)
6769     return val;
6770
6771   CHECK_TYPEDEF (type2);
6772   CHECK_TYPEDEF (type);
6773
6774   if (TYPE_CODE (type2) == TYPE_CODE_PTR
6775       && TYPE_CODE (type) == TYPE_CODE_ARRAY)
6776     {
6777       val = ada_value_ind (val);
6778       type2 = VALUE_TYPE (val);
6779     }
6780
6781   if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
6782       && TYPE_CODE (type) == TYPE_CODE_ARRAY)
6783     {
6784       if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
6785           || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
6786           != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
6787         error ("Incompatible types in assignment");
6788       VALUE_TYPE (val) = type;
6789     }
6790   return val;
6791 }
6792
6793 struct value *
6794 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
6795                      int *pos, enum noside noside)
6796 {
6797   enum exp_opcode op;
6798   enum ada_attribute atr;
6799   int tem, tem2, tem3;
6800   int pc;
6801   struct value *arg1 = NULL, *arg2 = NULL, *arg3;
6802   struct type *type;
6803   int nargs;
6804   struct value **argvec;
6805
6806   pc = *pos;
6807   *pos += 1;
6808   op = exp->elts[pc].opcode;
6809
6810   switch (op)
6811     {
6812     default:
6813       *pos -= 1;
6814       return
6815         unwrap_value (evaluate_subexp_standard
6816                       (expect_type, exp, pos, noside));
6817
6818     case UNOP_CAST:
6819       (*pos) += 2;
6820       type = exp->elts[pc + 1].type;
6821       arg1 = evaluate_subexp (type, exp, pos, noside);
6822       if (noside == EVAL_SKIP)
6823         goto nosideret;
6824       if (type != check_typedef (VALUE_TYPE (arg1)))
6825         {
6826           if (ada_is_fixed_point_type (type))
6827             arg1 = cast_to_fixed (type, arg1);
6828           else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
6829             arg1 = value_cast (type, cast_from_fixed_to_double (arg1));
6830           else if (VALUE_LVAL (arg1) == lval_memory)
6831             {
6832               /* This is in case of the really obscure (and undocumented,
6833                  but apparently expected) case of (Foo) Bar.all, where Bar
6834                  is an integer constant and Foo is a dynamic-sized type.
6835                  If we don't do this, ARG1 will simply be relabeled with
6836                  TYPE. */
6837               if (noside == EVAL_AVOID_SIDE_EFFECTS)
6838                 return value_zero (to_static_fixed_type (type), not_lval);
6839               arg1 =
6840                 ada_to_fixed_value
6841                 (type, 0, VALUE_ADDRESS (arg1) + VALUE_OFFSET (arg1), 0);
6842             }
6843           else
6844             arg1 = value_cast (type, arg1);
6845         }
6846       return arg1;
6847
6848       /* FIXME:  UNOP_QUAL should be defined in expression.h */
6849       /*    case UNOP_QUAL:
6850          (*pos) += 2;
6851          type = exp->elts[pc + 1].type;
6852          return ada_evaluate_subexp (type, exp, pos, noside);
6853        */
6854     case BINOP_ASSIGN:
6855       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
6856       arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
6857       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
6858         return arg1;
6859       if (binop_user_defined_p (op, arg1, arg2))
6860         return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
6861       else
6862         {
6863           if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
6864             arg2 = cast_to_fixed (VALUE_TYPE (arg1), arg2);
6865           else if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
6866             error
6867               ("Fixed-point values must be assigned to fixed-point variables");
6868           else
6869             arg2 = coerce_for_assign (VALUE_TYPE (arg1), arg2);
6870           return ada_value_assign (arg1, arg2);
6871         }
6872
6873     case BINOP_ADD:
6874       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
6875       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
6876       if (noside == EVAL_SKIP)
6877         goto nosideret;
6878       if (binop_user_defined_p (op, arg1, arg2))
6879         return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
6880       else
6881         {
6882           if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
6883                || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
6884               && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
6885             error
6886               ("Operands of fixed-point addition must have the same type");
6887           return value_cast (VALUE_TYPE (arg1), value_add (arg1, arg2));
6888         }
6889
6890     case BINOP_SUB:
6891       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
6892       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
6893       if (noside == EVAL_SKIP)
6894         goto nosideret;
6895       if (binop_user_defined_p (op, arg1, arg2))
6896         return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
6897       else
6898         {
6899           if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
6900                || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
6901               && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
6902             error
6903               ("Operands of fixed-point subtraction must have the same type");
6904           return value_cast (VALUE_TYPE (arg1), value_sub (arg1, arg2));
6905         }
6906
6907     case BINOP_MUL:
6908     case BINOP_DIV:
6909       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
6910       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
6911       if (noside == EVAL_SKIP)
6912         goto nosideret;
6913       if (binop_user_defined_p (op, arg1, arg2))
6914         return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
6915       else
6916         if (noside == EVAL_AVOID_SIDE_EFFECTS
6917             && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
6918         return value_zero (VALUE_TYPE (arg1), not_lval);
6919       else
6920         {
6921           if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
6922             arg1 = cast_from_fixed_to_double (arg1);
6923           if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
6924             arg2 = cast_from_fixed_to_double (arg2);
6925           return value_binop (arg1, arg2, op);
6926         }
6927
6928     case UNOP_NEG:
6929       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
6930       if (noside == EVAL_SKIP)
6931         goto nosideret;
6932       if (unop_user_defined_p (op, arg1))
6933         return value_x_unop (arg1, op, EVAL_NORMAL);
6934       else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
6935         return value_cast (VALUE_TYPE (arg1), value_neg (arg1));
6936       else
6937         return value_neg (arg1);
6938
6939       /* FIXME:  OP_UNRESOLVED_VALUE should be defined in expression.h */
6940       /*    case OP_UNRESOLVED_VALUE:
6941          /* Only encountered when an unresolved symbol occurs in a
6942          context other than a function call, in which case, it is
6943    illegal. *//*
6944    (*pos) += 3;
6945    if (noside == EVAL_SKIP)
6946    goto nosideret;
6947    else
6948    error ("Unexpected unresolved symbol, %s, during evaluation",
6949    ada_demangle (exp->elts[pc + 2].name));
6950  */
6951     case OP_VAR_VALUE:
6952       *pos -= 1;
6953       if (noside == EVAL_SKIP)
6954         {
6955           *pos += 4;
6956           goto nosideret;
6957         }
6958       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
6959         {
6960           *pos += 4;
6961           return value_zero
6962             (to_static_fixed_type
6963              (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
6964              not_lval);
6965         }
6966       else
6967         {
6968           arg1 =
6969             unwrap_value (evaluate_subexp_standard
6970                           (expect_type, exp, pos, noside));
6971           return ada_to_fixed_value (VALUE_TYPE (arg1), 0,
6972                                      VALUE_ADDRESS (arg1) +
6973                                      VALUE_OFFSET (arg1), arg1);
6974         }
6975
6976     case OP_ARRAY:
6977       (*pos) += 3;
6978       tem2 = longest_to_int (exp->elts[pc + 1].longconst);
6979       tem3 = longest_to_int (exp->elts[pc + 2].longconst);
6980       nargs = tem3 - tem2 + 1;
6981       type = expect_type ? check_typedef (expect_type) : NULL_TYPE;
6982
6983       argvec =
6984         (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
6985       for (tem = 0; tem == 0 || tem < nargs; tem += 1)
6986         /* At least one element gets inserted for the type */
6987         {
6988           /* Ensure that array expressions are coerced into pointer objects. */
6989           argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside);
6990         }
6991       if (noside == EVAL_SKIP)
6992         goto nosideret;
6993       return value_array (tem2, tem3, argvec);
6994
6995     case OP_FUNCALL:
6996       (*pos) += 2;
6997
6998       /* Allocate arg vector, including space for the function to be
6999          called in argvec[0] and a terminating NULL */
7000       nargs = longest_to_int (exp->elts[pc + 1].longconst);
7001       argvec =
7002         (struct value * *) alloca (sizeof (struct value *) * (nargs + 2));
7003
7004       /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7005       /* FIXME: name should be defined in expresion.h */
7006       /*      if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7007          error ("Unexpected unresolved symbol, %s, during evaluation",
7008          ada_demangle (exp->elts[pc + 5].name));
7009        */
7010       if (0)
7011         {
7012           error ("unexpected code path, FIXME");
7013         }
7014       else
7015         {
7016           for (tem = 0; tem <= nargs; tem += 1)
7017             argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7018           argvec[tem] = 0;
7019
7020           if (noside == EVAL_SKIP)
7021             goto nosideret;
7022         }
7023
7024       if (TYPE_CODE (VALUE_TYPE (argvec[0])) == TYPE_CODE_REF)
7025         argvec[0] = value_addr (argvec[0]);
7026
7027       if (ada_is_packed_array_type (VALUE_TYPE (argvec[0])))
7028         argvec[0] = ada_coerce_to_simple_array (argvec[0]);
7029
7030       type = check_typedef (VALUE_TYPE (argvec[0]));
7031       if (TYPE_CODE (type) == TYPE_CODE_PTR)
7032         {
7033           switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type))))
7034             {
7035             case TYPE_CODE_FUNC:
7036               type = check_typedef (TYPE_TARGET_TYPE (type));
7037               break;
7038             case TYPE_CODE_ARRAY:
7039               break;
7040             case TYPE_CODE_STRUCT:
7041               if (noside != EVAL_AVOID_SIDE_EFFECTS)
7042                 argvec[0] = ada_value_ind (argvec[0]);
7043               type = check_typedef (TYPE_TARGET_TYPE (type));
7044               break;
7045             default:
7046               error ("cannot subscript or call something of type `%s'",
7047                      ada_type_name (VALUE_TYPE (argvec[0])));
7048               break;
7049             }
7050         }
7051
7052       switch (TYPE_CODE (type))
7053         {
7054         case TYPE_CODE_FUNC:
7055           if (noside == EVAL_AVOID_SIDE_EFFECTS)
7056             return allocate_value (TYPE_TARGET_TYPE (type));
7057           return call_function_by_hand (argvec[0], nargs, argvec + 1);
7058         case TYPE_CODE_STRUCT:
7059           {
7060             int arity = ada_array_arity (type);
7061             type = ada_array_element_type (type, nargs);
7062             if (type == NULL)
7063               error ("cannot subscript or call a record");
7064             if (arity != nargs)
7065               error ("wrong number of subscripts; expecting %d", arity);
7066             if (noside == EVAL_AVOID_SIDE_EFFECTS)
7067               return allocate_value (ada_aligned_type (type));
7068             return
7069               unwrap_value (ada_value_subscript
7070                             (argvec[0], nargs, argvec + 1));
7071           }
7072         case TYPE_CODE_ARRAY:
7073           if (noside == EVAL_AVOID_SIDE_EFFECTS)
7074             {
7075               type = ada_array_element_type (type, nargs);
7076               if (type == NULL)
7077                 error ("element type of array unknown");
7078               else
7079                 return allocate_value (ada_aligned_type (type));
7080             }
7081           return
7082             unwrap_value (ada_value_subscript
7083                           (ada_coerce_to_simple_array (argvec[0]),
7084                            nargs, argvec + 1));
7085         case TYPE_CODE_PTR:     /* Pointer to array */
7086           type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
7087           if (noside == EVAL_AVOID_SIDE_EFFECTS)
7088             {
7089               type = ada_array_element_type (type, nargs);
7090               if (type == NULL)
7091                 error ("element type of array unknown");
7092               else
7093                 return allocate_value (ada_aligned_type (type));
7094             }
7095           return
7096             unwrap_value (ada_value_ptr_subscript (argvec[0], type,
7097                                                    nargs, argvec + 1));
7098
7099         default:
7100           error ("Internal error in evaluate_subexp");
7101         }
7102
7103     case TERNOP_SLICE:
7104       {
7105         struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7106         int lowbound
7107           = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
7108         int upper
7109           = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
7110         if (noside == EVAL_SKIP)
7111           goto nosideret;
7112
7113         /* If this is a reference to an array, then dereference it */
7114         if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_REF
7115             && TYPE_TARGET_TYPE (VALUE_TYPE (array)) != NULL
7116             && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array))) ==
7117             TYPE_CODE_ARRAY
7118             && !ada_is_array_descriptor (check_typedef (VALUE_TYPE (array))))
7119           {
7120             array = ada_coerce_ref (array);
7121           }
7122
7123         if (noside == EVAL_AVOID_SIDE_EFFECTS &&
7124             ada_is_array_descriptor (check_typedef (VALUE_TYPE (array))))
7125           {
7126             /* Try to dereference the array, in case it is an access to array */
7127             struct type *arrType = ada_type_of_array (array, 0);
7128             if (arrType != NULL)
7129               array = value_at_lazy (arrType, 0, NULL);
7130           }
7131         if (ada_is_array_descriptor (VALUE_TYPE (array)))
7132           array = ada_coerce_to_simple_array (array);
7133
7134         /* If at this point we have a pointer to an array, it means that
7135            it is a pointer to a simple (non-ada) array. We just then
7136            dereference it */
7137         if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_PTR
7138             && TYPE_TARGET_TYPE (VALUE_TYPE (array)) != NULL
7139             && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array))) ==
7140             TYPE_CODE_ARRAY)
7141           {
7142             array = ada_value_ind (array);
7143           }
7144
7145         if (noside == EVAL_AVOID_SIDE_EFFECTS)
7146           /* The following will get the bounds wrong, but only in contexts
7147              where the value is not being requested (FIXME?). */
7148           return array;
7149         else
7150           return value_slice (array, lowbound, upper - lowbound + 1);
7151       }
7152
7153       /* FIXME: UNOP_MBR should be defined in expression.h */
7154       /*    case UNOP_MBR:
7155          (*pos) += 2;
7156          arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7157          type = exp->elts[pc + 1].type;
7158
7159          if (noside == EVAL_SKIP)
7160          goto nosideret;
7161
7162          switch (TYPE_CODE (type))
7163          {
7164          default:
7165          warning ("Membership test incompletely implemented; always returns true");
7166          return value_from_longest (builtin_type_int, (LONGEST) 1);
7167
7168          case TYPE_CODE_RANGE:
7169          arg2 = value_from_longest (builtin_type_int,
7170          (LONGEST) TYPE_LOW_BOUND (type));
7171          arg3 = value_from_longest (builtin_type_int,
7172          (LONGEST) TYPE_HIGH_BOUND (type));
7173          return
7174          value_from_longest (builtin_type_int,
7175          (value_less (arg1,arg3)
7176          || value_equal (arg1,arg3))
7177          && (value_less (arg2,arg1)
7178          || value_equal (arg2,arg1)));
7179          }
7180        */
7181       /* FIXME: BINOP_MBR should be defined in expression.h */
7182       /*    case BINOP_MBR:
7183          (*pos) += 2;
7184          arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7185          arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7186
7187          if (noside == EVAL_SKIP)
7188          goto nosideret;
7189
7190          if (noside == EVAL_AVOID_SIDE_EFFECTS)
7191          return value_zero (builtin_type_int, not_lval);
7192
7193          tem = longest_to_int (exp->elts[pc + 1].longconst);
7194
7195          if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7196          error ("invalid dimension number to '%s", "range");
7197
7198          arg3 = ada_array_bound (arg2, tem, 1);
7199          arg2 = ada_array_bound (arg2, tem, 0);
7200
7201          return
7202          value_from_longest (builtin_type_int,
7203          (value_less (arg1,arg3)
7204          || value_equal (arg1,arg3))
7205          && (value_less (arg2,arg1)
7206          || value_equal (arg2,arg1)));
7207        */
7208       /* FIXME: TERNOP_MBR should be defined in expression.h */
7209       /*    case TERNOP_MBR:
7210          arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7211          arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7212          arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7213
7214          if (noside == EVAL_SKIP)
7215          goto nosideret;
7216
7217          return
7218          value_from_longest (builtin_type_int,
7219          (value_less (arg1,arg3)
7220          || value_equal (arg1,arg3))
7221          && (value_less (arg2,arg1)
7222          || value_equal (arg2,arg1)));
7223        */
7224       /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7225       /*    case OP_ATTRIBUTE:
7226          *pos += 3;
7227          atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7228          switch (atr)
7229          {
7230          default:
7231          error ("unexpected attribute encountered");
7232
7233          case ATR_FIRST:
7234          case ATR_LAST:
7235          case ATR_LENGTH:
7236          {
7237          struct type* type_arg;
7238          if (exp->elts[*pos].opcode == OP_TYPE)
7239          {
7240          evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7241          arg1 = NULL;
7242          type_arg = exp->elts[pc + 5].type;
7243          }
7244          else
7245          {
7246          arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7247          type_arg = NULL;
7248          }
7249
7250          if (exp->elts[*pos].opcode != OP_LONG)
7251          error ("illegal operand to '%s", ada_attribute_name (atr));
7252          tem = longest_to_int (exp->elts[*pos+2].longconst);
7253          *pos += 4;
7254
7255          if (noside == EVAL_SKIP)
7256          goto nosideret;
7257
7258          if (type_arg == NULL)
7259          {
7260          arg1 = ada_coerce_ref (arg1);
7261
7262          if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7263          arg1 = ada_coerce_to_simple_array (arg1);
7264
7265          if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7266          error ("invalid dimension number to '%s",
7267          ada_attribute_name (atr));
7268
7269          if (noside == EVAL_AVOID_SIDE_EFFECTS)
7270          {
7271          type = ada_index_type (VALUE_TYPE (arg1), tem);
7272          if (type == NULL)
7273          error ("attempt to take bound of something that is not an array");
7274          return allocate_value (type);
7275          }
7276
7277          switch (atr)
7278          {
7279          default:
7280          error ("unexpected attribute encountered");
7281          case ATR_FIRST:
7282          return ada_array_bound (arg1, tem, 0);
7283          case ATR_LAST:
7284          return ada_array_bound (arg1, tem, 1);
7285          case ATR_LENGTH:
7286          return ada_array_length (arg1, tem);
7287          }
7288          }
7289          else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7290          || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7291          {
7292          struct type* range_type;
7293          char* name = ada_type_name (type_arg);
7294          if (name == NULL)
7295          {
7296          if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7297          range_type = type_arg;
7298          else
7299          error ("unimplemented type attribute");
7300          }
7301          else
7302          range_type =
7303          to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7304          switch (atr)
7305          {
7306          default:
7307          error ("unexpected attribute encountered");
7308          case ATR_FIRST:
7309          return value_from_longest (TYPE_TARGET_TYPE (range_type),
7310          TYPE_LOW_BOUND (range_type));
7311          case ATR_LAST:
7312          return value_from_longest (TYPE_TARGET_TYPE (range_type),
7313          TYPE_HIGH_BOUND (range_type));
7314          }
7315          }
7316          else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7317          {
7318          switch (atr)
7319          {
7320          default:
7321          error ("unexpected attribute encountered");
7322          case ATR_FIRST:
7323          return value_from_longest
7324          (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7325          case ATR_LAST:
7326          return value_from_longest
7327          (type_arg,
7328          TYPE_FIELD_BITPOS (type_arg,
7329          TYPE_NFIELDS (type_arg) - 1));
7330          }
7331          }
7332          else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7333          error ("unimplemented type attribute");
7334          else
7335          {
7336          LONGEST low, high;
7337
7338          if (ada_is_packed_array_type (type_arg))
7339          type_arg = decode_packed_array_type (type_arg);
7340
7341          if (tem < 1 || tem > ada_array_arity (type_arg))
7342          error ("invalid dimension number to '%s",
7343          ada_attribute_name (atr));
7344
7345          if (noside == EVAL_AVOID_SIDE_EFFECTS)
7346          {
7347          type = ada_index_type (type_arg, tem);
7348          if (type == NULL)
7349          error ("attempt to take bound of something that is not an array");
7350          return allocate_value (type);
7351          }
7352
7353          switch (atr)
7354          {
7355          default:
7356          error ("unexpected attribute encountered");
7357          case ATR_FIRST:
7358          low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7359          return value_from_longest (type, low);
7360          case ATR_LAST:
7361          high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7362          return value_from_longest (type, high);
7363          case ATR_LENGTH:
7364          low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7365          high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7366          return value_from_longest (type, high-low+1);
7367          }
7368          }
7369          }
7370
7371          case ATR_TAG:
7372          arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7373          if (noside == EVAL_SKIP)
7374          goto nosideret;
7375
7376          if (noside == EVAL_AVOID_SIDE_EFFECTS)
7377          return
7378          value_zero (ada_tag_type (arg1), not_lval);
7379
7380          return ada_value_tag (arg1);
7381
7382          case ATR_MIN:
7383          case ATR_MAX:
7384          evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7385          arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7386          arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7387          if (noside == EVAL_SKIP)
7388          goto nosideret;
7389          else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7390          return value_zero (VALUE_TYPE (arg1), not_lval);
7391          else
7392          return value_binop (arg1, arg2,
7393          atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7394
7395          case ATR_MODULUS:
7396          {
7397          struct type* type_arg = exp->elts[pc + 5].type;
7398          evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7399          *pos += 4;
7400
7401          if (noside == EVAL_SKIP)
7402          goto nosideret;
7403
7404          if (! ada_is_modular_type (type_arg))
7405          error ("'modulus must be applied to modular type");
7406
7407          return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7408          ada_modulus (type_arg));
7409          }
7410
7411
7412          case ATR_POS:
7413          evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7414          arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7415          if (noside == EVAL_SKIP)
7416          goto nosideret;
7417          else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7418          return value_zero (builtin_type_ada_int, not_lval);
7419          else
7420          return value_pos_atr (arg1);
7421
7422          case ATR_SIZE:
7423          arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7424          if (noside == EVAL_SKIP)
7425          goto nosideret;
7426          else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7427          return value_zero (builtin_type_ada_int, not_lval);
7428          else
7429          return value_from_longest (builtin_type_ada_int,
7430          TARGET_CHAR_BIT
7431          * TYPE_LENGTH (VALUE_TYPE (arg1)));
7432
7433          case ATR_VAL:
7434          evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7435          arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7436          type = exp->elts[pc + 5].type;
7437          if (noside == EVAL_SKIP)
7438          goto nosideret;
7439          else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7440          return value_zero (type, not_lval);
7441          else
7442          return value_val_atr (type, arg1);
7443          } */
7444     case BINOP_EXP:
7445       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7446       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7447       if (noside == EVAL_SKIP)
7448         goto nosideret;
7449       if (binop_user_defined_p (op, arg1, arg2))
7450         return unwrap_value (value_x_binop (arg1, arg2, op, OP_NULL,
7451                                             EVAL_NORMAL));
7452       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7453         return value_zero (VALUE_TYPE (arg1), not_lval);
7454       else
7455         return value_binop (arg1, arg2, op);
7456
7457     case UNOP_PLUS:
7458       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7459       if (noside == EVAL_SKIP)
7460         goto nosideret;
7461       if (unop_user_defined_p (op, arg1))
7462         return unwrap_value (value_x_unop (arg1, op, EVAL_NORMAL));
7463       else
7464         return arg1;
7465
7466     case UNOP_ABS:
7467       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7468       if (noside == EVAL_SKIP)
7469         goto nosideret;
7470       if (value_less (arg1, value_zero (VALUE_TYPE (arg1), not_lval)))
7471         return value_neg (arg1);
7472       else
7473         return arg1;
7474
7475     case UNOP_IND:
7476       if (expect_type && TYPE_CODE (expect_type) == TYPE_CODE_PTR)
7477         expect_type = TYPE_TARGET_TYPE (check_typedef (expect_type));
7478       arg1 = evaluate_subexp (expect_type, exp, pos, noside);
7479       if (noside == EVAL_SKIP)
7480         goto nosideret;
7481       type = check_typedef (VALUE_TYPE (arg1));
7482       if (noside == EVAL_AVOID_SIDE_EFFECTS)
7483         {
7484           if (ada_is_array_descriptor (type))
7485             /* GDB allows dereferencing GNAT array descriptors. */
7486             {
7487               struct type *arrType = ada_type_of_array (arg1, 0);
7488               if (arrType == NULL)
7489                 error ("Attempt to dereference null array pointer.");
7490               return value_at_lazy (arrType, 0, NULL);
7491             }
7492           else if (TYPE_CODE (type) == TYPE_CODE_PTR
7493                    || TYPE_CODE (type) == TYPE_CODE_REF
7494                    /* In C you can dereference an array to get the 1st elt.  */
7495                    || TYPE_CODE (type) == TYPE_CODE_ARRAY)
7496             return
7497               value_zero
7498               (to_static_fixed_type
7499                (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type)))),
7500                lval_memory);
7501           else if (TYPE_CODE (type) == TYPE_CODE_INT)
7502             /* GDB allows dereferencing an int.  */
7503             return value_zero (builtin_type_int, lval_memory);
7504           else
7505             error ("Attempt to take contents of a non-pointer value.");
7506         }
7507       arg1 = ada_coerce_ref (arg1);
7508       type = check_typedef (VALUE_TYPE (arg1));
7509
7510       if (ada_is_array_descriptor (type))
7511         /* GDB allows dereferencing GNAT array descriptors. */
7512         return ada_coerce_to_simple_array (arg1);
7513       else
7514         return ada_value_ind (arg1);
7515
7516     case STRUCTOP_STRUCT:
7517       tem = longest_to_int (exp->elts[pc + 1].longconst);
7518       (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
7519       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7520       if (noside == EVAL_SKIP)
7521         goto nosideret;
7522       if (noside == EVAL_AVOID_SIDE_EFFECTS)
7523         return value_zero (ada_aligned_type
7524                            (ada_lookup_struct_elt_type (VALUE_TYPE (arg1),
7525                                                         &exp->elts[pc +
7526                                                                    2].string,
7527                                                         0, NULL)),
7528                            lval_memory);
7529       else
7530         return unwrap_value (ada_value_struct_elt (arg1,
7531                                                    &exp->elts[pc + 2].string,
7532                                                    "record"));
7533     case OP_TYPE:
7534       /* The value is not supposed to be used. This is here to make it
7535          easier to accommodate expressions that contain types. */
7536       (*pos) += 2;
7537       if (noside == EVAL_SKIP)
7538         goto nosideret;
7539       else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7540         return allocate_value (builtin_type_void);
7541       else
7542         error ("Attempt to use a type name as an expression");
7543
7544     case STRUCTOP_PTR:
7545       tem = longest_to_int (exp->elts[pc + 1].longconst);
7546       (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
7547       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7548       if (noside == EVAL_SKIP)
7549         goto nosideret;
7550       if (noside == EVAL_AVOID_SIDE_EFFECTS)
7551         return value_zero (ada_aligned_type
7552                            (ada_lookup_struct_elt_type (VALUE_TYPE (arg1),
7553                                                         &exp->elts[pc +
7554                                                                    2].string,
7555                                                         0, NULL)),
7556                            lval_memory);
7557       else
7558         return unwrap_value (ada_value_struct_elt (arg1,
7559                                                    &exp->elts[pc + 2].string,
7560                                                    "record access"));
7561     }
7562
7563 nosideret:
7564   return value_from_longest (builtin_type_long, (LONGEST) 1);
7565 }
7566 \f
7567
7568                                 /* Fixed point */
7569
7570 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7571    type name that encodes the 'small and 'delta information.
7572    Otherwise, return NULL. */
7573
7574 static const char *
7575 fixed_type_info (struct type *type)
7576 {
7577   const char *name = ada_type_name (type);
7578   enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
7579
7580   if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
7581     {
7582       const char *tail = strstr (name, "___XF_");
7583       if (tail == NULL)
7584         return NULL;
7585       else
7586         return tail + 5;
7587     }
7588   else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
7589     return fixed_type_info (TYPE_TARGET_TYPE (type));
7590   else
7591     return NULL;
7592 }
7593
7594 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7595
7596 int
7597 ada_is_fixed_point_type (struct type *type)
7598 {
7599   return fixed_type_info (type) != NULL;
7600 }
7601
7602 /* Assuming that TYPE is the representation of an Ada fixed-point
7603    type, return its delta, or -1 if the type is malformed and the
7604    delta cannot be determined. */
7605
7606 DOUBLEST
7607 ada_delta (struct type *type)
7608 {
7609   const char *encoding = fixed_type_info (type);
7610   long num, den;
7611
7612   if (sscanf (encoding, "_%ld_%ld", &num, &den) < 2)
7613     return -1.0;
7614   else
7615     return (DOUBLEST) num / (DOUBLEST) den;
7616 }
7617
7618 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7619    factor ('SMALL value) associated with the type. */
7620
7621 static DOUBLEST
7622 scaling_factor (struct type *type)
7623 {
7624   const char *encoding = fixed_type_info (type);
7625   unsigned long num0, den0, num1, den1;
7626   int n;
7627
7628   n = sscanf (encoding, "_%lu_%lu_%lu_%lu", &num0, &den0, &num1, &den1);
7629
7630   if (n < 2)
7631     return 1.0;
7632   else if (n == 4)
7633     return (DOUBLEST) num1 / (DOUBLEST) den1;
7634   else
7635     return (DOUBLEST) num0 / (DOUBLEST) den0;
7636 }
7637
7638
7639 /* Assuming that X is the representation of a value of fixed-point
7640    type TYPE, return its floating-point equivalent. */
7641
7642 DOUBLEST
7643 ada_fixed_to_float (struct type *type, LONGEST x)
7644 {
7645   return (DOUBLEST) x *scaling_factor (type);
7646 }
7647
7648 /* The representation of a fixed-point value of type TYPE
7649    corresponding to the value X. */
7650
7651 LONGEST
7652 ada_float_to_fixed (struct type *type, DOUBLEST x)
7653 {
7654   return (LONGEST) (x / scaling_factor (type) + 0.5);
7655 }
7656
7657
7658                                 /* VAX floating formats */
7659
7660 /* Non-zero iff TYPE represents one of the special VAX floating-point
7661    types. */
7662 int
7663 ada_is_vax_floating_type (struct type *type)
7664 {
7665   int name_len =
7666     (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
7667   return
7668     name_len > 6
7669     && (TYPE_CODE (type) == TYPE_CODE_INT
7670         || TYPE_CODE (type) == TYPE_CODE_RANGE)
7671     && DEPRECATED_STREQN (ada_type_name (type) + name_len - 6, "___XF", 5);
7672 }
7673
7674 /* The type of special VAX floating-point type this is, assuming
7675    ada_is_vax_floating_point */
7676 int
7677 ada_vax_float_type_suffix (struct type *type)
7678 {
7679   return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
7680 }
7681
7682 /* A value representing the special debugging function that outputs
7683    VAX floating-point values of the type represented by TYPE.  Assumes
7684    ada_is_vax_floating_type (TYPE). */
7685 struct value *
7686 ada_vax_float_print_function (struct type *type)
7687 {
7688   switch (ada_vax_float_type_suffix (type))
7689     {
7690     case 'F':
7691       return get_var_value ("DEBUG_STRING_F", 0);
7692     case 'D':
7693       return get_var_value ("DEBUG_STRING_D", 0);
7694     case 'G':
7695       return get_var_value ("DEBUG_STRING_G", 0);
7696     default:
7697       error ("invalid VAX floating-point type");
7698     }
7699 }
7700 \f
7701
7702                                 /* Range types */
7703
7704 /* Scan STR beginning at position K for a discriminant name, and
7705    return the value of that discriminant field of DVAL in *PX.  If
7706    PNEW_K is not null, put the position of the character beyond the
7707    name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
7708    not alter *PX and *PNEW_K if unsuccessful. */
7709
7710 static int
7711 scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
7712                     int *pnew_k)
7713 {
7714   static char *bound_buffer = NULL;
7715   static size_t bound_buffer_len = 0;
7716   char *bound;
7717   char *pend;
7718   struct value *bound_val;
7719
7720   if (dval == NULL || str == NULL || str[k] == '\0')
7721     return 0;
7722
7723   pend = strstr (str + k, "__");
7724   if (pend == NULL)
7725     {
7726       bound = str + k;
7727       k += strlen (bound);
7728     }
7729   else
7730     {
7731       GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
7732       bound = bound_buffer;
7733       strncpy (bound_buffer, str + k, pend - (str + k));
7734       bound[pend - (str + k)] = '\0';
7735       k = pend - str;
7736     }
7737
7738   bound_val = ada_search_struct_field (bound, dval, 0, VALUE_TYPE (dval));
7739   if (bound_val == NULL)
7740     return 0;
7741
7742   *px = value_as_long (bound_val);
7743   if (pnew_k != NULL)
7744     *pnew_k = k;
7745   return 1;
7746 }
7747
7748 /* Value of variable named NAME in the current environment.  If
7749    no such variable found, then if ERR_MSG is null, returns 0, and
7750    otherwise causes an error with message ERR_MSG. */
7751 static struct value *
7752 get_var_value (char *name, char *err_msg)
7753 {
7754   struct symbol **syms;
7755   struct block **blocks;
7756   int nsyms;
7757
7758   nsyms =
7759     ada_lookup_symbol_list (name, get_selected_block (NULL), VAR_DOMAIN,
7760                             &syms, &blocks);
7761
7762   if (nsyms != 1)
7763     {
7764       if (err_msg == NULL)
7765         return 0;
7766       else
7767         error ("%s", err_msg);
7768     }
7769
7770   return value_of_variable (syms[0], blocks[0]);
7771 }
7772
7773 /* Value of integer variable named NAME in the current environment.  If
7774    no such variable found, then if ERR_MSG is null, returns 0, and sets
7775    *FLAG to 0.  If successful, sets *FLAG to 1. */
7776 LONGEST
7777 get_int_var_value (char *name, char *err_msg, int *flag)
7778 {
7779   struct value *var_val = get_var_value (name, err_msg);
7780
7781   if (var_val == 0)
7782     {
7783       if (flag != NULL)
7784         *flag = 0;
7785       return 0;
7786     }
7787   else
7788     {
7789       if (flag != NULL)
7790         *flag = 1;
7791       return value_as_long (var_val);
7792     }
7793 }
7794
7795
7796 /* Return a range type whose base type is that of the range type named
7797    NAME in the current environment, and whose bounds are calculated
7798    from NAME according to the GNAT range encoding conventions.
7799    Extract discriminant values, if needed, from DVAL.  If a new type
7800    must be created, allocate in OBJFILE's space.  The bounds
7801    information, in general, is encoded in NAME, the base type given in
7802    the named range type. */
7803
7804 static struct type *
7805 to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
7806 {
7807   struct type *raw_type = ada_find_any_type (name);
7808   struct type *base_type;
7809   LONGEST low, high;
7810   char *subtype_info;
7811
7812   if (raw_type == NULL)
7813     base_type = builtin_type_int;
7814   else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
7815     base_type = TYPE_TARGET_TYPE (raw_type);
7816   else
7817     base_type = raw_type;
7818
7819   subtype_info = strstr (name, "___XD");
7820   if (subtype_info == NULL)
7821     return raw_type;
7822   else
7823     {
7824       static char *name_buf = NULL;
7825       static size_t name_len = 0;
7826       int prefix_len = subtype_info - name;
7827       LONGEST L, U;
7828       struct type *type;
7829       char *bounds_str;
7830       int n;
7831
7832       GROW_VECT (name_buf, name_len, prefix_len + 5);
7833       strncpy (name_buf, name, prefix_len);
7834       name_buf[prefix_len] = '\0';
7835
7836       subtype_info += 5;
7837       bounds_str = strchr (subtype_info, '_');
7838       n = 1;
7839
7840       if (*subtype_info == 'L')
7841         {
7842           if (!ada_scan_number (bounds_str, n, &L, &n)
7843               && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
7844             return raw_type;
7845           if (bounds_str[n] == '_')
7846             n += 2;
7847           else if (bounds_str[n] == '.')        /* FIXME? SGI Workshop kludge. */
7848             n += 1;
7849           subtype_info += 1;
7850         }
7851       else
7852         {
7853           strcpy (name_buf + prefix_len, "___L");
7854           L = get_int_var_value (name_buf, "Index bound unknown.", NULL);
7855         }
7856
7857       if (*subtype_info == 'U')
7858         {
7859           if (!ada_scan_number (bounds_str, n, &U, &n)
7860               && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
7861             return raw_type;
7862         }
7863       else
7864         {
7865           strcpy (name_buf + prefix_len, "___U");
7866           U = get_int_var_value (name_buf, "Index bound unknown.", NULL);
7867         }
7868
7869       if (objfile == NULL)
7870         objfile = TYPE_OBJFILE (base_type);
7871       type = create_range_type (alloc_type (objfile), base_type, L, U);
7872       TYPE_NAME (type) = name;
7873       return type;
7874     }
7875 }
7876
7877 /* True iff NAME is the name of a range type. */
7878 int
7879 ada_is_range_type_name (const char *name)
7880 {
7881   return (name != NULL && strstr (name, "___XD"));
7882 }
7883 \f
7884
7885                                 /* Modular types */
7886
7887 /* True iff TYPE is an Ada modular type. */
7888 int
7889 ada_is_modular_type (struct type *type)
7890 {
7891   /* FIXME: base_type should be declared in gdbtypes.h, implemented in
7892      valarith.c */
7893   struct type *subranged_type;  /* = base_type (type); */
7894
7895   return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
7896           && TYPE_CODE (subranged_type) != TYPE_CODE_ENUM
7897           && TYPE_UNSIGNED (subranged_type));
7898 }
7899
7900 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
7901 LONGEST
7902 ada_modulus (struct type * type)
7903 {
7904   return TYPE_HIGH_BOUND (type) + 1;
7905 }
7906 \f
7907
7908
7909                                 /* Operators */
7910
7911 /* Table mapping opcodes into strings for printing operators
7912    and precedences of the operators.  */
7913
7914 static const struct op_print ada_op_print_tab[] = {
7915   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
7916   {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
7917   {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
7918   {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
7919   {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
7920   {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
7921   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
7922   {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
7923   {"<=", BINOP_LEQ, PREC_ORDER, 0},
7924   {">=", BINOP_GEQ, PREC_ORDER, 0},
7925   {">", BINOP_GTR, PREC_ORDER, 0},
7926   {"<", BINOP_LESS, PREC_ORDER, 0},
7927   {">>", BINOP_RSH, PREC_SHIFT, 0},
7928   {"<<", BINOP_LSH, PREC_SHIFT, 0},
7929   {"+", BINOP_ADD, PREC_ADD, 0},
7930   {"-", BINOP_SUB, PREC_ADD, 0},
7931   {"&", BINOP_CONCAT, PREC_ADD, 0},
7932   {"*", BINOP_MUL, PREC_MUL, 0},
7933   {"/", BINOP_DIV, PREC_MUL, 0},
7934   {"rem", BINOP_REM, PREC_MUL, 0},
7935   {"mod", BINOP_MOD, PREC_MUL, 0},
7936   {"**", BINOP_EXP, PREC_REPEAT, 0},
7937   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
7938   {"-", UNOP_NEG, PREC_PREFIX, 0},
7939   {"+", UNOP_PLUS, PREC_PREFIX, 0},
7940   {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
7941   {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
7942   {"abs ", UNOP_ABS, PREC_PREFIX, 0},
7943   {".all", UNOP_IND, PREC_SUFFIX, 1},   /* FIXME: postfix .ALL */
7944   {"'access", UNOP_ADDR, PREC_SUFFIX, 1},       /* FIXME: postfix 'ACCESS */
7945   {NULL, 0, 0, 0}
7946 };
7947 \f
7948                         /* Assorted Types and Interfaces */
7949
7950 struct type *builtin_type_ada_int;
7951 struct type *builtin_type_ada_short;
7952 struct type *builtin_type_ada_long;
7953 struct type *builtin_type_ada_long_long;
7954 struct type *builtin_type_ada_char;
7955 struct type *builtin_type_ada_float;
7956 struct type *builtin_type_ada_double;
7957 struct type *builtin_type_ada_long_double;
7958 struct type *builtin_type_ada_natural;
7959 struct type *builtin_type_ada_positive;
7960 struct type *builtin_type_ada_system_address;
7961
7962 struct type **const (ada_builtin_types[]) =
7963 {
7964
7965   &builtin_type_ada_int,
7966     &builtin_type_ada_long,
7967     &builtin_type_ada_short,
7968     &builtin_type_ada_char,
7969     &builtin_type_ada_float,
7970     &builtin_type_ada_double,
7971     &builtin_type_ada_long_long,
7972     &builtin_type_ada_long_double,
7973     &builtin_type_ada_natural, &builtin_type_ada_positive,
7974     /* The following types are carried over from C for convenience. */
7975 &builtin_type_int,
7976     &builtin_type_long,
7977     &builtin_type_short,
7978     &builtin_type_char,
7979     &builtin_type_float,
7980     &builtin_type_double,
7981     &builtin_type_long_long,
7982     &builtin_type_void,
7983     &builtin_type_signed_char,
7984     &builtin_type_unsigned_char,
7985     &builtin_type_unsigned_short,
7986     &builtin_type_unsigned_int,
7987     &builtin_type_unsigned_long,
7988     &builtin_type_unsigned_long_long,
7989     &builtin_type_long_double,
7990     &builtin_type_complex, &builtin_type_double_complex, 0};
7991
7992 /* Not really used, but needed in the ada_language_defn. */
7993 static void
7994 emit_char (int c, struct ui_file *stream, int quoter)
7995 {
7996   ada_emit_char (c, stream, quoter, 1);
7997 }
7998
7999 const struct language_defn ada_language_defn = {
8000   "ada",                        /* Language name */
8001   /*  language_ada, */
8002   language_unknown,
8003   /* FIXME: language_ada should be defined in defs.h */
8004   ada_builtin_types,
8005   range_check_off,
8006   type_check_off,
8007   case_sensitive_on,            /* Yes, Ada is case-insensitive, but
8008                                  * that's not quite what this means. */
8009   ada_parse,
8010   ada_error,
8011   ada_evaluate_subexp,
8012   ada_printchar,                /* Print a character constant */
8013   ada_printstr,                 /* Function to print string constant */
8014   emit_char,                    /* Function to print single char (not used) */
8015   ada_create_fundamental_type,  /* Create fundamental type in this language */
8016   ada_print_type,               /* Print a type using appropriate syntax */
8017   ada_val_print,                /* Print a value using appropriate syntax */
8018   ada_value_print,              /* Print a top-level value */
8019   NULL,                         /* Language specific skip_trampoline */
8020   value_of_this,                /* value_of_this */
8021   basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal  */
8022   basic_lookup_transparent_type,/* lookup_transparent_type */
8023   NULL,                         /* Language specific symbol demangler */
8024   {"", "", "", ""},             /* Binary format info */
8025 #if 0
8026   {"8#%lo#", "8#", "o", "#"},   /* Octal format info */
8027   {"%ld", "", "d", ""},         /* Decimal format info */
8028   {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8029 #else
8030   /* Copied from c-lang.c. */
8031   {"0%lo", "0", "o", ""},       /* Octal format info */
8032   {"%ld", "", "d", ""},         /* Decimal format info */
8033   {"0x%lx", "0x", "x", ""},     /* Hex format info */
8034 #endif
8035   ada_op_print_tab,             /* expression operators for printing */
8036   1,                            /* c-style arrays (FIXME?) */
8037   0,                            /* String lower bound (FIXME?) */
8038   &builtin_type_ada_char,
8039   default_word_break_characters,
8040   LANG_MAGIC
8041 };
8042
8043 void
8044 _initialize_ada_language (void)
8045 {
8046   builtin_type_ada_int =
8047     init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
8048                0, "integer", (struct objfile *) NULL);
8049   builtin_type_ada_long =
8050     init_type (TYPE_CODE_INT, TARGET_LONG_BIT / TARGET_CHAR_BIT,
8051                0, "long_integer", (struct objfile *) NULL);
8052   builtin_type_ada_short =
8053     init_type (TYPE_CODE_INT, TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8054                0, "short_integer", (struct objfile *) NULL);
8055   builtin_type_ada_char =
8056     init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8057                0, "character", (struct objfile *) NULL);
8058   builtin_type_ada_float =
8059     init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
8060                0, "float", (struct objfile *) NULL);
8061   builtin_type_ada_double =
8062     init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
8063                0, "long_float", (struct objfile *) NULL);
8064   builtin_type_ada_long_long =
8065     init_type (TYPE_CODE_INT, TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8066                0, "long_long_integer", (struct objfile *) NULL);
8067   builtin_type_ada_long_double =
8068     init_type (TYPE_CODE_FLT, TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
8069                0, "long_long_float", (struct objfile *) NULL);
8070   builtin_type_ada_natural =
8071     init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
8072                0, "natural", (struct objfile *) NULL);
8073   builtin_type_ada_positive =
8074     init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
8075                0, "positive", (struct objfile *) NULL);
8076
8077
8078   builtin_type_ada_system_address =
8079     lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
8080                                     (struct objfile *) NULL));
8081   TYPE_NAME (builtin_type_ada_system_address) = "system__address";
8082
8083   add_language (&ada_language_defn);
8084
8085   add_show_from_set
8086     (add_set_cmd ("varsize-limit", class_support, var_uinteger,
8087                   (char *) &varsize_limit,
8088                   "Set maximum bytes in dynamic-sized object.",
8089                   &setlist), &showlist);
8090   varsize_limit = 65536;
8091
8092   add_com ("begin", class_breakpoint, begin_command,
8093            "Start the debugged program, stopping at the beginning of the\n\
8094 main program.  You may specify command-line arguments to give it, as for\n\
8095 the \"run\" command (q.v.).");
8096 }
8097
8098
8099 /* Create a fundamental Ada type using default reasonable for the current
8100    target machine.
8101
8102    Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8103    define fundamental types such as "int" or "double".  Others (stabs or
8104    DWARF version 2, etc) do define fundamental types.  For the formats which
8105    don't provide fundamental types, gdb can create such types using this
8106    function.
8107
8108    FIXME:  Some compilers distinguish explicitly signed integral types
8109    (signed short, signed int, signed long) from "regular" integral types
8110    (short, int, long) in the debugging information.  There is some dis-
8111    agreement as to how useful this feature is.  In particular, gcc does
8112    not support this.  Also, only some debugging formats allow the
8113    distinction to be passed on to a debugger.  For now, we always just
8114    use "short", "int", or "long" as the type name, for both the implicit
8115    and explicitly signed types.  This also makes life easier for the
8116    gdb test suite since we don't have to account for the differences
8117    in output depending upon what the compiler and debugging format
8118    support.  We will probably have to re-examine the issue when gdb
8119    starts taking it's fundamental type information directly from the
8120    debugging information supplied by the compiler.  fnf@cygnus.com */
8121
8122 static struct type *
8123 ada_create_fundamental_type (struct objfile *objfile, int typeid)
8124 {
8125   struct type *type = NULL;
8126
8127   switch (typeid)
8128     {
8129     default:
8130       /* FIXME:  For now, if we are asked to produce a type not in this
8131          language, create the equivalent of a C integer type with the
8132          name "<?type?>".  When all the dust settles from the type
8133          reconstruction work, this should probably become an error. */
8134       type = init_type (TYPE_CODE_INT,
8135                         TARGET_INT_BIT / TARGET_CHAR_BIT,
8136                         0, "<?type?>", objfile);
8137       warning ("internal error: no Ada fundamental type %d", typeid);
8138       break;
8139     case FT_VOID:
8140       type = init_type (TYPE_CODE_VOID,
8141                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8142                         0, "void", objfile);
8143       break;
8144     case FT_CHAR:
8145       type = init_type (TYPE_CODE_INT,
8146                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8147                         0, "character", objfile);
8148       break;
8149     case FT_SIGNED_CHAR:
8150       type = init_type (TYPE_CODE_INT,
8151                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8152                         0, "signed char", objfile);
8153       break;
8154     case FT_UNSIGNED_CHAR:
8155       type = init_type (TYPE_CODE_INT,
8156                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8157                         TYPE_FLAG_UNSIGNED, "unsigned char", objfile);
8158       break;
8159     case FT_SHORT:
8160       type = init_type (TYPE_CODE_INT,
8161                         TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8162                         0, "short_integer", objfile);
8163       break;
8164     case FT_SIGNED_SHORT:
8165       type = init_type (TYPE_CODE_INT,
8166                         TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8167                         0, "short_integer", objfile);
8168       break;
8169     case FT_UNSIGNED_SHORT:
8170       type = init_type (TYPE_CODE_INT,
8171                         TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8172                         TYPE_FLAG_UNSIGNED, "unsigned short", objfile);
8173       break;
8174     case FT_INTEGER:
8175       type = init_type (TYPE_CODE_INT,
8176                         TARGET_INT_BIT / TARGET_CHAR_BIT,
8177                         0, "integer", objfile);
8178       break;
8179     case FT_SIGNED_INTEGER:
8180       type = init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT, 0, "integer", objfile);        /* FIXME -fnf */
8181       break;
8182     case FT_UNSIGNED_INTEGER:
8183       type = init_type (TYPE_CODE_INT,
8184                         TARGET_INT_BIT / TARGET_CHAR_BIT,
8185                         TYPE_FLAG_UNSIGNED, "unsigned int", objfile);
8186       break;
8187     case FT_LONG:
8188       type = init_type (TYPE_CODE_INT,
8189                         TARGET_LONG_BIT / TARGET_CHAR_BIT,
8190                         0, "long_integer", objfile);
8191       break;
8192     case FT_SIGNED_LONG:
8193       type = init_type (TYPE_CODE_INT,
8194                         TARGET_LONG_BIT / TARGET_CHAR_BIT,
8195                         0, "long_integer", objfile);
8196       break;
8197     case FT_UNSIGNED_LONG:
8198       type = init_type (TYPE_CODE_INT,
8199                         TARGET_LONG_BIT / TARGET_CHAR_BIT,
8200                         TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
8201       break;
8202     case FT_LONG_LONG:
8203       type = init_type (TYPE_CODE_INT,
8204                         TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8205                         0, "long_long_integer", objfile);
8206       break;
8207     case FT_SIGNED_LONG_LONG:
8208       type = init_type (TYPE_CODE_INT,
8209                         TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8210                         0, "long_long_integer", objfile);
8211       break;
8212     case FT_UNSIGNED_LONG_LONG:
8213       type = init_type (TYPE_CODE_INT,
8214                         TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8215                         TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
8216       break;
8217     case FT_FLOAT:
8218       type = init_type (TYPE_CODE_FLT,
8219                         TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
8220                         0, "float", objfile);
8221       break;
8222     case FT_DBL_PREC_FLOAT:
8223       type = init_type (TYPE_CODE_FLT,
8224                         TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
8225                         0, "long_float", objfile);
8226       break;
8227     case FT_EXT_PREC_FLOAT:
8228       type = init_type (TYPE_CODE_FLT,
8229                         TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
8230                         0, "long_long_float", objfile);
8231       break;
8232     }
8233   return (type);
8234 }
8235
8236 void
8237 ada_dump_symtab (struct symtab *s)
8238 {
8239   int i;
8240   fprintf (stderr, "New symtab: [\n");
8241   fprintf (stderr, "  Name: %s/%s;\n",
8242            s->dirname ? s->dirname : "?", s->filename ? s->filename : "?");
8243   fprintf (stderr, "  Format: %s;\n", s->debugformat);
8244   if (s->linetable != NULL)
8245     {
8246       fprintf (stderr, "  Line table (section %d):\n", s->block_line_section);
8247       for (i = 0; i < s->linetable->nitems; i += 1)
8248         {
8249           struct linetable_entry *e = s->linetable->item + i;
8250           fprintf (stderr, "    %4ld: %8lx\n", (long) e->line, (long) e->pc);
8251         }
8252     }
8253   fprintf (stderr, "]\n");
8254 }