/usr/src/gnu/usr.bin/binutils/gdb/ada-lang.c

Bug Summary

File:	src/gnu/usr.bin/binutils/gdb/ada-lang.c
Warning:	line 932, column 22 Array access (from variable 'decoded') results in a null pointer dereference
Annotated Source Code

Press '?' to see keyboard shortcuts
Show analyzer invocation
clang -cc1 -cc1 -triple amd64-unknown-openbsd7.0 -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name ada-lang.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model pic -pic-level 1 -pic-is-pie -mframe-pointer=all -relaxed-aliasing -fno-rounding-math -mconstructor-aliases -munwind-tables -target-cpu x86-64 -target-feature +retpoline-indirect-calls -target-feature +retpoline-indirect-branches -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/usr/src/gnu/usr.bin/binutils/obj/gdb -resource-dir /usr/local/lib/clang/13.0.0 -D PIE_DEFAULT=1 -I . -I /usr/src/gnu/usr.bin/binutils/gdb -I /usr/src/gnu/usr.bin/binutils/gdb/config -D LOCALEDIR="/usr/share/locale" -D HAVE_CONFIG_H -I /usr/src/gnu/usr.bin/binutils/gdb/../include/opcode -I ../bfd -I /usr/src/gnu/usr.bin/binutils/gdb/../bfd -I /usr/src/gnu/usr.bin/binutils/gdb/../include -I ../intl -I /usr/src/gnu/usr.bin/binutils/gdb/../intl -D MI_OUT=1 -D TUI=1 -internal-isystem /usr/local/lib/clang/13.0.0/include -internal-externc-isystem /usr/include -O2 -fdebug-compilation-dir=/usr/src/gnu/usr.bin/binutils/obj/gdb -ferror-limit 19 -fwrapv -D_RET_PROTECTOR -ret-protector -fgnuc-version=4.2.1 -fcommon -vectorize-loops -vectorize-slp -fno-builtin-malloc -fno-builtin-calloc -fno-builtin-realloc -fno-builtin-valloc -fno-builtin-free -fno-builtin-strdup -fno-builtin-strndup -analyzer-output=html -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /home/ben/Projects/vmm/scan-build/2022-01-12-194120-40624-1 -x c /usr/src/gnu/usr.bin/binutils/gdb/ada-lang.c
1/* Ada language support routines for GDB, the GNU debugger.  Copyright
 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004.
 Free Software Foundation, Inc.

5This file is part of GDB.

7This program is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 2 of the License, or
10(at your option) any later version.

12This program is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15GNU General Public License for more details.

17You should have received a copy of the GNU General Public License
18along with this program; if not, write to the Free Software
19Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */


22#include "defs.h"
23#include <stdio.h>
24#include "gdb_string.h"
25#include <ctype.h>
26#include <stdarg.h>
27#include "demangle.h"
28#include "gdb_regex.h"
29#include "frame.h"
30#include "symtab.h"
31#include "gdbtypes.h"
32#include "gdbcmd.h"
33#include "expression.h"
34#include "parser-defs.h"
35#include "language.h"
36#include "c-lang.h"
37#include "inferior.h"
38#include "symfile.h"
39#include "objfiles.h"
40#include "breakpoint.h"
41#include "gdbcore.h"
42#include "hashtab.h"
43#include "gdb_obstack.h"
44#include "ada-lang.h"
45#include "completer.h"
46#include "gdb_stat.h"
47#ifdef UI_OUT
48#include "ui-out.h"
49#endif
50#include "block.h"
51#include "infcall.h"
52#include "dictionary.h"

54#ifndef ADA_RETAIN_DOTS0
55#define ADA_RETAIN_DOTS0 0
56#endif

58/* Define whether or not the C operator '/' truncates towards zero for
 differently signed operands (truncation direction is undefined in C). 
 Copied from valarith.c.  */

62#ifndef TRUNCATION_TOWARDS_ZERO((-5 / 2) == -2)
63#define TRUNCATION_TOWARDS_ZERO((-5 / 2) == -2) ((-5 / 2) == -2)
64#endif


67static void extract_string (CORE_ADDR addr, char *buf);

69static struct type *ada_create_fundamental_type (struct objfile *, int);

71static void modify_general_field (char *, LONGESTlong, int, int);

73static struct type *desc_base_type (struct type *);

75static struct type *desc_bounds_type (struct type *);

77static struct value *desc_bounds (struct value *);

79static int fat_pntr_bounds_bitpos (struct type *);

81static int fat_pntr_bounds_bitsize (struct type *);

83static struct type *desc_data_type (struct type *);

85static struct value *desc_data (struct value *);

87static int fat_pntr_data_bitpos (struct type *);

89static int fat_pntr_data_bitsize (struct type *);

91static struct value *desc_one_bound (struct value *, int, int);

93static int desc_bound_bitpos (struct type *, int, int);

95static int desc_bound_bitsize (struct type *, int, int);

97static struct type *desc_index_type (struct type *, int);

99static int desc_arity (struct type *);

101static int ada_type_match (struct type *, struct type *, int);

103static int ada_args_match (struct symbol *, struct value **, int);

105static struct value *ensure_lval (struct value *, CORE_ADDR *);

107static struct value *convert_actual (struct value *, struct type *,
                                   CORE_ADDR *);

110static struct value *make_array_descriptor (struct type *, struct value *,
                                          CORE_ADDR *);

113static void ada_add_block_symbols (struct obstack *,
                                 struct block *, const char *,
                                 domain_enum, struct objfile *,
                                 struct symtab *, int);

118static int is_nonfunction (struct ada_symbol_info *, int);

120static void add_defn_to_vec (struct obstack *, struct symbol *,
                           struct block *, struct symtab *);

123static int num_defns_collected (struct obstack *);

125static struct ada_symbol_info *defns_collected (struct obstack *, int);

127static struct partial_symbol *ada_lookup_partial_symbol (struct partial_symtab
                                                       *, const char *, int,
                                                       domain_enum, int);

131static struct symtab *symtab_for_sym (struct symbol *);

133static struct value *resolve_subexp (struct expression **, int *, int,
                                   struct type *);

136static void replace_operator_with_call (struct expression **, int, int, int,
                                      struct symbol *, struct block *);

139static int possible_user_operator_p (enum exp_opcode, struct value **);

141static char *ada_op_name (enum exp_opcode);

143static const char *ada_decoded_op_name (enum exp_opcode);

145static int numeric_type_p (struct type *);

147static int integer_type_p (struct type *);

149static int scalar_type_p (struct type *);

151static int discrete_type_p (struct type *);

153static struct type *ada_lookup_struct_elt_type (struct type *, char *,
                                              int, int, int *);

156static struct value *evaluate_subexp (struct type *, struct expression *,
                                    int *, enum noside);

159static struct value *evaluate_subexp_type (struct expression *, int *);

161static int is_dynamic_field (struct type *, int);

163static struct type *to_fixed_variant_branch_type (struct type *, char *,
                                                CORE_ADDR, struct value *);

166static struct type *to_fixed_array_type (struct type *, struct value *, int);

168static struct type *to_fixed_range_type (char *, struct value *,
                                       struct objfile *);

171static struct type *to_static_fixed_type (struct type *);

173static struct value *unwrap_value (struct value *);

175static struct type *packed_array_type (struct type *, long *);

177static struct type *decode_packed_array_type (struct type *);

179static struct value *decode_packed_array (struct value *);

181static struct value *value_subscript_packed (struct value *, int,
                                           struct value **);

184static struct value *coerce_unspec_val_to_type (struct value *,
                                              struct type *);

187static struct value *get_var_value (char *, char *);

189static int lesseq_defined_than (struct symbol *, struct symbol *);

191static int equiv_types (struct type *, struct type *);

193static int is_name_suffix (const char *);

195static int wild_match (const char *, int, const char *);

197static struct value *ada_coerce_ref (struct value *);

199static LONGESTlong pos_atr (struct value *);

201static struct value *value_pos_atr (struct value *);

203static struct value *value_val_atr (struct type *, struct value *);

205static struct symbol *standard_lookup (const char *, const struct block *,
                                     domain_enum);

208static struct value *ada_search_struct_field (char *, struct value *, int,
                                            struct type *);

211static struct value *ada_value_primitive_field (struct value *, int, int,
                                              struct type *);

214static int find_struct_field (char *, struct type *, int,
                            struct type **, int *, int *, int *);

217static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
                                              struct value *);

220static struct value *ada_to_fixed_value (struct value *);

222static int ada_resolve_function (struct ada_symbol_info *, int,
                               struct value **, int, const char *,
                               struct type *);

226static struct value *ada_coerce_to_simple_array (struct value *);

228static int ada_is_direct_array_type (struct type *);

230static void ada_language_arch_info (struct gdbarch *,
		    struct language_arch_info *);

233static void check_size (const struct type *);
234


237/* Maximum-sized dynamic type.  */
238static unsigned int varsize_limit;

240/* FIXME: brobecker/2003-09-17: No longer a const because it is
 returned by a function that does not return a const char *.  */
242static char *ada_completer_word_break_characters =
243#ifdef VMS
" \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
245#else
" \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
247#endif

249/* The name of the symbol to use to get the name of the main subprogram.  */
250static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
= "__gnat_ada_main_program_name";

253/* The name of the runtime function called when an exception is raised.  */
254static const char raise_sym_name[] = "__gnat_raise_nodefer_with_msg";

256/* The name of the runtime function called when an unhandled exception
 is raised.  */
258static const char raise_unhandled_sym_name[] = "__gnat_unhandled_exception";

260/* The name of the runtime function called when an assert failure is
 raised.  */
262static const char raise_assert_sym_name[] =
"system__assertions__raise_assert_failure";

265/* When GDB stops on an unhandled exception, GDB will go up the stack until
 if finds a frame corresponding to this function, in order to extract the
 name of the exception that has been raised from one of the parameters.  */
268static const char process_raise_exception_name[] =
"ada__exceptions__process_raise_exception";

271/* A string that reflects the longest exception expression rewrite,
 aside from the exception name.  */
273static const char longest_exception_template[] =
"'__gnat_raise_nodefer_with_msg' if long_integer(e) = long_integer(&)";

276/* Limit on the number of warnings to raise per expression evaluation.  */
277static int warning_limit = 2;

279/* Number of warning messages issued; reset to 0 by cleanups after
 expression evaluation.  */
281static int warnings_issued = 0;

283static const char *known_runtime_file_name_patterns[] = {
ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS"^[agis]-.*\\.ad[bs]$", NULL((void*)0)
285};

287static const char *known_auxiliary_function_name_patterns[] = {
ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS"___clean[.a-zA-Z0-9_]*$", NULL((void*)0)
289};

291/* Space for allocating results of ada_lookup_symbol_list.  */
292static struct obstack symbol_list_obstack;

                      /* Utilities */


297static char *
298ada_get_gdb_completer_word_break_characters (void)
299{
return ada_completer_word_break_characters;
301}

303/* Read the string located at ADDR from the inferior and store the
 result into BUF.  */

306static void
307extract_string (CORE_ADDR addr, char *buf)
308{
int char_index = 0;

/* Loop, reading one byte at a time, until we reach the '\000'
   end-of-string marker.  */
do
  {
    target_read_memory (addr + char_index * sizeof (char),
                        buf + char_index * sizeof (char), sizeof (char));
    char_index++;
  }
while (buf[char_index - 1] != '\000');
320}

322/* Assuming *OLD_VECT points to an array of *SIZE objects of size
 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
 updating *OLD_VECT and *SIZE as necessary.  */

326void
327grow_vect (void **old_vect, size_t * size, size_t min_size, int element_size)
328{
if (*size < min_size)
  {
    *size *= 2;
    if (*size < min_size)
      *size = min_size;
    *old_vect = xrealloc (*old_vect, *size * element_size);
  }
336}

338/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
 suffix of FIELD_NAME beginning "___".  */

341static int
342field_name_match (const char *field_name, const char *target)
343{
int len = strlen (target);
return
  (strncmp (field_name, target, len) == 0
   && (field_name[len] == '\0'
       || (strncmp (field_name + len, "___", 3) == 0
           && strcmp (field_name + strlen (field_name) - 6,
                      "___XVN") != 0)));
351}


354/* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
 FIELD_NAME, and return its index.  This function also handles fields
 whose name have ___ suffixes because the compiler sometimes alters
 their name by adding such a suffix to represent fields with certain
 constraints.  If the field could not be found, return a negative
 number if MAYBE_MISSING is set.  Otherwise raise an error.  */

361int
362ada_get_field_index (const struct type *type, const char *field_name,
                   int maybe_missing)
364{
int fieldno;
for (fieldno = 0; fieldno < TYPE_NFIELDS (type)(type)->main_type->nfields; fieldno++)
  if (field_name_match (TYPE_FIELD_NAME (type, fieldno)(((type)->main_type->fields[fieldno]).name), field_name))
    return fieldno;

if (!maybe_missing)
  error ("Unable to find field %s in struct %s.  Aborting",
         field_name, TYPE_NAME (type)(type)->main_type->name);

return -1;
375}

377/* The length of the prefix of NAME prior to any "___" suffix.  */

379int
380ada_name_prefix_len (const char *name)
381{
if (name == NULL((void*)0))
  return 0;
else
  {
    const char *p = strstr (name, "___");
    if (p == NULL((void*)0))
      return strlen (name);
    else
      return p - name;
  }
392}

394/* Return non-zero if SUFFIX is a suffix of STR.
 Return zero if STR is null.  */

397static int
398is_suffix (const char *str, const char *suffix)
399{
int len1, len2;
if (str == NULL((void*)0))
  return 0;
len1 = strlen (str);
len2 = strlen (suffix);
return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
406}

408/* Create a value of type TYPE whose contents come from VALADDR, if it
 is non-null, and whose memory address (in the inferior) is
 ADDRESS.  */

412struct value *
413value_from_contents_and_address (struct type *type, char *valaddr,
                               CORE_ADDR address)
415{
struct value *v = allocate_value (type);
if (valaddr == NULL((void*)0))
  VALUE_LAZY (v)(v)->lazy = 1;
else
  memcpy (VALUE_CONTENTS_RAW (v)((char *) (v)->aligner.contents + (v)->embedded_offset), valaddr, TYPE_LENGTH (type)(type)->length);
VALUE_ADDRESS (v)(v)->location.address = address;
if (address != 0)
  VALUE_LVAL (v)(v)->lval = lval_memory;
return v;
425}

427/* The contents of value VAL, treated as a value of type TYPE.  The
 result is an lval in memory if VAL is.  */

430static struct value *
431coerce_unspec_val_to_type (struct value *val, struct type *type)
432{
type = ada_check_typedef (type);
if (VALUE_TYPE (val)(val)->type == type)
  return val;
else
  {
    struct value *result;

    /* Make sure that the object size is not unreasonable before
       trying to allocate some memory for it.  */
    check_size (type);

    result = allocate_value (type);
    VALUE_LVAL (result)(result)->lval = VALUE_LVAL (val)(val)->lval;
    VALUE_BITSIZE (result)(result)->bitsize = VALUE_BITSIZE (val)(val)->bitsize;
    VALUE_BITPOS (result)(result)->bitpos = VALUE_BITPOS (val)(val)->bitpos;
    VALUE_ADDRESS (result)(result)->location.address = VALUE_ADDRESS (val)(val)->location.address + VALUE_OFFSET (val)(val)->offset;
    if (VALUE_LAZY (val)(val)->lazy
        || TYPE_LENGTH (type)(type)->length > TYPE_LENGTH (VALUE_TYPE (val))((val)->type)->length)
      VALUE_LAZY (result)(result)->lazy = 1;
    else
      memcpy (VALUE_CONTENTS_RAW (result)((char *) (result)->aligner.contents + (result)->embedded_offset
), VALUE_CONTENTS (val)((void)((val)->lazy && value_fetch_lazy(val)), ((char
 *) (val)->aligner.contents + (val)->embedded_offset)),
              TYPE_LENGTH (type)(type)->length);
    return result;
  }
457}

459static char *
460cond_offset_host (char *valaddr, long offset)
461{
if (valaddr == NULL((void*)0))
  return NULL((void*)0);
else
  return valaddr + offset;
466}

468static CORE_ADDR
469cond_offset_target (CORE_ADDR address, long offset)
470{
if (address == 0)
  return 0;
else
  return address + offset;
475}

477/* Issue a warning (as for the definition of warning in utils.c, but
 with exactly one argument rather than ...), unless the limit on the
 number of warnings has passed during the evaluation of the current
 expression.  */

482/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
 provided by "complaint".  */
484static void lim_warning (const char *format, ...) ATTR_FORMAT (printf, 1, 2)__attribute__ ((format(printf, 1, 2)));

486static void
487lim_warning (const char *format, ...)
488{
va_list args;
va_start (args, format)__builtin_va_start(args, format);

warnings_issued += 1;
if (warnings_issued <= warning_limit)
  vwarning (format, args);

va_end (args)__builtin_va_end(args);
497}

499/* Issue an error if the size of an object of type T is unreasonable,
 i.e. if it would be a bad idea to allocate a value of this type in
 GDB.  */

503static void
504check_size (const struct type *type)
505{
if (TYPE_LENGTH (type)(type)->length > varsize_limit)
  error ("object size is larger than varsize-limit");
508}


511/* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
 gdbtypes.h, but some of the necessary definitions in that file
 seem to have gone missing. */

515/* Maximum value of a SIZE-byte signed integer type. */
516static LONGESTlong
517max_of_size (int size)
518{
LONGESTlong top_bit = (LONGESTlong) 1 << (size * 8 - 2);
return top_bit | (top_bit - 1);
521}

523/* Minimum value of a SIZE-byte signed integer type. */
524static LONGESTlong
525min_of_size (int size)
526{
return -max_of_size (size) - 1;
528}

530/* Maximum value of a SIZE-byte unsigned integer type. */
531static ULONGESTunsigned long
532umax_of_size (int size)
533{
ULONGESTunsigned long top_bit = (ULONGESTunsigned long) 1 << (size * 8 - 1);
return top_bit | (top_bit - 1);
536}

538/* Maximum value of integral type T, as a signed quantity. */
539static LONGESTlong
540max_of_type (struct type *t)
541{
if (TYPE_UNSIGNED (t)((t)->main_type->flags & (1 << 0)))
  return (LONGESTlong) umax_of_size (TYPE_LENGTH (t)(t)->length);
else
  return max_of_size (TYPE_LENGTH (t)(t)->length);
546}

548/* Minimum value of integral type T, as a signed quantity. */
549static LONGESTlong
550min_of_type (struct type *t)
551{
if (TYPE_UNSIGNED (t)((t)->main_type->flags & (1 << 0))) 
  return 0;
else
  return min_of_size (TYPE_LENGTH (t)(t)->length);
556}

558/* The largest value in the domain of TYPE, a discrete type, as an integer.  */
559static struct value *
560discrete_type_high_bound (struct type *type)
561{
switch (TYPE_CODE (type)(type)->main_type->code)
  {
  case TYPE_CODE_RANGE:
    return value_from_longest (TYPE_TARGET_TYPE (type)(type)->main_type->target_type,
                               TYPE_HIGH_BOUND (type)(((type)->main_type->fields[1]).loc.bitpos));
  case TYPE_CODE_ENUM:
    return
      value_from_longest (type,
                          TYPE_FIELD_BITPOS (type,(((type)->main_type->fields[(type)->main_type->nfields
 - 1]).loc.bitpos)
                                             TYPE_NFIELDS (type) - 1)(((type)->main_type->fields[(type)->main_type->nfields
 - 1]).loc.bitpos));
  case TYPE_CODE_INT:
    return value_from_longest (type, max_of_type (type));
  default:
    error ("Unexpected type in discrete_type_high_bound.");
  }
577}

579/* The largest value in the domain of TYPE, a discrete type, as an integer.  */
580static struct value *
581discrete_type_low_bound (struct type *type)
582{
switch (TYPE_CODE (type)(type)->main_type->code)
  {
  case TYPE_CODE_RANGE:
    return value_from_longest (TYPE_TARGET_TYPE (type)(type)->main_type->target_type,
                               TYPE_LOW_BOUND (type)(((type)->main_type->fields[0]).loc.bitpos));
  case TYPE_CODE_ENUM:
    return value_from_longest (type, TYPE_FIELD_BITPOS (type, 0)(((type)->main_type->fields[0]).loc.bitpos));
  case TYPE_CODE_INT:
    return value_from_longest (type, min_of_type (type));
  default:
    error ("Unexpected type in discrete_type_low_bound.");
  }
595}

597/* The identity on non-range types.  For range types, the underlying
 non-range scalar type.  */

600static struct type *
601base_type (struct type *type)
602{
while (type != NULL((void*)0) && TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_RANGE)
  {
    if (type == TYPE_TARGET_TYPE (type)(type)->main_type->target_type || TYPE_TARGET_TYPE (type)(type)->main_type->target_type == NULL((void*)0))
      return type;
    type = TYPE_TARGET_TYPE (type)(type)->main_type->target_type;
  }
return type;
610}
611

                              /* Language Selection */

615/* If the main program is in Ada, return language_ada, otherwise return LANG
 (the main program is in Ada iif the adainit symbol is found).

 MAIN_PST is not used.  */

620enum language
621ada_update_initial_language (enum language lang,
                           struct partial_symtab *main_pst)
623{
if (lookup_minimal_symbol ("adainit", (const char *) NULL((void*)0),
                           (struct objfile *) NULL((void*)0)) != NULL((void*)0))
  return language_ada;

return lang;
629}

631/* If the main procedure is written in Ada, then return its name.
 The result is good until the next call.  Return NULL if the main
 procedure doesn't appear to be in Ada.  */

635char *
636ada_main_name (void)
637{
struct minimal_symbol *msym;
CORE_ADDR main_program_name_addr;
static char main_program_name[1024];

/* For Ada, the name of the main procedure is stored in a specific
   string constant, generated by the binder.  Look for that symbol,
   extract its address, and then read that string.  If we didn't find
   that string, then most probably the main procedure is not written
   in Ada.  */
msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL((void*)0), NULL((void*)0));

if (msym != NULL((void*)0))
  {
    main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym)(msym)->ginfo.value.address;
    if (main_program_name_addr == 0)
      error ("Invalid address for Ada main program name.");

    extract_string (main_program_name_addr, main_program_name);
    return main_program_name;
  }

/* The main procedure doesn't seem to be in Ada.  */
return NULL((void*)0);
661}
662
                              /* Symbols */

665/* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
 of NULLs.  */

668const struct ada_opname_map ada_opname_table[] = {
{"Oadd", "\"+\"", BINOP_ADD},
{"Osubtract", "\"-\"", BINOP_SUB},
{"Omultiply", "\"*\"", BINOP_MUL},
{"Odivide", "\"/\"", BINOP_DIV},
{"Omod", "\"mod\"", BINOP_MOD},
{"Orem", "\"rem\"", BINOP_REM},
{"Oexpon", "\"**\"", BINOP_EXP},
{"Olt", "\"<\"", BINOP_LESS},
{"Ole", "\"<=\"", BINOP_LEQ},
{"Ogt", "\">\"", BINOP_GTR},
{"Oge", "\">=\"", BINOP_GEQ},
{"Oeq", "\"=\"", BINOP_EQUAL},
{"One", "\"/=\"", BINOP_NOTEQUAL},
{"Oand", "\"and\"", BINOP_BITWISE_AND},
{"Oor", "\"or\"", BINOP_BITWISE_IOR},
{"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
{"Oconcat", "\"&\"", BINOP_CONCAT},
{"Oabs", "\"abs\"", UNOP_ABS},
{"Onot", "\"not\"", UNOP_LOGICAL_NOT},
{"Oadd", "\"+\"", UNOP_PLUS},
{"Osubtract", "\"-\"", UNOP_NEG},
{NULL((void*)0), NULL((void*)0)}
691};

693/* Return non-zero if STR should be suppressed in info listings.  */

695static int
696is_suppressed_name (const char *str)
697{
if (strncmp (str, "_ada_", 5) == 0)
  str += 5;
if (str[0] == '_' || str[0] == '\000')
  return 1;
else
  {
    const char *p;
    const char *suffix = strstr (str, "___");
    if (suffix != NULL((void*)0) && suffix[3] != 'X')
      return 1;
    if (suffix == NULL((void*)0))
      suffix = str + strlen (str);
    for (p = suffix - 1; p != str; p -= 1)
      if (isupper (*p))
        {
          int i;
          if (p[0] == 'X' && p[-1] != '_')
            goto OK;
          if (*p != 'O')
            return 1;
          for (i = 0; ada_opname_table[i].encoded != NULL((void*)0); i += 1)
            if (strncmp (ada_opname_table[i].encoded, p,
                         strlen (ada_opname_table[i].encoded)) == 0)
              goto OK;
          return 1;
        OK:;
        }
    return 0;
  }
727}

729/* The "encoded" form of DECODED, according to GNAT conventions.
 The result is valid until the next call to ada_encode.  */

732char *
733ada_encode (const char *decoded)
734{
static char *encoding_buffer = NULL((void*)0);
static size_t encoding_buffer_size = 0;
const char *p;
int k;

if (decoded == NULL((void*)0))
  return NULL((void*)0);

GROW_VECT (encoding_buffer, encoding_buffer_size,if ((encoding_buffer_size) < (2 * strlen (decoded) + 10)) grow_vect
 ((void**) &(encoding_buffer), &(encoding_buffer_size
), (2 * strlen (decoded) + 10), sizeof(*(encoding_buffer)));
           2 * strlen (decoded) + 10)if ((encoding_buffer_size) < (2 * strlen (decoded) + 10)) grow_vect
 ((void**) &(encoding_buffer), &(encoding_buffer_size
), (2 * strlen (decoded) + 10), sizeof(*(encoding_buffer)));;

k = 0;
for (p = decoded; *p != '\0'; p += 1)
  {
    if (!ADA_RETAIN_DOTS0 && *p == '.')
      {
        encoding_buffer[k] = encoding_buffer[k + 1] = '_';
        k += 2;
      }
    else if (*p == '"')
      {
        const struct ada_opname_map *mapping;

        for (mapping = ada_opname_table;
             mapping->encoded != NULL((void*)0)
             && strncmp (mapping->decoded, p,
                         strlen (mapping->decoded)) != 0; mapping += 1)
          ;
        if (mapping->encoded == NULL((void*)0))
          error ("invalid Ada operator name: %s", p);
        strcpy (encoding_buffer + k, mapping->encoded);
        k += strlen (mapping->encoded);
        break;
      }
    else
      {
        encoding_buffer[k] = *p;
        k += 1;
      }
  }

encoding_buffer[k] = '\0';
return encoding_buffer;
778}

780/* Return NAME folded to lower case, or, if surrounded by single
 quotes, unfolded, but with the quotes stripped away.  Result good
 to next call.  */

784char *
785ada_fold_name (const char *name)
786{
static char *fold_buffer = NULL((void*)0);
static size_t fold_buffer_size = 0;

int len = strlen (name);
GROW_VECT (fold_buffer, fold_buffer_size, len + 1)if ((fold_buffer_size) < (len + 1)) grow_vect ((void**) &
(fold_buffer), &(fold_buffer_size), (len + 1), sizeof(*(fold_buffer
)));;

if (name[0] == '\'')
  {
    strncpy (fold_buffer, name + 1, len - 2);
    fold_buffer[len - 2] = '\000';
  }
else
  {
    int i;
    for (i = 0; i <= len; i += 1)
      fold_buffer[i] = tolower (name[i]);
  }

return fold_buffer;
806}

808/* decode:
   0. Discard trailing .{DIGIT}+ or trailing ___{DIGIT}+
      These are suffixes introduced by GNAT5 to nested subprogram
      names, and do not serve any purpose for the debugger.
   1. Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
   2. Convert other instances of embedded "__" to `.'.
   3. Discard leading _ada_.
   4. Convert operator names to the appropriate quoted symbols.
   5. Remove everything after first ___ if it is followed by
      'X'.
   6. Replace TK__ with __, and a trailing B or TKB with nothing.
   7. Put symbols that should be suppressed in <...> brackets.
   8. Remove trailing X[bn]* suffix (indicating names in package bodies).

 The resulting string is valid until the next call of ada_decode.
 If the string is unchanged by demangling, the original string pointer
 is returned.  */

826const char *
827ada_decode (const char *encoded)
828{
int i, j;
int len0;
const char *p;
char *decoded;
int at_start_name;
static char *decoding_buffer = NULL((void*)0);
1
'decoding_buffer' initialized to a null pointer value→
static size_t decoding_buffer_size = 0;

if (strncmp (encoded, "_ada_", 5) == 0)
2
←
Assuming the condition is false→
3
←
Taking false branch→
  encoded += 5;

if (encoded[0] == '_' || encoded[0] == '<')
4
←
Assuming the condition is false→
5
←
Assuming the condition is false→
6
←
Taking false branch→
  goto Suppress;

/* Remove trailing .{DIGIT}+ or ___{DIGIT}+.  */
len0 = strlen (encoded);
if (len0 > 1 && isdigit (encoded[len0 - 1]))
7
←
Assuming 'len0' is <= 1→
  {
    i = len0 - 2;
    while (i > 0 && isdigit (encoded[i]))
      i--;
    if (i >= 0 && encoded[i] == '.')
      len0 = i;
    else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
      len0 = i - 2;
  }

/* Remove the ___X.* suffix if present.  Do not forget to verify that
   the suffix is located before the current "end" of ENCODED.  We want
   to avoid re-matching parts of ENCODED that have previously been
   marked as discarded (by decrementing LEN0).  */
p = strstr (encoded, "___");
if (p != NULL((void*)0) && p - encoded < len0 - 3)
8
←
Assuming 'p' is not equal to NULL→
9
←
Assuming the condition is true→
10
←
Taking true branch→
  {
    if (p[3] == 'X')
11
←
Assuming the condition is true→
12
←
Taking true branch→
      len0 = p - encoded;
    else
      goto Suppress;
  }

if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
13
←
Assuming 'len0' is > 3→
14
←
Assuming the condition is false→
15
←
Taking false branch→
  len0 -= 3;

if (len015.1
'len0' is > 1
 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
16
←
Assuming the condition is false→
17
←
Taking false branch→
  len0 -= 1;

/* Make decoded big enough for possible expansion by operator name.  */
GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1)if ((decoding_buffer_size) < (2 * len0 + 1)) grow_vect ((void
**) &(decoding_buffer), &(decoding_buffer_size), (2 *
 len0 + 1), sizeof(*(decoding_buffer)));;
18
←
Assuming the condition is false→
19
←
Taking false branch→
decoded = decoding_buffer;
20
←
Null pointer value stored to 'decoded'→

if (len020.1
'len0' is > 1
 > 1 && isdigit (encoded[len0 - 1]))
21
←
Taking false branch→
  {
    i = len0 - 2;
    while ((i >= 0 && isdigit (encoded[i]))
           || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
      i -= 1;
    if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
      len0 = i - 1;
    else if (encoded[i] == '$')
      len0 = i;
  }

for (i = 0, j = 0; i21.1
'i' is < 'len0'
 < len0 && !isalpha (encoded[i]); i += 1, j += 1)
22
←
Loop condition is false. Execution continues on line 894→
  decoded[j] = encoded[i];

at_start_name = 1;
while (i22.1
'i' is < 'len0'
 < len0)
23
←
Loop condition is true.  Entering loop body→
  {
    if (at_start_name23.1
'at_start_name' is 1
 && encoded[i] == 'O')
24
←
Assuming the condition is false→
25
←
Taking false branch→
      {
        int k;
        for (k = 0; ada_opname_table[k].encoded != NULL((void*)0); k += 1)
          {
            int op_len = strlen (ada_opname_table[k].encoded);
            if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
                          op_len - 1) == 0)
                && !isalnum (encoded[i + op_len]))
              {
                strcpy (decoded + j, ada_opname_table[k].decoded);
                at_start_name = 0;
                i += op_len;
                j += strlen (ada_opname_table[k].decoded);
                break;
              }
          }
        if (ada_opname_table[k].encoded != NULL((void*)0))
          continue;
      }
    at_start_name = 0;

    if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
26
←
Assuming the condition is true→
27
←
Taking true branch→
      i += 2;
    if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
28
←
Assuming the condition is false→
      {
        do
          i += 1;
        while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
        if (i < len0)
          goto Suppress;
      }
    else if (!ADA_RETAIN_DOTS0
31
←
Taking true branch→
             && i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
29
←
Assuming the condition is true→
30
←
Assuming the condition is true→
      {
        decoded[j] = '.';
32
←
Array access (from variable 'decoded') results in a null pointer dereference
        at_start_name = 1;
        i += 2;
        j += 1;
      }
    else
      {
        decoded[j] = encoded[i];
        i += 1;
        j += 1;
      }
  }
decoded[j] = '\000';

for (i = 0; decoded[i] != '\0'; i += 1)
  if (isupper (decoded[i]) || decoded[i] == ' ')
    goto Suppress;

if (strcmp (decoded, encoded) == 0)
  return encoded;
else
  return decoded;

955Suppress:
GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3)if ((decoding_buffer_size) < (strlen (encoded) + 3)) grow_vect
 ((void**) &(decoding_buffer), &(decoding_buffer_size
), (strlen (encoded) + 3), sizeof(*(decoding_buffer)));;
decoded = decoding_buffer;
if (encoded[0] == '<')
  strcpy (decoded, encoded);
else
  sprintf (decoded, "<%s>", encoded);
return decoded;

964}

966/* Table for keeping permanent unique copies of decoded names.  Once
 allocated, names in this table are never released.  While this is a
 storage leak, it should not be significant unless there are massive
 changes in the set of decoded names in successive versions of a 
 symbol table loaded during a single session.  */
971static struct htab *decoded_names_store;

973/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
 in the language-specific part of GSYMBOL, if it has not been
 previously computed.  Tries to save the decoded name in the same
 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
 in any case, the decoded symbol has a lifetime at least that of
 GSYMBOL).  
 The GSYMBOL parameter is "mutable" in the C++ sense: logically
 const, but nevertheless modified to a semantically equivalent form
 when a decoded name is cached in it.
982*/

984char *
985ada_decode_symbol (const struct general_symbol_info *gsymbol)
986{
char **resultp =
  (char **) &gsymbol->language_specific.cplus_specific.demangled_name;
if (*resultp == NULL((void*)0))
  {
    const char *decoded = ada_decode (gsymbol->name);
    if (gsymbol->bfd_section != NULL((void*)0))
      {
        bfd *obfd = gsymbol->bfd_section->owner;
        if (obfd != NULL((void*)0))
          {
            struct objfile *objf;
            ALL_OBJFILES (objf)for ((objf) = object_files; (objf) != ((void*)0); (objf) = (objf
)->next)
            {
              if (obfd == objf->obfd)
                {
                  *resultp = obsavestring (decoded, strlen (decoded),
                                           &objf->objfile_obstack);
                  break;
                }
            }
          }
      }
    /* Sometimes, we can't find a corresponding objfile, in which
       case, we put the result on the heap.  Since we only decode
       when needed, we hope this usually does not cause a
       significant memory leak (FIXME).  */
    if (*resultp == NULL((void*)0))
      {
        char **slot = (char **) htab_find_slot (decoded_names_store,
                                                decoded, INSERT);
        if (*slot == NULL((void*)0))
          *slot = xstrdup (decoded);
        *resultp = *slot;
      }
  }

return *resultp;
1024}

1026char *
1027ada_la_decode (const char *encoded, int options)
1028{
return xstrdup (ada_decode (encoded));
1030}

1032/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
 suffixes that encode debugging information or leading _ada_ on
 SYM_NAME (see is_name_suffix commentary for the debugging
 information that is ignored).  If WILD, then NAME need only match a
 suffix of SYM_NAME minus the same suffixes.  Also returns 0 if
 either argument is NULL.  */

1039int
1040ada_match_name (const char *sym_name, const char *name, int wild)
1041{
if (sym_name == NULL((void*)0) || name == NULL((void*)0))
  return 0;
else if (wild)
  return wild_match (name, strlen (name), sym_name);
else
  {
    int len_name = strlen (name);
    return (strncmp (sym_name, name, len_name) == 0
            && is_name_suffix (sym_name + len_name))
      || (strncmp (sym_name, "_ada_", 5) == 0
          && strncmp (sym_name + 5, name, len_name) == 0
          && is_name_suffix (sym_name + len_name + 5));
  }
1055}

1057/* True (non-zero) iff, in Ada mode, the symbol SYM should be
 suppressed in info listings.  */

1060int
1061ada_suppress_symbol_printing (struct symbol *sym)
1062{
if (SYMBOL_DOMAIN (sym)(sym)->domain == STRUCT_DOMAIN)
  return 1;
else
  return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym)(sym)->ginfo.name);
1067}
1068

                              /* Arrays */

1072/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors.  */

1074static char *bound_name[] = {
"LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
"LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1077};

1079/* Maximum number of array dimensions we are prepared to handle.  */

1081#define MAX_ADA_DIMENS(sizeof(bound_name) / (2*sizeof(char *))) (sizeof(bound_name) / (2*sizeof(char *)))

1083/* Like modify_field, but allows bitpos > wordlength.  */

1085static void
1086modify_general_field (char *addr, LONGESTlong fieldval, int bitpos, int bitsize)
1087{
modify_field (addr + bitpos / 8, fieldval, bitpos % 8, bitsize);
1089}


1092/* The desc_* routines return primitive portions of array descriptors
 (fat pointers).  */

1095/* The descriptor or array type, if any, indicated by TYPE; removes
 level of indirection, if needed.  */

1098static struct type *
1099desc_base_type (struct type *type)
1100{
if (type == NULL((void*)0))
  return NULL((void*)0);
type = ada_check_typedef (type);
if (type != NULL((void*)0)
    && (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_PTR
        || TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_REF))
  return ada_check_typedef (TYPE_TARGET_TYPE (type)(type)->main_type->target_type);
else
  return type;
1110}

1112/* True iff TYPE indicates a "thin" array pointer type.  */

1114static int
1115is_thin_pntr (struct type *type)
1116{
return
  is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
  || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1120}

1122/* The descriptor type for thin pointer type TYPE.  */

1124static struct type *
1125thin_descriptor_type (struct type *type)
1126{
struct type *base_type = desc_base_type (type);
if (base_type == NULL((void*)0))
  return NULL((void*)0);
if (is_suffix (ada_type_name (base_type), "___XVE"))
  return base_type;
else
  {
    struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
    if (alt_type == NULL((void*)0))
      return base_type;
    else
      return alt_type;
  }
1140}

1142/* A pointer to the array data for thin-pointer value VAL.  */

1144static struct value *
1145thin_data_pntr (struct value *val)
1146{
struct type *type = VALUE_TYPE (val)(val)->type;
if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_PTR)
  return value_cast (desc_data_type (thin_descriptor_type (type)),
                     value_copy (val));
else
  return value_from_longest (desc_data_type (thin_descriptor_type (type)),
                             VALUE_ADDRESS (val)(val)->location.address + VALUE_OFFSET (val)(val)->offset);
1154}

1156/* True iff TYPE indicates a "thick" array pointer type.  */

1158static int
1159is_thick_pntr (struct type *type)
1160{
type = desc_base_type (type);
return (type != NULL((void*)0) && TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_STRUCT
        && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL((void*)0));
1164}

1166/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
 pointer to one, the type of its bounds data; otherwise, NULL.  */

1169static struct type *
1170desc_bounds_type (struct type *type)
1171{
struct type *r;

type = desc_base_type (type);

if (type == NULL((void*)0))
  return NULL((void*)0);
else if (is_thin_pntr (type))
  {
    type = thin_descriptor_type (type);
    if (type == NULL((void*)0))
      return NULL((void*)0);
    r = lookup_struct_elt_type (type, "BOUNDS", 1);
    if (r != NULL((void*)0))
      return ada_check_typedef (r);
  }
else if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_STRUCT)
  {
    r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
    if (r != NULL((void*)0))
      return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r))(ada_check_typedef (r))->main_type->target_type);
  }
return NULL((void*)0);
1194}

1196/* If ARR is an array descriptor (fat or thin pointer), or pointer to
 one, a pointer to its bounds data.   Otherwise NULL.  */

1199static struct value *
1200desc_bounds (struct value *arr)
1201{
struct type *type = ada_check_typedef (VALUE_TYPE (arr)(arr)->type);
if (is_thin_pntr (type))
  {
    struct type *bounds_type =
      desc_bounds_type (thin_descriptor_type (type));
    LONGESTlong addr;

    if (desc_bounds_type == NULL((void*)0))
      error ("Bad GNAT array descriptor");

    /* NOTE: The following calculation is not really kosher, but
       since desc_type is an XVE-encoded type (and shouldn't be),
       the correct calculation is a real pain.  FIXME (and fix GCC).  */
    if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_PTR)
      addr = value_as_long (arr);
    else
      addr = VALUE_ADDRESS (arr)(arr)->location.address + VALUE_OFFSET (arr)(arr)->offset;

    return
      value_from_longest (lookup_pointer_type (bounds_type),
                          addr - TYPE_LENGTH (bounds_type)(bounds_type)->length);
  }

else if (is_thick_pntr (type))
  return value_struct_elt (&arr, NULL((void*)0), "P_BOUNDS", NULL((void*)0),
                           "Bad GNAT array descriptor");
else
  return NULL((void*)0);
1230}

1232/* If TYPE is the type of an array-descriptor (fat pointer),  the bit
 position of the field containing the address of the bounds data.  */

1235static int
1236fat_pntr_bounds_bitpos (struct type *type)
1237{
return TYPE_FIELD_BITPOS (desc_base_type (type), 1)(((desc_base_type (type))->main_type->fields[1]).loc.bitpos
);
1239}

1241/* If TYPE is the type of an array-descriptor (fat pointer), the bit
 size of the field containing the address of the bounds data.  */

1244static int
1245fat_pntr_bounds_bitsize (struct type *type)
1246{
type = desc_base_type (type);

if (TYPE_FIELD_BITSIZE (type, 1)(((type)->main_type->fields[1]).bitsize) > 0)
  return TYPE_FIELD_BITSIZE (type, 1)(((type)->main_type->fields[1]).bitsize);
else
  return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)))(ada_check_typedef ((((type)->main_type->fields[1]).type
)))->length;
1253}

1255/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
 pointer to one, the type of its array data (a
 pointer-to-array-with-no-bounds type); otherwise, NULL.  Use
 ada_type_of_array to get an array type with bounds data.  */

1260static struct type *
1261desc_data_type (struct type *type)
1262{
type = desc_base_type (type);

/* NOTE: The following is bogus; see comment in desc_bounds.  */
if (is_thin_pntr (type))
  return lookup_pointer_type
    (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)(((thin_descriptor_type (type))->main_type->fields[1]).
type)));
else if (is_thick_pntr (type))
  return lookup_struct_elt_type (type, "P_ARRAY", 1);
else
  return NULL((void*)0);
1273}

1275/* If ARR is an array descriptor (fat or thin pointer), a pointer to
 its array data.  */

1278static struct value *
1279desc_data (struct value *arr)
1280{
struct type *type = VALUE_TYPE (arr)(arr)->type;
if (is_thin_pntr (type))
  return thin_data_pntr (arr);
else if (is_thick_pntr (type))
  return value_struct_elt (&arr, NULL((void*)0), "P_ARRAY", NULL((void*)0),
                           "Bad GNAT array descriptor");
else
  return NULL((void*)0);
1289}


1292/* If TYPE is the type of an array-descriptor (fat pointer), the bit
 position of the field containing the address of the data.  */

1295static int
1296fat_pntr_data_bitpos (struct type *type)
1297{
return TYPE_FIELD_BITPOS (desc_base_type (type), 0)(((desc_base_type (type))->main_type->fields[0]).loc.bitpos
);
1299}

1301/* If TYPE is the type of an array-descriptor (fat pointer), the bit
 size of the field containing the address of the data.  */

1304static int
1305fat_pntr_data_bitsize (struct type *type)
1306{
type = desc_base_type (type);

if (TYPE_FIELD_BITSIZE (type, 0)(((type)->main_type->fields[0]).bitsize) > 0)
  return TYPE_FIELD_BITSIZE (type, 0)(((type)->main_type->fields[0]).bitsize);
else
  return TARGET_CHAR_BIT8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0))((((type)->main_type->fields[0]).type))->length;
1313}

1315/* If BOUNDS is an array-bounds structure (or pointer to one), return
 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
 bound, if WHICH is 1.  The first bound is I=1.  */

1319static struct value *
1320desc_one_bound (struct value *bounds, int i, int which)
1321{
return value_struct_elt (&bounds, NULL((void*)0), bound_name[2 * i + which - 2], NULL((void*)0),
                         "Bad GNAT array descriptor bounds");
1324}

1326/* If BOUNDS is an array-bounds structure type, return the bit position
 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
 bound, if WHICH is 1.  The first bound is I=1.  */

1330static int
1331desc_bound_bitpos (struct type *type, int i, int which)
1332{
return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2)(((desc_base_type (type))->main_type->fields[2 * i + which
 - 2]).loc.bitpos);
1334}

1336/* If BOUNDS is an array-bounds structure type, return the bit field size
 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
 bound, if WHICH is 1.  The first bound is I=1.  */

1340static int
1341desc_bound_bitsize (struct type *type, int i, int which)
1342{
type = desc_base_type (type);

if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2)(((type)->main_type->fields[2 * i + which - 2]).bitsize
) > 0)
  return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2)(((type)->main_type->fields[2 * i + which - 2]).bitsize
);
else
  return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2))((((type)->main_type->fields[2 * i + which - 2]).type))
->length;
1349}

1351/* If TYPE is the type of an array-bounds structure, the type of its
 Ith bound (numbering from 1).  Otherwise, NULL.  */

1354static struct type *
1355desc_index_type (struct type *type, int i)
1356{
type = desc_base_type (type);

if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_STRUCT)
  return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
else
  return NULL((void*)0);
1363}

1365/* The number of index positions in the array-bounds type TYPE.
 Return 0 if TYPE is NULL.  */

1368static int
1369desc_arity (struct type *type)
1370{
type = desc_base_type (type);

if (type != NULL((void*)0))
  return TYPE_NFIELDS (type)(type)->main_type->nfields / 2;
return 0;
1376}

1378/* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
 an array descriptor type (representing an unconstrained array
 type).  */

1382static int
1383ada_is_direct_array_type (struct type *type)
1384{
if (type == NULL((void*)0))
  return 0;
type = ada_check_typedef (type);
return (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_ARRAY
        || ada_is_array_descriptor_type (type));
1390}

1392/* Non-zero iff TYPE is a simple array type or pointer to one.  */

1394int
1395ada_is_simple_array_type (struct type *type)
1396{
if (type == NULL((void*)0))
  return 0;
type = ada_check_typedef (type);
return (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_ARRAY
        || (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_PTR
            && TYPE_CODE (TYPE_TARGET_TYPE (type))((type)->main_type->target_type)->main_type->code == TYPE_CODE_ARRAY));
1403}

1405/* Non-zero iff TYPE belongs to a GNAT array descriptor.  */

1407int
1408ada_is_array_descriptor_type (struct type *type)
1409{
struct type *data_type = desc_data_type (type);

if (type == NULL((void*)0))
  return 0;
type = ada_check_typedef (type);
return
  data_type != NULL((void*)0)
  && ((TYPE_CODE (data_type)(data_type)->main_type->code == TYPE_CODE_PTR
       && TYPE_TARGET_TYPE (data_type)(data_type)->main_type->target_type != NULL((void*)0)
       && TYPE_CODE (TYPE_TARGET_TYPE (data_type))((data_type)->main_type->target_type)->main_type->
code == TYPE_CODE_ARRAY)
      || TYPE_CODE (data_type)(data_type)->main_type->code == TYPE_CODE_ARRAY)
  && desc_arity (desc_bounds_type (type)) > 0;
1422}

1424/* Non-zero iff type is a partially mal-formed GNAT array
 descriptor.  FIXME: This is to compensate for some problems with
 debugging output from GNAT.  Re-examine periodically to see if it
 is still needed.  */

1429int
1430ada_is_bogus_array_descriptor (struct type *type)
1431{
return
  type != NULL((void*)0)
  && TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_STRUCT
  && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL((void*)0)
      || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL((void*)0))
  && !ada_is_array_descriptor_type (type);
1438}


1441/* If ARR has a record type in the form of a standard GNAT array descriptor,
 (fat pointer) returns the type of the array data described---specifically,
 a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
 in from the descriptor; otherwise, they are left unspecified.  If
 the ARR denotes a null array descriptor and BOUNDS is non-zero,
 returns NULL.  The result is simply the type of ARR if ARR is not
 a descriptor.  */
1448struct type *
1449ada_type_of_array (struct value *arr, int bounds)
1450{
if (ada_is_packed_array_type (VALUE_TYPE (arr)(arr)->type))
  return decode_packed_array_type (VALUE_TYPE (arr)(arr)->type);

if (!ada_is_array_descriptor_type (VALUE_TYPE (arr)(arr)->type))
  return VALUE_TYPE (arr)(arr)->type;

if (!bounds)
  return
    ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr)))(desc_data_type ((arr)->type))->main_type->target_type);
else
  {
    struct type *elt_type;
    int arity;
    struct value *descriptor;
    struct objfile *objf = TYPE_OBJFILE (VALUE_TYPE (arr))((arr)->type)->main_type->objfile;

    elt_type = ada_array_element_type (VALUE_TYPE (arr)(arr)->type, -1);
    arity = ada_array_arity (VALUE_TYPE (arr)(arr)->type);

    if (elt_type == NULL((void*)0) || arity == 0)
      return ada_check_typedef (VALUE_TYPE (arr)(arr)->type);

    descriptor = desc_bounds (arr);
    if (value_as_long (descriptor) == 0)
      return NULL((void*)0);
    while (arity > 0)
      {
        struct type *range_type = alloc_type (objf);
        struct type *array_type = alloc_type (objf);
        struct value *low = desc_one_bound (descriptor, arity, 0);
        struct value *high = desc_one_bound (descriptor, arity, 1);
        arity -= 1;

        create_range_type (range_type, VALUE_TYPE (low)(low)->type,
                           (int) value_as_long (low),
                           (int) value_as_long (high));
        elt_type = create_array_type (array_type, elt_type, range_type);
      }

    return lookup_pointer_type (elt_type);
  }
1492}

1494/* If ARR does not represent an array, returns ARR unchanged.
 Otherwise, returns either a standard GDB array with bounds set
 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
 GDB array.  Returns NULL if ARR is a null fat pointer.  */

1499struct value *
1500ada_coerce_to_simple_array_ptr (struct value *arr)
1501{
if (ada_is_array_descriptor_type (VALUE_TYPE (arr)(arr)->type))
  {
    struct type *arrType = ada_type_of_array (arr, 1);
    if (arrType == NULL((void*)0))
      return NULL((void*)0);
    return value_cast (arrType, value_copy (desc_data (arr)));
  }
else if (ada_is_packed_array_type (VALUE_TYPE (arr)(arr)->type))
  return decode_packed_array (arr);
else
  return arr;
1513}

1515/* If ARR does not represent an array, returns ARR unchanged.
 Otherwise, returns a standard GDB array describing ARR (which may
 be ARR itself if it already is in the proper form).  */

1519static struct value *
1520ada_coerce_to_simple_array (struct value *arr)
1521{
if (ada_is_array_descriptor_type (VALUE_TYPE (arr)(arr)->type))
  {
    struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
    if (arrVal == NULL((void*)0))
      error ("Bounds unavailable for null array pointer.");
    return value_ind (arrVal);
  }
else if (ada_is_packed_array_type (VALUE_TYPE (arr)(arr)->type))
  return decode_packed_array (arr);
else
  return arr;
1533}

1535/* If TYPE represents a GNAT array type, return it translated to an
 ordinary GDB array type (possibly with BITSIZE fields indicating
 packing).  For other types, is the identity.  */

1539struct type *
1540ada_coerce_to_simple_array_type (struct type *type)
1541{
struct value *mark = value_mark ();
struct value *dummy = value_from_longest (builtin_type_long, 0);
struct type *result;
VALUE_TYPE (dummy)(dummy)->type = type;
result = ada_type_of_array (dummy, 0);
value_free_to_mark (mark);
return result;
1549}

1551/* Non-zero iff TYPE represents a standard GNAT packed-array type.  */

1553int
1554ada_is_packed_array_type (struct type *type)
1555{
if (type == NULL((void*)0))
  return 0;
type = desc_base_type (type);
type = ada_check_typedef (type);
return
  ada_type_name (type) != NULL((void*)0)
  && strstr (ada_type_name (type), "___XP") != NULL((void*)0);
1563}

1565/* Given that TYPE is a standard GDB array type with all bounds filled
 in, and that the element size of its ultimate scalar constituents
 (that is, either its elements, or, if it is an array of arrays, its
 elements' elements, etc.) is *ELT_BITS, return an identical type,
 but with the bit sizes of its elements (and those of any
 constituent arrays) recorded in the BITSIZE components of its
 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
 in bits.  */

1574static struct type *
1575packed_array_type (struct type *type, long *elt_bits)
1576{
struct type *new_elt_type;
struct type *new_type;
LONGESTlong low_bound, high_bound;

type = ada_check_typedef (type);
if (TYPE_CODE (type)(type)->main_type->code != TYPE_CODE_ARRAY)
  return type;

new_type = alloc_type (TYPE_OBJFILE (type)(type)->main_type->objfile);
new_elt_type = packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)(type)->main_type->target_type),
                                  elt_bits);
create_array_type (new_type, new_elt_type, TYPE_FIELD_TYPE (type, 0)(((type)->main_type->fields[0]).type));
TYPE_FIELD_BITSIZE (new_type, 0)(((new_type)->main_type->fields[0]).bitsize) = *elt_bits;
TYPE_NAME (new_type)(new_type)->main_type->name = ada_type_name (type);

if (get_discrete_bounds (TYPE_FIELD_TYPE (type, 0)(((type)->main_type->fields[0]).type),
                         &low_bound, &high_bound) < 0)
  low_bound = high_bound = 0;
if (high_bound < low_bound)
  *elt_bits = TYPE_LENGTH (new_type)(new_type)->length = 0;
else
  {
    *elt_bits *= (high_bound - low_bound + 1);
    TYPE_LENGTH (new_type)(new_type)->length =
      (*elt_bits + HOST_CHAR_BIT8 - 1) / HOST_CHAR_BIT8;
  }

TYPE_FLAGS (new_type)(new_type)->main_type->flags |= TYPE_FLAG_FIXED_INSTANCE(1 << 15);
return new_type;
1606}

1608/* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE).  */

1610static struct type *
1611decode_packed_array_type (struct type *type)
1612{
struct symbol *sym;
struct block **blocks;
const char *raw_name = ada_type_name (ada_check_typedef (type));
char *name = (char *) alloca (strlen (raw_name) + 1)__builtin_alloca(strlen (raw_name) + 1);
char *tail = strstr (raw_name, "___XP");
struct type *shadow_type;
long bits;
int i, n;

type = desc_base_type (type);

memcpy (name, raw_name, tail - raw_name);
name[tail - raw_name] = '\000';

sym = standard_lookup (name, get_selected_block (0), VAR_DOMAIN);
if (sym == NULL((void*)0) || SYMBOL_TYPE (sym)(sym)->type == NULL((void*)0))
  {
    lim_warning ("could not find bounds information on packed array");
    return NULL((void*)0);
  }
shadow_type = SYMBOL_TYPE (sym)(sym)->type;

if (TYPE_CODE (shadow_type)(shadow_type)->main_type->code != TYPE_CODE_ARRAY)
  {
    lim_warning ("could not understand bounds information on packed array");
    return NULL((void*)0);
  }

if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
  {
    lim_warning
("could not understand bit size information on packed array");
    return NULL((void*)0);
  }

return packed_array_type (shadow_type, &bits);
1649}

1651/* Given that ARR is a struct value *indicating a GNAT packed array,
 returns a simple array that denotes that array.  Its type is a
 standard GDB array type except that the BITSIZEs of the array
 target types are set to the number of bits in each element, and the
 type length is set appropriately.  */

1657static struct value *
1658decode_packed_array (struct value *arr)
1659{
struct type *type;

arr = ada_coerce_ref (arr);
if (TYPE_CODE (VALUE_TYPE (arr))((arr)->type)->main_type->code == TYPE_CODE_PTR)
  arr = ada_value_ind (arr);

type = decode_packed_array_type (VALUE_TYPE (arr)(arr)->type);
if (type == NULL((void*)0))
  {
    error ("can't unpack array");
    return NULL((void*)0);
  }

if (BITS_BIG_ENDIAN((gdbarch_byte_order (current_gdbarch)) == BFD_ENDIAN_BIG) && ada_is_modular_type (VALUE_TYPE (arr)(arr)->type))
  {
     /* This is a (right-justified) modular type representing a packed
 array with no wrapper.  In order to interpret the value through
 the (left-justified) packed array type we just built, we must
 first left-justify it.  */
    int bit_size, bit_pos;
    ULONGESTunsigned long mod;

    mod = ada_modulus (VALUE_TYPE (arr)(arr)->type) - 1;
    bit_size = 0;
    while (mod > 0)
{
 bit_size += 1;
 mod >>= 1;
}
    bit_pos = HOST_CHAR_BIT8 * TYPE_LENGTH (VALUE_TYPE (arr))((arr)->type)->length - bit_size;
    arr = ada_value_primitive_packed_val (arr, NULL((void*)0),
			    bit_pos / HOST_CHAR_BIT8,
			    bit_pos % HOST_CHAR_BIT8,
			    bit_size,
			    type);
  }

return coerce_unspec_val_to_type (arr, type);
1698}


1701/* The value of the element of packed array ARR at the ARITY indices
 given in IND.   ARR must be a simple array.  */

1704static struct value *
1705value_subscript_packed (struct value *arr, int arity, struct value **ind)
1706{
int i;
int bits, elt_off, bit_off;
long elt_total_bit_offset;
struct type *elt_type;
struct value *v;

bits = 0;
elt_total_bit_offset = 0;
elt_type = ada_check_typedef (VALUE_TYPE (arr)(arr)->type);
for (i = 0; i < arity; i += 1)
  {
    if (TYPE_CODE (elt_type)(elt_type)->main_type->code != TYPE_CODE_ARRAY
        || TYPE_FIELD_BITSIZE (elt_type, 0)(((elt_type)->main_type->fields[0]).bitsize) == 0)
      error
        ("attempt to do packed indexing of something other than a packed array");
    else
      {
        struct type *range_type = TYPE_INDEX_TYPE (elt_type)(((elt_type)->main_type->fields[0]).type);
        LONGESTlong lowerbound, upperbound;
        LONGESTlong idx;

        if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
          {
            lim_warning ("don't know bounds of array");
            lowerbound = upperbound = 0;
          }

        idx = value_as_long (value_pos_atr (ind[i]));
        if (idx < lowerbound || idx > upperbound)
          lim_warning ("packed array index %ld out of bounds", (long) idx);
        bits = TYPE_FIELD_BITSIZE (elt_type, 0)(((elt_type)->main_type->fields[0]).bitsize);
        elt_total_bit_offset += (idx - lowerbound) * bits;
        elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type)(elt_type)->main_type->target_type);
      }
  }
elt_off = elt_total_bit_offset / HOST_CHAR_BIT8;
bit_off = elt_total_bit_offset % HOST_CHAR_BIT8;

v = ada_value_primitive_packed_val (arr, NULL((void*)0), elt_off, bit_off,
                                    bits, elt_type);
if (VALUE_LVAL (arr)(arr)->lval == lval_internalvar)
  VALUE_LVAL (v)(v)->lval = lval_internalvar_component;
else
  VALUE_LVAL (v)(v)->lval = VALUE_LVAL (arr)(arr)->lval;
return v;
1752}

1754/* Non-zero iff TYPE includes negative integer values.  */

1756static int
1757has_negatives (struct type *type)
1758{
switch (TYPE_CODE (type)(type)->main_type->code)
  {
  default:
    return 0;
  case TYPE_CODE_INT:
    return !TYPE_UNSIGNED (type)((type)->main_type->flags & (1 << 0));
  case TYPE_CODE_RANGE:
    return TYPE_LOW_BOUND (type)(((type)->main_type->fields[0]).loc.bitpos) < 0;
  }
1768}


1771/* Create a new value of type TYPE from the contents of OBJ starting
 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
 proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
 assigning through the result will set the field fetched from.  
 VALADDR is ignored unless OBJ is NULL, in which case,
 VALADDR+OFFSET must address the start of storage containing the 
 packed value.  The value returned  in this case is never an lval.
 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */

1780struct value *
1781ada_value_primitive_packed_val (struct value *obj, char *valaddr, long offset,
                              int bit_offset, int bit_size,
                              struct type *type)
1784{
struct value *v;
int src,                      /* Index into the source area */
  targ,                       /* Index into the target area */
  srcBitsLeft,                /* Number of source bits left to move */
  nsrc, ntarg,                /* Number of source and target bytes */
  unusedLS,                   /* Number of bits in next significant
                                 byte of source that are unused */
  accumSize;                  /* Number of meaningful bits in accum */
unsigned char *bytes;         /* First byte containing data to unpack */
unsigned char *unpacked;
unsigned long accum;          /* Staging area for bits being transferred */
unsigned char sign;
int len = (bit_size + bit_offset + HOST_CHAR_BIT8 - 1) / 8;
/* Transmit bytes from least to most significant; delta is the direction
   the indices move.  */
int delta = BITS_BIG_ENDIAN((gdbarch_byte_order (current_gdbarch)) == BFD_ENDIAN_BIG) ? -1 : 1;

type = ada_check_typedef (type);

if (obj == NULL((void*)0))
  {
    v = allocate_value (type);
    bytes = (unsigned char *) (valaddr + offset);
  }
else if (VALUE_LAZY (obj)(obj)->lazy)
  {
    v = value_at (type,
                  VALUE_ADDRESS (obj)(obj)->location.address + VALUE_OFFSET (obj)(obj)->offset + offset, NULL((void*)0));
    bytes = (unsigned char *) alloca (len)__builtin_alloca(len);
    read_memory (VALUE_ADDRESS (v)(v)->location.address, bytes, len);
  }
else
  {
    v = allocate_value (type);
    bytes = (unsigned char *) VALUE_CONTENTS (obj)((void)((obj)->lazy && value_fetch_lazy(obj)), ((char
 *) (obj)->aligner.contents + (obj)->embedded_offset)) + offset;
  }

if (obj != NULL((void*)0))
  {
    VALUE_LVAL (v)(v)->lval = VALUE_LVAL (obj)(obj)->lval;
    if (VALUE_LVAL (obj)(obj)->lval == lval_internalvar)
      VALUE_LVAL (v)(v)->lval = lval_internalvar_component;
    VALUE_ADDRESS (v)(v)->location.address = VALUE_ADDRESS (obj)(obj)->location.address + VALUE_OFFSET (obj)(obj)->offset + offset;
    VALUE_BITPOS (v)(v)->bitpos = bit_offset + VALUE_BITPOS (obj)(obj)->bitpos;
    VALUE_BITSIZE (v)(v)->bitsize = bit_size;
    if (VALUE_BITPOS (v)(v)->bitpos >= HOST_CHAR_BIT8)
      {
        VALUE_ADDRESS (v)(v)->location.address += 1;
        VALUE_BITPOS (v)(v)->bitpos -= HOST_CHAR_BIT8;
      }
  }
else
  VALUE_BITSIZE (v)(v)->bitsize = bit_size;
unpacked = (unsigned char *) VALUE_CONTENTS (v)((void)((v)->lazy && value_fetch_lazy(v)), ((char *
) (v)->aligner.contents + (v)->embedded_offset));

srcBitsLeft = bit_size;
nsrc = len;
ntarg = TYPE_LENGTH (type)(type)->length;
sign = 0;
if (bit_size == 0)
  {
    memset (unpacked, 0, TYPE_LENGTH (type)(type)->length);
    return v;
  }
else if (BITS_BIG_ENDIAN((gdbarch_byte_order (current_gdbarch)) == BFD_ENDIAN_BIG))
  {
    src = len - 1;
    if (has_negatives (type)
        && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT8 - 1))))
      sign = ~0;

    unusedLS =
      (HOST_CHAR_BIT8 - (bit_size + bit_offset) % HOST_CHAR_BIT8)
      % HOST_CHAR_BIT8;

    switch (TYPE_CODE (type)(type)->main_type->code)
      {
      case TYPE_CODE_ARRAY:
      case TYPE_CODE_UNION:
      case TYPE_CODE_STRUCT:
        /* Non-scalar values must be aligned at a byte boundary...  */
        accumSize =
          (HOST_CHAR_BIT8 - bit_size % HOST_CHAR_BIT8) % HOST_CHAR_BIT8;
        /* ... And are placed at the beginning (most-significant) bytes
           of the target.  */
        targ = src;
        break;
      default:
        accumSize = 0;
        targ = TYPE_LENGTH (type)(type)->length - 1;
        break;
      }
  }
else
  {
    int sign_bit_offset = (bit_size + bit_offset - 1) % 8;

    src = targ = 0;
    unusedLS = bit_offset;
    accumSize = 0;

    if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
      sign = ~0;
  }

accum = 0;
while (nsrc > 0)
  {
    /* Mask for removing bits of the next source byte that are not
       part of the value.  */
    unsigned int unusedMSMask =
      (1 << (srcBitsLeft >= HOST_CHAR_BIT8 ? HOST_CHAR_BIT8 : srcBitsLeft)) -
      1;
    /* Sign-extend bits for this byte.  */
    unsigned int signMask = sign & ~unusedMSMask;
    accum |=
      (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
    accumSize += HOST_CHAR_BIT8 - unusedLS;
    if (accumSize >= HOST_CHAR_BIT8)
      {
        unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT8);
        accumSize -= HOST_CHAR_BIT8;
        accum >>= HOST_CHAR_BIT8;
        ntarg -= 1;
        targ += delta;
      }
    srcBitsLeft -= HOST_CHAR_BIT8 - unusedLS;
    unusedLS = 0;
    nsrc -= 1;
    src += delta;
  }
while (ntarg > 0)
  {
    accum |= sign << accumSize;
    unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT8);
    accumSize -= HOST_CHAR_BIT8;
    accum >>= HOST_CHAR_BIT8;
    ntarg -= 1;
    targ += delta;
  }

return v;
1927}

1929/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
 TARGET, starting at bit offset TARG_OFFSET.  SOURCE and TARGET must
 not overlap.  */
1932static void
1933move_bits (char *target, int targ_offset, char *source, int src_offset, int n)
1934{
unsigned int accum, mask;
int accum_bits, chunk_size;

target += targ_offset / HOST_CHAR_BIT8;
targ_offset %= HOST_CHAR_BIT8;
source += src_offset / HOST_CHAR_BIT8;
src_offset %= HOST_CHAR_BIT8;
if (BITS_BIG_ENDIAN((gdbarch_byte_order (current_gdbarch)) == BFD_ENDIAN_BIG))
  {
    accum = (unsigned char) *source;
    source += 1;
    accum_bits = HOST_CHAR_BIT8 - src_offset;

    while (n > 0)
      {
        int unused_right;
        accum = (accum << HOST_CHAR_BIT8) + (unsigned char) *source;
        accum_bits += HOST_CHAR_BIT8;
        source += 1;
        chunk_size = HOST_CHAR_BIT8 - targ_offset;
        if (chunk_size > n)
          chunk_size = n;
        unused_right = HOST_CHAR_BIT8 - (chunk_size + targ_offset);
        mask = ((1 << chunk_size) - 1) << unused_right;
        *target =
          (*target & ~mask)
          | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
        n -= chunk_size;
        accum_bits -= chunk_size;
        target += 1;
        targ_offset = 0;
      }
  }
else
  {
    accum = (unsigned char) *source >> src_offset;
    source += 1;
    accum_bits = HOST_CHAR_BIT8 - src_offset;

    while (n > 0)
      {
        accum = accum + ((unsigned char) *source << accum_bits);
        accum_bits += HOST_CHAR_BIT8;
        source += 1;
        chunk_size = HOST_CHAR_BIT8 - targ_offset;
        if (chunk_size > n)
          chunk_size = n;
        mask = ((1 << chunk_size) - 1) << targ_offset;
        *target = (*target & ~mask) | ((accum << targ_offset) & mask);
        n -= chunk_size;
        accum_bits -= chunk_size;
        accum >>= chunk_size;
        target += 1;
        targ_offset = 0;
      }
  }
1991}


1994/* Store the contents of FROMVAL into the location of TOVAL.
 Return a new value with the location of TOVAL and contents of
 FROMVAL.   Handles assignment into packed fields that have
 floating-point or non-scalar types.  */

1999static struct value *
2000ada_value_assign (struct value *toval, struct value *fromval)
2001{
struct type *type = VALUE_TYPE (toval)(toval)->type;
int bits = VALUE_BITSIZE (toval)(toval)->bitsize;

if (!toval->modifiable)
  error ("Left operand of assignment is not a modifiable lvalue.");

COERCE_REF (toval)do { struct type *value_type_arg_tmp = check_typedef ((toval)
->type); if ((value_type_arg_tmp)->main_type->code ==
 TYPE_CODE_REF) toval = value_at_lazy ((value_type_arg_tmp)->
main_type->target_type, unpack_pointer ((toval)->type, (
(void)((toval)->lazy && value_fetch_lazy(toval)), (
(char *) (toval)->aligner.contents + (toval)->embedded_offset
))), ((toval)->bfd_section)); } while (0);

if (VALUE_LVAL (toval)(toval)->lval == lval_memory
    && bits > 0
    && (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_FLT
        || TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_STRUCT))
  {
    int len =
      (VALUE_BITPOS (toval)(toval)->bitpos + bits + HOST_CHAR_BIT8 - 1) / HOST_CHAR_BIT8;
    char *buffer = (char *) alloca (len)__builtin_alloca(len);
    struct value *val;

    if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_FLT)
      fromval = value_cast (type, fromval);

    read_memory (VALUE_ADDRESS (toval)(toval)->location.address + VALUE_OFFSET (toval)(toval)->offset, buffer, len);
    if (BITS_BIG_ENDIAN((gdbarch_byte_order (current_gdbarch)) == BFD_ENDIAN_BIG))
      move_bits (buffer, VALUE_BITPOS (toval)(toval)->bitpos,
                 VALUE_CONTENTS (fromval)((void)((fromval)->lazy && value_fetch_lazy(fromval
)), ((char *) (fromval)->aligner.contents + (fromval)->
embedded_offset)),
                 TYPE_LENGTH (VALUE_TYPE (fromval))((fromval)->type)->length * TARGET_CHAR_BIT8 -
                 bits, bits);
    else
      move_bits (buffer, VALUE_BITPOS (toval)(toval)->bitpos, VALUE_CONTENTS (fromval)((void)((fromval)->lazy && value_fetch_lazy(fromval
)), ((char *) (fromval)->aligner.contents + (fromval)->
embedded_offset)),
                 0, bits);
    write_memory (VALUE_ADDRESS (toval)(toval)->location.address + VALUE_OFFSET (toval)(toval)->offset, buffer,
                  len);

    val = value_copy (toval);
    memcpy (VALUE_CONTENTS_RAW (val)((char *) (val)->aligner.contents + (val)->embedded_offset
), VALUE_CONTENTS (fromval)((void)((fromval)->lazy && value_fetch_lazy(fromval
)), ((char *) (fromval)->aligner.contents + (fromval)->
embedded_offset)),
            TYPE_LENGTH (type)(type)->length);
    VALUE_TYPE (val)(val)->type = type;

    return val;
  }

return value_assign (toval, fromval);
2044}


2047/* The value of the element of array ARR at the ARITY indices given in IND.
 ARR may be either a simple array, GNAT array descriptor, or pointer
 thereto.  */

2051struct value *
2052ada_value_subscript (struct value *arr, int arity, struct value **ind)
2053{
int k;
struct value *elt;
struct type *elt_type;

elt = ada_coerce_to_simple_array (arr);

elt_type = ada_check_typedef (VALUE_TYPE (elt)(elt)->type);
if (TYPE_CODE (elt_type)(elt_type)->main_type->code == TYPE_CODE_ARRAY
    && TYPE_FIELD_BITSIZE (elt_type, 0)(((elt_type)->main_type->fields[0]).bitsize) > 0)
  return value_subscript_packed (elt, arity, ind);

for (k = 0; k < arity; k += 1)
  {
    if (TYPE_CODE (elt_type)(elt_type)->main_type->code != TYPE_CODE_ARRAY)
      error ("too many subscripts (%d expected)", k);
    elt = value_subscript (elt, value_pos_atr (ind[k]));
  }
return elt;
2072}

2074/* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
 value of the element of *ARR at the ARITY indices given in
 IND.  Does not read the entire array into memory.  */

2078struct value *
2079ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
                       struct value **ind)
2081{
int k;

for (k = 0; k < arity; k += 1)
  {
    LONGESTlong lwb, upb;
    struct value *idx;

    if (TYPE_CODE (type)(type)->main_type->code != TYPE_CODE_ARRAY)
      error ("too many subscripts (%d expected)", k);
    arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)(type)->main_type->target_type),
                      value_copy (arr));
    get_discrete_bounds (TYPE_INDEX_TYPE (type)(((type)->main_type->fields[0]).type), &lwb, &upb);
    idx = value_pos_atr (ind[k]);
    if (lwb != 0)
      idx = value_sub (idx, value_from_longest (builtin_type_int, lwb));
    arr = value_add (arr, idx);
    type = TYPE_TARGET_TYPE (type)(type)->main_type->target_type;
  }

return value_ind (arr);
2102}

2104/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
 actual type of ARRAY_PTR is ignored), returns a reference to
 the Ada slice of HIGH-LOW+1 elements starting at index LOW.  The lower
 bound of this array is LOW, as per Ada rules. */
2108static struct value *
2109ada_value_slice_ptr (struct value *array_ptr, struct type *type,
                   int low, int high)
2111{
CORE_ADDR base = value_as_address (array_ptr)
  + ((low - TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type))((((((type)->main_type->fields[0]).type))->main_type
->fields[0]).loc.bitpos))
     * TYPE_LENGTH (TYPE_TARGET_TYPE (type))((type)->main_type->target_type)->length);
struct type *index_type =
  create_range_type (NULL((void*)0), TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type))((((type)->main_type->fields[0]).type))->main_type->
target_type,
                     low, high);
struct type *slice_type =
  create_array_type (NULL((void*)0), TYPE_TARGET_TYPE (type)(type)->main_type->target_type, index_type);
return value_from_pointer (lookup_reference_type (slice_type), base);
2121}


2124static struct value *
2125ada_value_slice (struct value *array, int low, int high)
2126{
struct type *type = VALUE_TYPE (array)(array)->type;
struct type *index_type =
  create_range_type (NULL((void*)0), TYPE_INDEX_TYPE (type)(((type)->main_type->fields[0]).type), low, high);
struct type *slice_type =
  create_array_type (NULL((void*)0), TYPE_TARGET_TYPE (type)(type)->main_type->target_type, index_type);
return value_cast (slice_type, value_slice (array, low, high - low + 1));
2133}

2135/* If type is a record type in the form of a standard GNAT array
 descriptor, returns the number of dimensions for type.  If arr is a
 simple array, returns the number of "array of"s that prefix its
 type designation.  Otherwise, returns 0.  */

2140int
2141ada_array_arity (struct type *type)
2142{
int arity;

if (type == NULL((void*)0))
  return 0;

type = desc_base_type (type);

arity = 0;
if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_STRUCT)
  return desc_arity (desc_bounds_type (type));
else
  while (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_ARRAY)
    {
      arity += 1;
      type = ada_check_typedef (TYPE_TARGET_TYPE (type)(type)->main_type->target_type);
    }

return arity;
2161}

2163/* If TYPE is a record type in the form of a standard GNAT array
 descriptor or a simple array type, returns the element type for
 TYPE after indexing by NINDICES indices, or by all indices if
 NINDICES is -1.  Otherwise, returns NULL.  */

2168struct type *
2169ada_array_element_type (struct type *type, int nindices)
2170{
type = desc_base_type (type);

if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_STRUCT)
  {
    int k;
    struct type *p_array_type;

    p_array_type = desc_data_type (type);

    k = ada_array_arity (type);
    if (k == 0)
      return NULL((void*)0);

    /* Initially p_array_type = elt_type(*)[]...(k times)...[].  */
    if (nindices >= 0 && k > nindices)
      k = nindices;
    p_array_type = TYPE_TARGET_TYPE (p_array_type)(p_array_type)->main_type->target_type;
    while (k > 0 && p_array_type != NULL((void*)0))
      {
        p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type)(p_array_type)->main_type->target_type);
        k -= 1;
      }
    return p_array_type;
  }
else if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_ARRAY)
  {
    while (nindices != 0 && TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_ARRAY)
      {
        type = TYPE_TARGET_TYPE (type)(type)->main_type->target_type;
        nindices -= 1;
      }
    return type;
  }

return NULL((void*)0);
2206}

2208/* The type of nth index in arrays of given type (n numbering from 1).
 Does not examine memory.  */

2211struct type *
2212ada_index_type (struct type *type, int n)
2213{
struct type *result_type;

type = desc_base_type (type);

if (n > ada_array_arity (type))
  return NULL((void*)0);

if (ada_is_simple_array_type (type))
  {
    int i;

    for (i = 1; i < n; i += 1)
      type = TYPE_TARGET_TYPE (type)(type)->main_type->target_type;
    result_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 0))((((type)->main_type->fields[0]).type))->main_type->
target_type;
    /* FIXME: The stabs type r(0,0);bound;bound in an array type
       has a target type of TYPE_CODE_UNDEF.  We compensate here, but
       perhaps stabsread.c would make more sense.  */
    if (result_type == NULL((void*)0) || TYPE_CODE (result_type)(result_type)->main_type->code == TYPE_CODE_UNDEF)
      result_type = builtin_type_int;

    return result_type;
  }
else
  return desc_index_type (desc_bounds_type (type), n);
2238}

2240/* Given that arr is an array type, returns the lower bound of the
 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
 WHICH is 1.  This returns bounds 0 .. -1 if ARR_TYPE is an
 array-descriptor type.  If TYPEP is non-null, *TYPEP is set to the
 bounds type.  It works for other arrays with bounds supplied by
 run-time quantities other than discriminants.  */

2247LONGESTlong
2248ada_array_bound_from_type (struct type * arr_type, int n, int which,
                         struct type ** typep)
2250{
struct type *type;
struct type *index_type_desc;

if (ada_is_packed_array_type (arr_type))
  arr_type = decode_packed_array_type (arr_type);

if (arr_type == NULL((void*)0) || !ada_is_simple_array_type (arr_type))
  {
    if (typep != NULL((void*)0))
      *typep = builtin_type_int;
    return (LONGESTlong) - which;
  }

if (TYPE_CODE (arr_type)(arr_type)->main_type->code == TYPE_CODE_PTR)
  type = TYPE_TARGET_TYPE (arr_type)(arr_type)->main_type->target_type;
else
  type = arr_type;

index_type_desc = ada_find_parallel_type (type, "___XA");
if (index_type_desc == NULL((void*)0))
  {
    struct type *range_type;
    struct type *index_type;

    while (n > 1)
      {
        type = TYPE_TARGET_TYPE (type)(type)->main_type->target_type;
        n -= 1;
      }

    range_type = TYPE_INDEX_TYPE (type)(((type)->main_type->fields[0]).type);
    index_type = TYPE_TARGET_TYPE (range_type)(range_type)->main_type->target_type;
    if (TYPE_CODE (index_type)(index_type)->main_type->code == TYPE_CODE_UNDEF)
      index_type = builtin_type_long;
    if (typep != NULL((void*)0))
      *typep = index_type;
    return
      (LONGESTlong) (which == 0
                 ? TYPE_LOW_BOUND (range_type)(((range_type)->main_type->fields[0]).loc.bitpos)
                 : TYPE_HIGH_BOUND (range_type)(((range_type)->main_type->fields[1]).loc.bitpos));
  }
else
  {
    struct type *index_type =
      to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, n - 1)(((index_type_desc)->main_type->fields[n - 1]).name),
                           NULL((void*)0), TYPE_OBJFILE (arr_type)(arr_type)->main_type->objfile);
    if (typep != NULL((void*)0))
      *typep = TYPE_TARGET_TYPE (index_type)(index_type)->main_type->target_type;
    return
      (LONGESTlong) (which == 0
                 ? TYPE_LOW_BOUND (index_type)(((index_type)->main_type->fields[0]).loc.bitpos)
                 : TYPE_HIGH_BOUND (index_type)(((index_type)->main_type->fields[1]).loc.bitpos));
  }
2304}

2306/* Given that arr is an array value, returns the lower bound of the
 nth index (numbering from 1) if which is 0, and the upper bound if
 which is 1.  This routine will also work for arrays with bounds
 supplied by run-time quantities other than discriminants.  */

2311struct value *
2312ada_array_bound (struct value *arr, int n, int which)
2313{
struct type *arr_type = VALUE_TYPE (arr)(arr)->type;

if (ada_is_packed_array_type (arr_type))
  return ada_array_bound (decode_packed_array (arr), n, which);
else if (ada_is_simple_array_type (arr_type))
  {
    struct type *type;
    LONGESTlong v = ada_array_bound_from_type (arr_type, n, which, &type);
    return value_from_longest (type, v);
  }
else
  return desc_one_bound (desc_bounds (arr), n, which);
2326}

2328/* Given that arr is an array value, returns the length of the
 nth index.  This routine will also work for arrays with bounds
 supplied by run-time quantities other than discriminants.
 Does not work for arrays indexed by enumeration types with representation
 clauses at the moment.  */

2334struct value *
2335ada_array_length (struct value *arr, int n)
2336{
struct type *arr_type = ada_check_typedef (VALUE_TYPE (arr)(arr)->type);

if (ada_is_packed_array_type (arr_type))
  return ada_array_length (decode_packed_array (arr), n);

if (ada_is_simple_array_type (arr_type))
  {
    struct type *type;
    LONGESTlong v =
      ada_array_bound_from_type (arr_type, n, 1, &type) -
      ada_array_bound_from_type (arr_type, n, 0, NULL((void*)0)) + 1;
    return value_from_longest (type, v);
  }
else
  return
    value_from_longest (builtin_type_int,
                        value_as_long (desc_one_bound (desc_bounds (arr),
                                                       n, 1))
                        - value_as_long (desc_one_bound (desc_bounds (arr),
                                                         n, 0)) + 1);
2357}

2359/* An empty array whose type is that of ARR_TYPE (an array type),
 with bounds LOW to LOW-1.  */

2362static struct value *
2363empty_array (struct type *arr_type, int low)
2364{
struct type *index_type =
  create_range_type (NULL((void*)0), TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type))((((arr_type)->main_type->fields[0]).type))->main_type
->target_type,
                     low, low - 1);
struct type *elt_type = ada_array_element_type (arr_type, 1);
return allocate_value (create_array_type (NULL((void*)0), elt_type, index_type));
2370}
2371

                              /* Name resolution */

2375/* The "decoded" name for the user-definable Ada operator corresponding
 to OP.  */

2378static const char *
2379ada_decoded_op_name (enum exp_opcode op)
2380{
int i;

for (i = 0; ada_opname_table[i].encoded != NULL((void*)0); i += 1)
  {
    if (ada_opname_table[i].op == op)
      return ada_opname_table[i].decoded;
  }
error ("Could not find operator name for opcode");
2389}


2392/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
 references (marked by OP_VAR_VALUE nodes in which the symbol has an
 undefined namespace) and converts operators that are
 user-defined into appropriate function calls.  If CONTEXT_TYPE is
 non-null, it provides a preferred result type [at the moment, only
 type void has any effect---causing procedures to be preferred over
 functions in calls].  A null CONTEXT_TYPE indicates that a non-void
 return type is preferred.  May change (expand) *EXP.  */

2401static void
2402resolve (struct expression **expp, int void_context_p)
2403{
int pc;
pc = 0;
resolve_subexp (expp, &pc, 1, void_context_p ? builtin_type_void : NULL((void*)0));
2407}

2409/* Resolve the operator of the subexpression beginning at
 position *POS of *EXPP.  "Resolving" consists of replacing
 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
 with their resolutions, replacing built-in operators with
 function calls to user-defined operators, where appropriate, and,
 when DEPROCEDURE_P is non-zero, converting function-valued variables
 into parameterless calls.  May expand *EXPP.  The CONTEXT_TYPE functions
 are as in ada_resolve, above.  */

2418static struct value *
2419resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
              struct type *context_type)
2421{
int pc = *pos;
int i;
struct expression *exp;       /* Convenience: == *expp.  */
enum exp_opcode op = (*expp)->elts[pc].opcode;
struct value **argvec;        /* Vector of operand types (alloca'ed).  */
int nargs;                    /* Number of operands.  */

argvec = NULL((void*)0);
nargs = 0;
exp = *expp;

/* Pass one: resolve operands, saving their types and updating *pos.  */
switch (op)
  {
  case OP_FUNCALL:
    if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
        && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol)(exp->elts[pc + 5].symbol)->domain == UNDEF_DOMAIN)
      *pos += 7;
    else
      {
        *pos += 3;
        resolve_subexp (expp, pos, 0, NULL((void*)0));
      }
    nargs = longest_to_int (exp->elts[pc + 1].longconst);
    break;

  case UNOP_QUAL:
    *pos += 3;
    resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
    break;

  case UNOP_ADDR:
    *pos += 1;
    resolve_subexp (expp, pos, 0, NULL((void*)0));
    break;

  case OP_ATR_MODULUS:
    *pos += 4;
    break;

  case OP_ATR_SIZE:
  case OP_ATR_TAG:
    *pos += 1;
    nargs = 1;
    break;

  case OP_ATR_FIRST:
  case OP_ATR_LAST:
  case OP_ATR_LENGTH:
  case OP_ATR_POS:
  case OP_ATR_VAL:
    *pos += 1;
    nargs = 2;
    break;

  case OP_ATR_MIN:
  case OP_ATR_MAX:
    *pos += 1;
    nargs = 3;
    break;

  case BINOP_ASSIGN:
    {
      struct value *arg1;

      *pos += 1;
      arg1 = resolve_subexp (expp, pos, 0, NULL((void*)0));
      if (arg1 == NULL((void*)0))
        resolve_subexp (expp, pos, 1, NULL((void*)0));
      else
        resolve_subexp (expp, pos, 1, VALUE_TYPE (arg1)(arg1)->type);
      break;
    }

  case UNOP_CAST:
  case UNOP_IN_RANGE:
    *pos += 3;
    nargs = 1;
    break;

  case BINOP_ADD:
  case BINOP_SUB:
  case BINOP_MUL:
  case BINOP_DIV:
  case BINOP_REM:
  case BINOP_MOD:
  case BINOP_EXP:
  case BINOP_CONCAT:
  case BINOP_LOGICAL_AND:
  case BINOP_LOGICAL_OR:
  case BINOP_BITWISE_AND:
  case BINOP_BITWISE_IOR:
  case BINOP_BITWISE_XOR:

  case BINOP_EQUAL:
  case BINOP_NOTEQUAL:
  case BINOP_LESS:
  case BINOP_GTR:
  case BINOP_LEQ:
  case BINOP_GEQ:

  case BINOP_REPEAT:
  case BINOP_SUBSCRIPT:
  case BINOP_COMMA:
    *pos += 1;
    nargs = 2;
    break;

  case UNOP_NEG:
  case UNOP_PLUS:
  case UNOP_LOGICAL_NOT:
  case UNOP_ABS:
  case UNOP_IND:
    *pos += 1;
    nargs = 1;
    break;

  case OP_LONG:
  case OP_DOUBLE:
  case OP_VAR_VALUE:
    *pos += 4;
    break;

  case OP_TYPE:
  case OP_BOOL:
  case OP_LAST:
  case OP_REGISTER:
  case OP_INTERNALVAR:
    *pos += 3;
    break;

  case UNOP_MEMVAL:
    *pos += 3;
    nargs = 1;
    break;

  case STRUCTOP_STRUCT:
    *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1)(((exp->elts[pc + 1].longconst + 1) + sizeof (union exp_element
) - 1) / sizeof (union exp_element));
    nargs = 1;
    break;

  case OP_STRING:
    (*pos) += 3 
      + BYTES_TO_EXP_ELEM (longest_to_int (exp->elts[pc + 1].longconst)(((longest_to_int (exp->elts[pc + 1].longconst) + 1) + sizeof
 (union exp_element) - 1) / sizeof (union exp_element)) 
                           + 1)(((longest_to_int (exp->elts[pc + 1].longconst) + 1) + sizeof
 (union exp_element) - 1) / sizeof (union exp_element));
    break;

  case TERNOP_SLICE:
  case TERNOP_IN_RANGE:
    *pos += 1;
    nargs = 3;
    break;

  case BINOP_IN_BOUNDS:
    *pos += 3;
    nargs = 2;
    break;

  default:
    error ("Unexpected operator during name resolution");
  }

argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1))__builtin_alloca(sizeof (struct value *) * (nargs + 1));
for (i = 0; i < nargs; i += 1)
  argvec[i] = resolve_subexp (expp, pos, 1, NULL((void*)0));
argvec[i] = NULL((void*)0);
exp = *expp;

/* Pass two: perform any resolution on principal operator.  */
switch (op)
  {
  default:
    break;

  case OP_VAR_VALUE:
    if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol)(exp->elts[pc + 2].symbol)->domain == UNDEF_DOMAIN)
      {
        struct ada_symbol_info *candidates;
        int n_candidates;

        n_candidates =
          ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME(exp->elts[pc + 2].symbol)->ginfo.name
                                  (exp->elts[pc + 2].symbol)(exp->elts[pc + 2].symbol)->ginfo.name,
                                  exp->elts[pc + 1].block, VAR_DOMAIN,
                                  &candidates);

        if (n_candidates > 1)
          {
            /* Types tend to get re-introduced locally, so if there
               are any local symbols that are not types, first filter
               out all types.  */
            int j;
            for (j = 0; j < n_candidates; j += 1)
              switch (SYMBOL_CLASS (candidates[j].sym)(candidates[j].sym)->aclass)
                {
                case LOC_REGISTER:
                case LOC_ARG:
                case LOC_REF_ARG:
                case LOC_REGPARM:
                case LOC_REGPARM_ADDR:
                case LOC_LOCAL:
                case LOC_LOCAL_ARG:
                case LOC_BASEREG:
                case LOC_BASEREG_ARG:
                case LOC_COMPUTED:
                case LOC_COMPUTED_ARG:
                  goto FoundNonType;
                default:
                  break;
                }
          FoundNonType:
            if (j < n_candidates)
              {
                j = 0;
                while (j < n_candidates)
                  {
                    if (SYMBOL_CLASS (candidates[j].sym)(candidates[j].sym)->aclass == LOC_TYPEDEF)
                      {
                        candidates[j] = candidates[n_candidates - 1];
                        n_candidates -= 1;
                      }
                    else
                      j += 1;
                  }
              }
          }

        if (n_candidates == 0)
          error ("No definition found for %s",
                 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)(demangle ? (symbol_natural_name (&(exp->elts[pc + 2].
symbol)->ginfo)) : (exp->elts[pc + 2].symbol)->ginfo
.name));
        else if (n_candidates == 1)
          i = 0;
        else if (deprocedure_p
                 && !is_nonfunction (candidates, n_candidates))
          {
            i = ada_resolve_function
              (candidates, n_candidates, NULL((void*)0), 0,
               SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol)(exp->elts[pc + 2].symbol)->ginfo.name,
               context_type);
            if (i < 0)
              error ("Could not find a match for %s",
                     SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)(demangle ? (symbol_natural_name (&(exp->elts[pc + 2].
symbol)->ginfo)) : (exp->elts[pc + 2].symbol)->ginfo
.name));
          }
        else
          {
            printf_filtered ("Multiple matches for %s\n",
                             SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)(demangle ? (symbol_natural_name (&(exp->elts[pc + 2].
symbol)->ginfo)) : (exp->elts[pc + 2].symbol)->ginfo
.name));
            user_select_syms (candidates, n_candidates, 1);
            i = 0;
          }

        exp->elts[pc + 1].block = candidates[i].block;
        exp->elts[pc + 2].symbol = candidates[i].sym;
        if (innermost_block == NULL((void*)0)
            || contained_in (candidates[i].block, innermost_block))
          innermost_block = candidates[i].block;
      }

    if (deprocedure_p
        && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))((exp->elts[pc + 2].symbol)->type)->main_type->code
            == TYPE_CODE_FUNC))
      {
        replace_operator_with_call (expp, pc, 0, 0,
                                    exp->elts[pc + 2].symbol,
                                    exp->elts[pc + 1].block);
        exp = *expp;
      }
    break;

  case OP_FUNCALL:
    {
      if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
          && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol)(exp->elts[pc + 5].symbol)->domain == UNDEF_DOMAIN)
        {
          struct ada_symbol_info *candidates;
          int n_candidates;

          n_candidates =
            ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME(exp->elts[pc + 5].symbol)->ginfo.name
                                    (exp->elts[pc + 5].symbol)(exp->elts[pc + 5].symbol)->ginfo.name,
                                    exp->elts[pc + 4].block, VAR_DOMAIN,
                                    &candidates);
          if (n_candidates == 1)
            i = 0;
          else
            {
              i = ada_resolve_function
                (candidates, n_candidates,
                 argvec, nargs,
                 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol)(exp->elts[pc + 5].symbol)->ginfo.name,
                 context_type);
              if (i < 0)
                error ("Could not find a match for %s",
                       SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol)(demangle ? (symbol_natural_name (&(exp->elts[pc + 5].
symbol)->ginfo)) : (exp->elts[pc + 5].symbol)->ginfo
.name));
            }

          exp->elts[pc + 4].block = candidates[i].block;
          exp->elts[pc + 5].symbol = candidates[i].sym;
          if (innermost_block == NULL((void*)0)
              || contained_in (candidates[i].block, innermost_block))
            innermost_block = candidates[i].block;
        }
    }
    break;
  case BINOP_ADD:
  case BINOP_SUB:
  case BINOP_MUL:
  case BINOP_DIV:
  case BINOP_REM:
  case BINOP_MOD:
  case BINOP_CONCAT:
  case BINOP_BITWISE_AND:
  case BINOP_BITWISE_IOR:
  case BINOP_BITWISE_XOR:
  case BINOP_EQUAL:
  case BINOP_NOTEQUAL:
  case BINOP_LESS:
  case BINOP_GTR:
  case BINOP_LEQ:
  case BINOP_GEQ:
  case BINOP_EXP:
  case UNOP_NEG:
  case UNOP_PLUS:
  case UNOP_LOGICAL_NOT:
  case UNOP_ABS:
    if (possible_user_operator_p (op, argvec))
      {
        struct ada_symbol_info *candidates;
        int n_candidates;

        n_candidates =
          ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
                                  (struct block *) NULL((void*)0), VAR_DOMAIN,
                                  &candidates);
        i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
                                  ada_decoded_op_name (op), NULL((void*)0));
        if (i < 0)
          break;

        replace_operator_with_call (expp, pc, nargs, 1,
                                    candidates[i].sym, candidates[i].block);
        exp = *expp;
      }
    break;

  case OP_TYPE:
    return NULL((void*)0);
  }

*pos = pc;
return evaluate_subexp_type (exp, pos);
2773}

2775/* Return non-zero if formal type FTYPE matches actual type ATYPE.  If
 MAY_DEREF is non-zero, the formal may be a pointer and the actual
 a non-pointer.   A type of 'void' (which is never a valid expression type)
 by convention matches anything. */
2779/* The term "match" here is rather loose.  The match is heuristic and
 liberal.  FIXME: TOO liberal, in fact.  */

2782static int
2783ada_type_match (struct type *ftype, struct type *atype, int may_deref)
2784{
ftype = ada_check_typedef (ftype);
atype = ada_check_typedef (atype);

if (TYPE_CODE (ftype)(ftype)->main_type->code == TYPE_CODE_REF)
  ftype = TYPE_TARGET_TYPE (ftype)(ftype)->main_type->target_type;
if (TYPE_CODE (atype)(atype)->main_type->code == TYPE_CODE_REF)
  atype = TYPE_TARGET_TYPE (atype)(atype)->main_type->target_type;

if (TYPE_CODE (ftype)(ftype)->main_type->code == TYPE_CODE_VOID
    || TYPE_CODE (atype)(atype)->main_type->code == TYPE_CODE_VOID)
  return 1;

switch (TYPE_CODE (ftype)(ftype)->main_type->code)
  {
  default:
    return 1;
  case TYPE_CODE_PTR:
    if (TYPE_CODE (atype)(atype)->main_type->code == TYPE_CODE_PTR)
      return ada_type_match (TYPE_TARGET_TYPE (ftype)(ftype)->main_type->target_type,
                             TYPE_TARGET_TYPE (atype)(atype)->main_type->target_type, 0);
    else
      return (may_deref
              && ada_type_match (TYPE_TARGET_TYPE (ftype)(ftype)->main_type->target_type, atype, 0));
  case TYPE_CODE_INT:
  case TYPE_CODE_ENUM:
  case TYPE_CODE_RANGE:
    switch (TYPE_CODE (atype)(atype)->main_type->code)
      {
      case TYPE_CODE_INT:
      case TYPE_CODE_ENUM:
      case TYPE_CODE_RANGE:
        return 1;
      default:
        return 0;
      }

  case TYPE_CODE_ARRAY:
    return (TYPE_CODE (atype)(atype)->main_type->code == TYPE_CODE_ARRAY
            || ada_is_array_descriptor_type (atype));

  case TYPE_CODE_STRUCT:
    if (ada_is_array_descriptor_type (ftype))
      return (TYPE_CODE (atype)(atype)->main_type->code == TYPE_CODE_ARRAY
              || ada_is_array_descriptor_type (atype));
    else
      return (TYPE_CODE (atype)(atype)->main_type->code == TYPE_CODE_STRUCT
              && !ada_is_array_descriptor_type (atype));

  case TYPE_CODE_UNION:
  case TYPE_CODE_FLT:
    return (TYPE_CODE (atype)(atype)->main_type->code == TYPE_CODE (ftype)(ftype)->main_type->code);
  }
2837}

2839/* Return non-zero if the formals of FUNC "sufficiently match" the
 vector of actual argument types ACTUALS of size N_ACTUALS.  FUNC
 may also be an enumeral, in which case it is treated as a 0-
 argument function.  */

2844static int
2845ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
2846{
int i;
struct type *func_type = SYMBOL_TYPE (func)(func)->type;

if (SYMBOL_CLASS (func)(func)->aclass == LOC_CONST
    && TYPE_CODE (func_type)(func_type)->main_type->code == TYPE_CODE_ENUM)
  return (n_actuals == 0);
else if (func_type == NULL((void*)0) || TYPE_CODE (func_type)(func_type)->main_type->code != TYPE_CODE_FUNC)
  return 0;

if (TYPE_NFIELDS (func_type)(func_type)->main_type->nfields != n_actuals)
  return 0;

for (i = 0; i < n_actuals; i += 1)
  {
    if (actuals[i] == NULL((void*)0))
      return 0;
    else
      {
        struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type, i)(((func_type)->main_type->fields[i]).type));
        struct type *atype = ada_check_typedef (VALUE_TYPE (actuals[i])(actuals[i])->type);

        if (!ada_type_match (ftype, atype, 1))
          return 0;
      }
  }
return 1;
2873}

2875/* False iff function type FUNC_TYPE definitely does not produce a value
 compatible with type CONTEXT_TYPE.  Conservatively returns 1 if
 FUNC_TYPE is not a valid function type with a non-null return type
 or an enumerated type.  A null CONTEXT_TYPE indicates any non-void type.  */

2880static int
2881return_match (struct type *func_type, struct type *context_type)
2882{
struct type *return_type;

if (func_type == NULL((void*)0))
  return 1;

if (TYPE_CODE (func_type)(func_type)->main_type->code == TYPE_CODE_FUNC)
  return_type = base_type (TYPE_TARGET_TYPE (func_type)(func_type)->main_type->target_type);
else
  return_type = base_type (func_type);
if (return_type == NULL((void*)0))
  return 1;

context_type = base_type (context_type);

if (TYPE_CODE (return_type)(return_type)->main_type->code == TYPE_CODE_ENUM)
  return context_type == NULL((void*)0) || return_type == context_type;
else if (context_type == NULL((void*)0))
  return TYPE_CODE (return_type)(return_type)->main_type->code != TYPE_CODE_VOID;
else
  return TYPE_CODE (return_type)(return_type)->main_type->code == TYPE_CODE (context_type)(context_type)->main_type->code;
2903}


2906/* Returns the index in SYMS[0..NSYMS-1] that contains  the symbol for the
 function (if any) that matches the types of the NARGS arguments in
 ARGS.  If CONTEXT_TYPE is non-null and there is at least one match
 that returns that type, then eliminate matches that don't.  If
 CONTEXT_TYPE is void and there is at least one match that does not
 return void, eliminate all matches that do.

 Asks the user if there is more than one match remaining.  Returns -1
 if there is no such symbol or none is selected.  NAME is used
 solely for messages.  May re-arrange and modify SYMS in
 the process; the index returned is for the modified vector.  */

2918static int
2919ada_resolve_function (struct ada_symbol_info syms[],
                    int nsyms, struct value **args, int nargs,
                    const char *name, struct type *context_type)
2922{
int k;
int m;                        /* Number of hits */
struct type *fallback;
struct type *return_type;

return_type = context_type;
if (context_type == NULL((void*)0))
  fallback = builtin_type_void;
else
  fallback = NULL((void*)0);

m = 0;
while (1)
  {
    for (k = 0; k < nsyms; k += 1)
      {
        struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym)(syms[k].sym)->type);

        if (ada_args_match (syms[k].sym, args, nargs)
            && return_match (type, return_type))
          {
            syms[m] = syms[k];
            m += 1;
          }
      }
    if (m > 0 || return_type == fallback)
      break;
    else
      return_type = fallback;
  }

if (m == 0)
  return -1;
else if (m > 1)
  {
    printf_filtered ("Multiple matches for %s\n", name);
    user_select_syms (syms, m, 1);
    return 0;
  }
return 0;
2963}

2965/* Returns true (non-zero) iff decoded name N0 should appear before N1
 in a listing of choices during disambiguation (see sort_choices, below).
 The idea is that overloadings of a subprogram name from the
 same package should sort in their source order.  We settle for ordering
 such symbols by their trailing number (__N  or $N).  */

2971static int
2972encoded_ordered_before (char *N0, char *N1)
2973{
if (N1 == NULL((void*)0))
  return 0;
else if (N0 == NULL((void*)0))
  return 1;
else
  {
    int k0, k1;
    for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
      ;
    for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
      ;
    if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
        && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
      {
        int n0, n1;
        n0 = k0;
        while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
          n0 -= 1;
        n1 = k1;
        while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
          n1 -= 1;
        if (n0 == n1 && strncmp (N0, N1, n0) == 0)
          return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
      }
    return (strcmp (N0, N1) < 0);
  }
3000}

3002/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
 encoded names.  */

3005static void
3006sort_choices (struct ada_symbol_info syms[], int nsyms)
3007{
int i;
for (i = 1; i < nsyms; i += 1)
  {
    struct ada_symbol_info sym = syms[i];
    int j;

    for (j = i - 1; j >= 0; j -= 1)
      {
        if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym)(syms[j].sym)->ginfo.name,
                                    SYMBOL_LINKAGE_NAME (sym.sym)(sym.sym)->ginfo.name))
          break;
        syms[j + 1] = syms[j];
      }
    syms[j + 1] = sym;
  }
3023}

3025/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0 
 by asking the user (if necessary), returning the number selected, 
 and setting the first elements of SYMS items.  Error if no symbols
 selected.  */

3030/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
 to be re-integrated one of these days.  */

3033int
3034user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
3035{
int i;
int *chosen = (int *) alloca (sizeof (int) * nsyms)__builtin_alloca(sizeof (int) * nsyms);
int n_chosen;
int first_choice = (max_results == 1) ? 1 : 2;

if (max_results < 1)
  error ("Request to select 0 symbols!");
if (nsyms <= 1)
  return nsyms;

printf_unfiltered ("[0] cancel\n");
if (max_results > 1)
  printf_unfiltered ("[1] all\n");

sort_choices (syms, nsyms);

for (i = 0; i < nsyms; i += 1)
  {
    if (syms[i].sym == NULL((void*)0))
      continue;

    if (SYMBOL_CLASS (syms[i].sym)(syms[i].sym)->aclass == LOC_BLOCK)
      {
        struct symtab_and_line sal =
          find_function_start_sal (syms[i].sym, 1);
        printf_unfiltered ("[%d] %s at %s:%d\n", i + first_choice,
                           SYMBOL_PRINT_NAME (syms[i].sym)(demangle ? (symbol_natural_name (&(syms[i].sym)->ginfo
)) : (syms[i].sym)->ginfo.name),
                           (sal.symtab == NULL((void*)0)
                            ? "<no source file available>"
                            : sal.symtab->filename), sal.line);
        continue;
      }
    else
      {
        int is_enumeral =
          (SYMBOL_CLASS (syms[i].sym)(syms[i].sym)->aclass == LOC_CONST
           && SYMBOL_TYPE (syms[i].sym)(syms[i].sym)->type != NULL((void*)0)
           && TYPE_CODE (SYMBOL_TYPE (syms[i].sym))((syms[i].sym)->type)->main_type->code == TYPE_CODE_ENUM);
        struct symtab *symtab = symtab_for_sym (syms[i].sym);

        if (SYMBOL_LINE (syms[i].sym)(syms[i].sym)->line != 0 && symtab != NULL((void*)0))
          printf_unfiltered ("[%d] %s at %s:%d\n",
                             i + first_choice,
                             SYMBOL_PRINT_NAME (syms[i].sym)(demangle ? (symbol_natural_name (&(syms[i].sym)->ginfo
)) : (syms[i].sym)->ginfo.name),
                             symtab->filename, SYMBOL_LINE (syms[i].sym)(syms[i].sym)->line);
        else if (is_enumeral
                 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym))((syms[i].sym)->type)->main_type->name != NULL((void*)0))
          {
            printf_unfiltered ("[%d] ", i + first_choice);
            ada_print_type (SYMBOL_TYPE (syms[i].sym)(syms[i].sym)->type, NULL((void*)0),
                            gdb_stdout, -1, 0);
            printf_unfiltered ("'(%s) (enumeral)\n",
                               SYMBOL_PRINT_NAME (syms[i].sym)(demangle ? (symbol_natural_name (&(syms[i].sym)->ginfo
)) : (syms[i].sym)->ginfo.name));
          }
        else if (symtab != NULL((void*)0))
          printf_unfiltered (is_enumeral
                             ? "[%d] %s in %s (enumeral)\n"
                             : "[%d] %s at %s:?\n",
                             i + first_choice,
                             SYMBOL_PRINT_NAME (syms[i].sym)(demangle ? (symbol_natural_name (&(syms[i].sym)->ginfo
)) : (syms[i].sym)->ginfo.name),
                             symtab->filename);
        else
          printf_unfiltered (is_enumeral
                             ? "[%d] %s (enumeral)\n"
                             : "[%d] %s at ?\n",
                             i + first_choice,
                             SYMBOL_PRINT_NAME (syms[i].sym)(demangle ? (symbol_natural_name (&(syms[i].sym)->ginfo
)) : (syms[i].sym)->ginfo.name));
      }
  }

n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
                           "overload-choice");

for (i = 0; i < n_chosen; i += 1)
  syms[i] = syms[chosen[i]];

return n_chosen;
3113}

3115/* Read and validate a set of numeric choices from the user in the
 range 0 .. N_CHOICES-1.  Place the results in increasing
 order in CHOICES[0 .. N-1], and return N.

 The user types choices as a sequence of numbers on one line
 separated by blanks, encoding them as follows:

   + A choice of 0 means to cancel the selection, throwing an error.
   + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
   + The user chooses k by typing k+IS_ALL_CHOICE+1.

 The user is not allowed to choose more than MAX_RESULTS values.

 ANNOTATION_SUFFIX, if present, is used to annotate the input
 prompts (for use with the -f switch).  */

3131int
3132get_selections (int *choices, int n_choices, int max_results,
              int is_all_choice, char *annotation_suffix)
3134{
char *args;
const char *prompt;
int n_chosen;
int first_choice = is_all_choice ? 2 : 1;

prompt = getenv ("PS2");
if (prompt == NULL((void*)0))
  prompt = ">";

printf_unfiltered ("%s ", prompt);
gdb_flush (gdb_stdout);

args = command_line_input ((char *) NULL((void*)0), 0, annotation_suffix);

if (args == NULL((void*)0))
  error_no_arg ("one or more choice numbers");

n_chosen = 0;

/* Set choices[0 .. n_chosen-1] to the users' choices in ascending
   order, as given in args.  Choices are validated.  */
while (1)
  {
    char *args2;
    int choice, j;

    while (isspace (*args))
      args += 1;
    if (*args == '\0' && n_chosen == 0)
      error_no_arg ("one or more choice numbers");
    else if (*args == '\0')
      break;

    choice = strtol (args, &args2, 10);
    if (args == args2 || choice < 0
        || choice > n_choices + first_choice - 1)
      error ("Argument must be choice number");
    args = args2;

    if (choice == 0)
      error ("cancelled");

    if (choice < first_choice)
      {
        n_chosen = n_choices;
        for (j = 0; j < n_choices; j += 1)
          choices[j] = j;
        break;
      }
    choice -= first_choice;

    for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
      {
      }

    if (j < 0 || choice != choices[j])
      {
        int k;
        for (k = n_chosen - 1; k > j; k -= 1)
          choices[k + 1] = choices[k];
        choices[j + 1] = choice;
        n_chosen += 1;
      }
  }

if (n_chosen > max_results)
  error ("Select no more than %d of the above", max_results);

return n_chosen;
3204}

3206/* Replace the operator of length OPLEN at position PC in *EXPP with a call
 on the function identified by SYM and BLOCK, and taking NARGS
 arguments.  Update *EXPP as needed to hold more space.  */

3210static void
3211replace_operator_with_call (struct expression **expp, int pc, int nargs,
                          int oplen, struct symbol *sym,
                          struct block *block)
3214{
/* A new expression, with 6 more elements (3 for funcall, 4 for function
   symbol, -oplen for operator being replaced).  */
struct expression *newexp = (struct expression *)
  xmalloc (sizeof (struct expression)
           + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen)(((*expp)->nelts + 7 - oplen) * sizeof (union exp_element)
));
struct expression *exp = *expp;

newexp->nelts = exp->nelts + 7 - oplen;
newexp->language_defn = exp->language_defn;
memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc)((pc) * sizeof (union exp_element)));
memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
        EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen)((exp->nelts - pc - oplen) * sizeof (union exp_element)));

newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
newexp->elts[pc + 1].longconst = (LONGESTlong) nargs;

newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
newexp->elts[pc + 4].block = block;
newexp->elts[pc + 5].symbol = sym;

*expp = newexp;
xfree (exp);
3237}

3239/* Type-class predicates */

3241/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
 or FLOAT).  */

3244static int
3245numeric_type_p (struct type *type)
3246{
if (type == NULL((void*)0))
  return 0;
else
  {
    switch (TYPE_CODE (type)(type)->main_type->code)
      {
      case TYPE_CODE_INT:
      case TYPE_CODE_FLT:
        return 1;
      case TYPE_CODE_RANGE:
        return (type == TYPE_TARGET_TYPE (type)(type)->main_type->target_type
                || numeric_type_p (TYPE_TARGET_TYPE (type)(type)->main_type->target_type));
      default:
        return 0;
      }
  }
3263}

3265/* True iff TYPE is integral (an INT or RANGE of INTs).  */

3267static int
3268integer_type_p (struct type *type)
3269{
if (type == NULL((void*)0))
  return 0;
else
  {
    switch (TYPE_CODE (type)(type)->main_type->code)
      {
      case TYPE_CODE_INT:
        return 1;
      case TYPE_CODE_RANGE:
        return (type == TYPE_TARGET_TYPE (type)(type)->main_type->target_type
                || integer_type_p (TYPE_TARGET_TYPE (type)(type)->main_type->target_type));
      default:
        return 0;
      }
  }
3285}

3287/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM).  */

3289static int
3290scalar_type_p (struct type *type)
3291{
if (type == NULL((void*)0))
  return 0;
else
  {
    switch (TYPE_CODE (type)(type)->main_type->code)
      {
      case TYPE_CODE_INT:
      case TYPE_CODE_RANGE:
      case TYPE_CODE_ENUM:
      case TYPE_CODE_FLT:
        return 1;
      default:
        return 0;
      }
  }
3307}

3309/* True iff TYPE is discrete (INT, RANGE, ENUM).  */

3311static int
3312discrete_type_p (struct type *type)
3313{
if (type == NULL((void*)0))
  return 0;
else
  {
    switch (TYPE_CODE (type)(type)->main_type->code)
      {
      case TYPE_CODE_INT:
      case TYPE_CODE_RANGE:
      case TYPE_CODE_ENUM:
        return 1;
      default:
        return 0;
      }
  }
3328}

3330/* Returns non-zero if OP with operands in the vector ARGS could be
 a user-defined function.  Errs on the side of pre-defined operators
 (i.e., result 0).  */

3334static int
3335possible_user_operator_p (enum exp_opcode op, struct value *args[])
3336{
struct type *type0 =
  (args[0] == NULL((void*)0)) ? NULL((void*)0) : ada_check_typedef (VALUE_TYPE (args[0])(args[0])->type);
struct type *type1 =
  (args[1] == NULL((void*)0)) ? NULL((void*)0) : ada_check_typedef (VALUE_TYPE (args[1])(args[1])->type);

if (type0 == NULL((void*)0))
  return 0;

switch (op)
  {
  default:
    return 0;

  case BINOP_ADD:
  case BINOP_SUB:
  case BINOP_MUL:
  case BINOP_DIV:
    return (!(numeric_type_p (type0) && numeric_type_p (type1)));

  case BINOP_REM:
  case BINOP_MOD:
  case BINOP_BITWISE_AND:
  case BINOP_BITWISE_IOR:
  case BINOP_BITWISE_XOR:
    return (!(integer_type_p (type0) && integer_type_p (type1)));

  case BINOP_EQUAL:
  case BINOP_NOTEQUAL:
  case BINOP_LESS:
  case BINOP_GTR:
  case BINOP_LEQ:
  case BINOP_GEQ:
    return (!(scalar_type_p (type0) && scalar_type_p (type1)));

  case BINOP_CONCAT:
    return
      ((TYPE_CODE (type0)(type0)->main_type->code != TYPE_CODE_ARRAY
        && (TYPE_CODE (type0)(type0)->main_type->code != TYPE_CODE_PTR
            || TYPE_CODE (TYPE_TARGET_TYPE (type0))((type0)->main_type->target_type)->main_type->code != TYPE_CODE_ARRAY))
       || (TYPE_CODE (type1)(type1)->main_type->code != TYPE_CODE_ARRAY
           && (TYPE_CODE (type1)(type1)->main_type->code != TYPE_CODE_PTR
               || (TYPE_CODE (TYPE_TARGET_TYPE (type1))((type1)->main_type->target_type)->main_type->code 
     != TYPE_CODE_ARRAY))));

  case BINOP_EXP:
    return (!(numeric_type_p (type0) && integer_type_p (type1)));

  case UNOP_NEG:
  case UNOP_PLUS:
  case UNOP_LOGICAL_NOT:
  case UNOP_ABS:
    return (!numeric_type_p (type0));

  }
3391}
3392
                              /* Renaming */

3395/* NOTE: In the following, we assume that a renaming type's name may
 have an ___XD suffix.  It would be nice if this went away at some
 point.  */

3399/* If TYPE encodes a renaming, returns the renaming suffix, which
 is XR for an object renaming, XRP for a procedure renaming, XRE for
 an exception renaming, and XRS for a subprogram renaming.  Returns
 NULL if NAME encodes none of these.  */

3404const char *
3405ada_renaming_type (struct type *type)
3406{
if (type != NULL((void*)0) && TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_ENUM)
  {
    const char *name = type_name_no_tag (type);
    const char *suffix = (name == NULL((void*)0)) ? NULL((void*)0) : strstr (name, "___XR");
    if (suffix == NULL((void*)0)
        || (suffix[5] != '\000' && strchr ("PES_", suffix[5]) == NULL((void*)0)))
      return NULL((void*)0);
    else
      return suffix + 3;
  }
else
  return NULL((void*)0);
3419}

3421/* Return non-zero iff SYM encodes an object renaming.  */

3423int
3424ada_is_object_renaming (struct symbol *sym)
3425{
const char *renaming_type = ada_renaming_type (SYMBOL_TYPE (sym)(sym)->type);
return renaming_type != NULL((void*)0)
  && (renaming_type[2] == '\0' || renaming_type[2] == '_');
3429}

3431/* Assuming that SYM encodes a non-object renaming, returns the original
 name of the renamed entity.  The name is good until the end of
 parsing.  */

3435char *
3436ada_simple_renamed_entity (struct symbol *sym)
3437{
struct type *type;
const char *raw_name;
int len;
char *result;

type = SYMBOL_TYPE (sym)(sym)->type;
if (type == NULL((void*)0) || TYPE_NFIELDS (type)(type)->main_type->nfields < 1)
  error ("Improperly encoded renaming.");

raw_name = TYPE_FIELD_NAME (type, 0)(((type)->main_type->fields[0]).name);
len = (raw_name == NULL((void*)0) ? 0 : strlen (raw_name)) - 5;
if (len <= 0)
  error ("Improperly encoded renaming.");

result = xmalloc (len + 1);
strncpy (result, raw_name, len);
result[len] = '\000';
return result;
3456}
3457

                              /* Evaluation: Function Calls */

3461/* Return an lvalue containing the value VAL.  This is the identity on
 lvalues, and otherwise has the side-effect of pushing a copy of VAL 
 on the stack, using and updating *SP as the stack pointer, and 
 returning an lvalue whose VALUE_ADDRESS points to the copy.  */

3466static struct value *
3467ensure_lval (struct value *val, CORE_ADDR *sp)
3468{
if (! VALUE_LVAL (val)(val)->lval)
  {
    int len = TYPE_LENGTH (ada_check_typedef (VALUE_TYPE (val)))(ada_check_typedef ((val)->type))->length;

    /* The following is taken from the structure-return code in
call_function_by_hand. FIXME: Therefore, some refactoring seems 
indicated. */
    if (INNER_THAN (1, 2)(gdbarch_inner_than (current_gdbarch, 1, 2)))
{
 /* Stack grows downward.  Align SP and VALUE_ADDRESS (val) after
    reserving sufficient space. */
 *sp -= len;
 if (gdbarch_frame_align_p (current_gdbarch))
   *sp = gdbarch_frame_align (current_gdbarch, *sp);
 VALUE_ADDRESS (val)(val)->location.address = *sp;
}
    else
{
 /* Stack grows upward.  Align the frame, allocate space, and
    then again, re-align the frame. */
 if (gdbarch_frame_align_p (current_gdbarch))
   *sp = gdbarch_frame_align (current_gdbarch, *sp);
 VALUE_ADDRESS (val)(val)->location.address = *sp;
 *sp += len;
 if (gdbarch_frame_align_p (current_gdbarch))
   *sp = gdbarch_frame_align (current_gdbarch, *sp);
}

    write_memory (VALUE_ADDRESS (val)(val)->location.address, VALUE_CONTENTS_RAW (val)((char *) (val)->aligner.contents + (val)->embedded_offset
), len);
  }

return val;
3501}

3503/* Return the value ACTUAL, converted to be an appropriate value for a
 formal of type FORMAL_TYPE.  Use *SP as a stack pointer for
 allocating any necessary descriptors (fat pointers), or copies of
 values not residing in memory, updating it as needed.  */

3508static struct value *
3509convert_actual (struct value *actual, struct type *formal_type0,
              CORE_ADDR *sp)
3511{
struct type *actual_type = ada_check_typedef (VALUE_TYPE (actual)(actual)->type);
struct type *formal_type = ada_check_typedef (formal_type0);
struct type *formal_target =
  TYPE_CODE (formal_type)(formal_type)->main_type->code == TYPE_CODE_PTR
  ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)(formal_type)->main_type->target_type) : formal_type;
struct type *actual_target =
  TYPE_CODE (actual_type)(actual_type)->main_type->code == TYPE_CODE_PTR
  ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)(actual_type)->main_type->target_type) : actual_type;

if (ada_is_array_descriptor_type (formal_target)
    && TYPE_CODE (actual_target)(actual_target)->main_type->code == TYPE_CODE_ARRAY)
  return make_array_descriptor (formal_type, actual, sp);
else if (TYPE_CODE (formal_type)(formal_type)->main_type->code == TYPE_CODE_PTR)
  {
    if (TYPE_CODE (formal_target)(formal_target)->main_type->code == TYPE_CODE_ARRAY
        && ada_is_array_descriptor_type (actual_target))
      return desc_data (actual);
    else if (TYPE_CODE (actual_type)(actual_type)->main_type->code != TYPE_CODE_PTR)
      {
        if (VALUE_LVAL (actual)(actual)->lval != lval_memory)
          {
            struct value *val;
            actual_type = ada_check_typedef (VALUE_TYPE (actual)(actual)->type);
            val = allocate_value (actual_type);
            memcpy ((char *) VALUE_CONTENTS_RAW (val)((char *) (val)->aligner.contents + (val)->embedded_offset
),
                    (char *) VALUE_CONTENTS (actual)((void)((actual)->lazy && value_fetch_lazy(actual)
), ((char *) (actual)->aligner.contents + (actual)->embedded_offset
)),
                    TYPE_LENGTH (actual_type)(actual_type)->length);
            actual = ensure_lval (val, sp);
          }
        return value_addr (actual);
      }
  }
else if (TYPE_CODE (actual_type)(actual_type)->main_type->code == TYPE_CODE_PTR)
  return ada_value_ind (actual);

return actual;
3548}


3551/* Push a descriptor of type TYPE for array value ARR on the stack at
 *SP, updating *SP to reflect the new descriptor.  Return either
 an lvalue representing the new descriptor, or (if TYPE is a pointer-
 to-descriptor type rather than a descriptor type), a struct value *
 representing a pointer to this descriptor.  */

3557static struct value *
3558make_array_descriptor (struct type *type, struct value *arr, CORE_ADDR *sp)
3559{
struct type *bounds_type = desc_bounds_type (type);
struct type *desc_type = desc_base_type (type);
struct value *descriptor = allocate_value (desc_type);
struct value *bounds = allocate_value (bounds_type);
int i;

for (i = ada_array_arity (ada_check_typedef (VALUE_TYPE (arr)(arr)->type)); i > 0; i -= 1)
  {
    modify_general_field (VALUE_CONTENTS (bounds)((void)((bounds)->lazy && value_fetch_lazy(bounds)
), ((char *) (bounds)->aligner.contents + (bounds)->embedded_offset
)),
                          value_as_long (ada_array_bound (arr, i, 0)),
                          desc_bound_bitpos (bounds_type, i, 0),
                          desc_bound_bitsize (bounds_type, i, 0));
    modify_general_field (VALUE_CONTENTS (bounds)((void)((bounds)->lazy && value_fetch_lazy(bounds)
), ((char *) (bounds)->aligner.contents + (bounds)->embedded_offset
)),
                          value_as_long (ada_array_bound (arr, i, 1)),
                          desc_bound_bitpos (bounds_type, i, 1),
                          desc_bound_bitsize (bounds_type, i, 1));
  }

bounds = ensure_lval (bounds, sp);

modify_general_field (VALUE_CONTENTS (descriptor)((void)((descriptor)->lazy && value_fetch_lazy(descriptor
)), ((char *) (descriptor)->aligner.contents + (descriptor
)->embedded_offset)),
                      VALUE_ADDRESS (ensure_lval (arr, sp))(ensure_lval (arr, sp))->location.address,
                      fat_pntr_data_bitpos (desc_type),
                      fat_pntr_data_bitsize (desc_type));

modify_general_field (VALUE_CONTENTS (descriptor)((void)((descriptor)->lazy && value_fetch_lazy(descriptor
)), ((char *) (descriptor)->aligner.contents + (descriptor
)->embedded_offset)),
                      VALUE_ADDRESS (bounds)(bounds)->location.address,
                      fat_pntr_bounds_bitpos (desc_type),
                      fat_pntr_bounds_bitsize (desc_type));

descriptor = ensure_lval (descriptor, sp);

if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_PTR)
  return value_addr (descriptor);
else
  return descriptor;
3596}


3599/* Assuming a dummy frame has been established on the target, perform any
 conversions needed for calling function FUNC on the NARGS actual
 parameters in ARGS, other than standard C conversions.  Does
 nothing if FUNC does not have Ada-style prototype data, or if NARGS
 does not match the number of arguments expected.  Use *SP as a
 stack pointer for additional data that must be pushed, updating its
 value as needed.  */

3607void
3608ada_convert_actuals (struct value *func, int nargs, struct value *args[],
                   CORE_ADDR *sp)
3610{
int i;

if (TYPE_NFIELDS (VALUE_TYPE (func))((func)->type)->main_type->nfields == 0
    || nargs != TYPE_NFIELDS (VALUE_TYPE (func))((func)->type)->main_type->nfields)
  return;

for (i = 0; i < nargs; i += 1)
  args[i] =
    convert_actual (args[i], TYPE_FIELD_TYPE (VALUE_TYPE (func), i)((((func)->type)->main_type->fields[i]).type), sp);
3620}
3621
3622/* Dummy definitions for an experimental caching module that is not
* used in the public sources. */

3625static int
3626lookup_cached_symbol (const char *name, domain_enum namespace,
                    struct symbol **sym, struct block **block,
                    struct symtab **symtab)
3629{
return 0;
3631}

3633static void
3634cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
            struct block *block, struct symtab *symtab)
3636{
3637}
3638
                              /* Symbol Lookup */

3641/* Return the result of a standard (literal, C-like) lookup of NAME in
 given DOMAIN, visible from lexical block BLOCK.  */

3644static struct symbol *
3645standard_lookup (const char *name, const struct block *block,
               domain_enum domain)
3647{
struct symbol *sym;
struct symtab *symtab;

if (lookup_cached_symbol (name, domain, &sym, NULL((void*)0), NULL((void*)0)))
  return sym;
sym =
  lookup_symbol_in_language (name, block, domain, language_c, 0, &symtab);
cache_symbol (name, domain, sym, block_found, symtab);
return sym;
3657}


3660/* Non-zero iff there is at least one non-function/non-enumeral symbol
 in the symbol fields of SYMS[0..N-1].  We treat enumerals as functions, 
 since they contend in overloading in the same way.  */
3663static int
3664is_nonfunction (struct ada_symbol_info syms[], int n)
3665{
int i;

for (i = 0; i < n; i += 1)
  if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym))((syms[i].sym)->type)->main_type->code != TYPE_CODE_FUNC
      && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym))((syms[i].sym)->type)->main_type->code != TYPE_CODE_ENUM
          || SYMBOL_CLASS (syms[i].sym)(syms[i].sym)->aclass != LOC_CONST))
    return 1;

return 0;
3675}

3677/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
 struct types.  Otherwise, they may not.  */

3680static int
3681equiv_types (struct type *type0, struct type *type1)
3682{
if (type0 == type1)
  return 1;
if (type0 == NULL((void*)0) || type1 == NULL((void*)0)
    || TYPE_CODE (type0)(type0)->main_type->code != TYPE_CODE (type1)(type1)->main_type->code)
  return 0;
if ((TYPE_CODE (type0)(type0)->main_type->code == TYPE_CODE_STRUCT
     || TYPE_CODE (type0)(type0)->main_type->code == TYPE_CODE_ENUM)
    && ada_type_name (type0) != NULL((void*)0) && ada_type_name (type1) != NULL((void*)0)
    && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
  return 1;

return 0;
3695}

3697/* True iff SYM0 represents the same entity as SYM1, or one that is
 no more defined than that of SYM1.  */

3700static int
3701lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
3702{
if (sym0 == sym1)
  return 1;
if (SYMBOL_DOMAIN (sym0)(sym0)->domain != SYMBOL_DOMAIN (sym1)(sym1)->domain
    || SYMBOL_CLASS (sym0)(sym0)->aclass != SYMBOL_CLASS (sym1)(sym1)->aclass)
  return 0;

switch (SYMBOL_CLASS (sym0)(sym0)->aclass)
  {
  case LOC_UNDEF:
    return 1;
  case LOC_TYPEDEF:
    {
      struct type *type0 = SYMBOL_TYPE (sym0)(sym0)->type;
      struct type *type1 = SYMBOL_TYPE (sym1)(sym1)->type;
      char *name0 = SYMBOL_LINKAGE_NAME (sym0)(sym0)->ginfo.name;
      char *name1 = SYMBOL_LINKAGE_NAME (sym1)(sym1)->ginfo.name;
      int len0 = strlen (name0);
      return
        TYPE_CODE (type0)(type0)->main_type->code == TYPE_CODE (type1)(type1)->main_type->code
        && (equiv_types (type0, type1)
            || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
                && strncmp (name1 + len0, "___XV", 5) == 0));
    }
  case LOC_CONST:
    return SYMBOL_VALUE (sym0)(sym0)->ginfo.value.ivalue == SYMBOL_VALUE (sym1)(sym1)->ginfo.value.ivalue
      && equiv_types (SYMBOL_TYPE (sym0)(sym0)->type, SYMBOL_TYPE (sym1)(sym1)->type);
  default:
    return 0;
  }
3732}

3734/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
 records in OBSTACKP.  Do nothing if SYM is a duplicate.  */

3737static void
3738add_defn_to_vec (struct obstack *obstackp,
               struct symbol *sym,
               struct block *block, struct symtab *symtab)
3741{
int i;
size_t tmp;
struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);

if (SYMBOL_TYPE (sym)(sym)->type != NULL((void*)0))
  SYMBOL_TYPE (sym)(sym)->type = ada_check_typedef (SYMBOL_TYPE (sym)(sym)->type);
for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
  {
    if (lesseq_defined_than (sym, prevDefns[i].sym))
      return;
    else if (lesseq_defined_than (prevDefns[i].sym, sym))
      {
        prevDefns[i].sym = sym;
        prevDefns[i].block = block;
        prevDefns[i].symtab = symtab;
        return;
      }
  }

{
  struct ada_symbol_info info;

  info.sym = sym;
  info.block = block;
  info.symtab = symtab;
  obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info))__extension__ ({ struct obstack *__o = (obstackp); int __len =
 (sizeof (struct ada_symbol_info)); if (__o->next_free + __len
 > __o->chunk_limit) _obstack_newchunk (__o, __len); memcpy
 ((__o->next_free), ((&info)), (__len)); __o->next_free
 += __len; (void) 0; });
}
3769}

3771/* Number of ada_symbol_info structures currently collected in 
 current vector in *OBSTACKP.  */

3774static int
3775num_defns_collected (struct obstack *obstackp)
3776{
return obstack_object_size (obstackp)__extension__ ({ struct obstack *__o = (obstackp); (unsigned)
 (__o->next_free - __o->object_base); }) / sizeof (struct ada_symbol_info);
3778}

3780/* Vector of ada_symbol_info structures currently collected in current 
 vector in *OBSTACKP.  If FINISH, close off the vector and return
 its final address.  */

3784static struct ada_symbol_info *
3785defns_collected (struct obstack *obstackp, int finish)
3786{
if (finish)
  return obstack_finish (obstackp)__extension__ ({ struct obstack *__o1 = (obstackp); void *value
; value = (void *) __o1->object_base; if (__o1->next_free
 == value) __o1->maybe_empty_object = 1; __o1->next_free
 = (((((__o1->next_free) - (char *) 0)+__o1->alignment_mask
) & ~ (__o1->alignment_mask)) + (char *) 0); if (__o1->
next_free - (char *)__o1->chunk > __o1->chunk_limit -
 (char *)__o1->chunk) __o1->next_free = __o1->chunk_limit
; __o1->object_base = __o1->next_free; value; });
else
  return (struct ada_symbol_info *) obstack_base (obstackp)((obstackp)->object_base);
3791}

3793/* Look, in partial_symtab PST, for symbol NAME in given namespace.
 Check the global symbols if GLOBAL, the static symbols if not.
 Do wild-card match if WILD.  */

3797static struct partial_symbol *
3798ada_lookup_partial_symbol (struct partial_symtab *pst, const char *name,
                         int global, domain_enum namespace, int wild)
3800{
struct partial_symbol **start;
int name_len = strlen (name);
int length = (global ? pst->n_global_syms : pst->n_static_syms);
int i;

if (length == 0)
  {
    return (NULL((void*)0));
  }

start = (global ?
         pst->objfile->global_psymbols.list + pst->globals_offset :
         pst->objfile->static_psymbols.list + pst->statics_offset);

if (wild)
  {
    for (i = 0; i < length; i += 1)
      {
        struct partial_symbol *psym = start[i];

        if (SYMBOL_DOMAIN (psym)(psym)->domain == namespace
            && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name))
          return psym;
      }
    return NULL((void*)0);
  }
else
  {
    if (global)
      {
        int U;
        i = 0;
        U = length - 1;
        while (U - i > 4)
          {
            int M = (U + i) >> 1;
            struct partial_symbol *psym = start[M];
            if (SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name[0] < name[0])
              i = M + 1;
            else if (SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name[0] > name[0])
              U = M - 1;
            else if (strcmp (SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name, name) < 0)
              i = M + 1;
            else
              U = M;
          }
      }
    else
      i = 0;

    while (i < length)
      {
        struct partial_symbol *psym = start[i];

        if (SYMBOL_DOMAIN (psym)(psym)->domain == namespace)
          {
            int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name, name_len);

            if (cmp < 0)
              {
                if (global)
                  break;
              }
            else if (cmp == 0
                     && is_name_suffix (SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name
                                        + name_len))
              return psym;
          }
        i += 1;
      }

    if (global)
      {
        int U;
        i = 0;
        U = length - 1;
        while (U - i > 4)
          {
            int M = (U + i) >> 1;
            struct partial_symbol *psym = start[M];
            if (SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name[0] < '_')
              i = M + 1;
            else if (SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name[0] > '_')
              U = M - 1;
            else if (strcmp (SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name, "_ada_") < 0)
              i = M + 1;
            else
              U = M;
          }
      }
    else
      i = 0;

    while (i < length)
      {
        struct partial_symbol *psym = start[i];

        if (SYMBOL_DOMAIN (psym)(psym)->domain == namespace)
          {
            int cmp;

            cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name[0];
            if (cmp == 0)
              {
                cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name, 5);
                if (cmp == 0)
                  cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name + 5,
                                 name_len);
              }

            if (cmp < 0)
              {
                if (global)
                  break;
              }
            else if (cmp == 0
                     && is_name_suffix (SYMBOL_LINKAGE_NAME (psym)(psym)->ginfo.name
                                        + name_len + 5))
              return psym;
          }
        i += 1;
      }
  }
return NULL((void*)0);
3925}

3927/* Find a symbol table containing symbol SYM or NULL if none.  */

3929static struct symtab *
3930symtab_for_sym (struct symbol *sym)
3931{
struct symtab *s;
struct objfile *objfile;
struct block *b;
struct symbol *tmp_sym;
struct dict_iterator iter;
int j;

ALL_SYMTABS (objfile, s)for ((objfile) = object_files; (objfile) != ((void*)0); (objfile
) = (objfile)->next) for ((s) = (objfile) -> symtabs; (
s) != ((void*)0); (s) = (s) -> next)
{
  switch (SYMBOL_CLASS (sym)(sym)->aclass)
    {
    case LOC_CONST:
    case LOC_STATIC:
    case LOC_TYPEDEF:
    case LOC_REGISTER:
    case LOC_LABEL:
    case LOC_BLOCK:
    case LOC_CONST_BYTES:
      b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK)((s)->blockvector)->block[GLOBAL_BLOCK];
      ALL_BLOCK_SYMBOLS (b, iter, tmp_sym)for ((tmp_sym) = dict_iterator_first (((b)->dict), &(iter
)); (tmp_sym); (tmp_sym) = dict_iterator_next (&(iter))) if (sym == tmp_sym)
        return s;
      b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK)((s)->blockvector)->block[STATIC_BLOCK];
      ALL_BLOCK_SYMBOLS (b, iter, tmp_sym)for ((tmp_sym) = dict_iterator_first (((b)->dict), &(iter
)); (tmp_sym); (tmp_sym) = dict_iterator_next (&(iter))) if (sym == tmp_sym)
        return s;
      break;
    default:
      break;
    }
  switch (SYMBOL_CLASS (sym)(sym)->aclass)
    {
    case LOC_REGISTER:
    case LOC_ARG:
    case LOC_REF_ARG:
    case LOC_REGPARM:
    case LOC_REGPARM_ADDR:
    case LOC_LOCAL:
    case LOC_TYPEDEF:
    case LOC_LOCAL_ARG:
    case LOC_BASEREG:
    case LOC_BASEREG_ARG:
    case LOC_COMPUTED:
    case LOC_COMPUTED_ARG:
      for (j = FIRST_LOCAL_BLOCK;
           j < BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s))((s)->blockvector)->nblocks; j += 1)
        {
          b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), j)((s)->blockvector)->block[j];
          ALL_BLOCK_SYMBOLS (b, iter, tmp_sym)for ((tmp_sym) = dict_iterator_first (((b)->dict), &(iter
)); (tmp_sym); (tmp_sym) = dict_iterator_next (&(iter))) if (sym == tmp_sym)
            return s;
        }
      break;
    default:
      break;
    }
}
return NULL((void*)0);
3987}

3989/* Return a minimal symbol matching NAME according to Ada decoding
 rules.  Returns NULL if there is no such minimal symbol.  Names 
 prefixed with "standard__" are handled specially: "standard__" is 
 first stripped off, and only static and global symbols are searched.  */

3994struct minimal_symbol *
3995ada_lookup_simple_minsym (const char *name)
3996{
struct objfile *objfile;
struct minimal_symbol *msymbol;
int wild_match;

if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
  {
    name += sizeof ("standard__") - 1;
    wild_match = 0;
  }
else
  wild_match = (strstr (name, "__") == NULL((void*)0));

ALL_MSYMBOLS (objfile, msymbol)for ((objfile) = object_files; (objfile) != ((void*)0); (objfile
) = (objfile)->next) for ((msymbol) = (objfile) -> msymbols
; (msymbol)->ginfo.name != ((void*)0); (msymbol)++)
{
  if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol)(msymbol)->ginfo.name, name, wild_match)
      && MSYMBOL_TYPE (msymbol)(msymbol)->type != mst_solib_trampoline)
    return msymbol;
}

return NULL((void*)0);
4017}

4019/* For all subprograms that statically enclose the subprogram of the
 selected frame, add symbols matching identifier NAME in DOMAIN
 and their blocks to the list of data in OBSTACKP, as for
 ada_add_block_symbols (q.v.).   If WILD, treat as NAME with a
 wildcard prefix.  */

4025static void
4026add_symbols_from_enclosing_procs (struct obstack *obstackp,
                                const char *name, domain_enum namespace,
                                int wild_match)
4029{
4030}

4032/* FIXME: The next two routines belong in symtab.c */

4034static void
4035restore_language (void *lang)
4036{
set_language ((enum language) lang);
4038}

4040/* As for lookup_symbol, but performed as if the current language 
 were LANG. */

4043struct symbol *
4044lookup_symbol_in_language (const char *name, const struct block *block,
                         domain_enum domain, enum language lang,
                         int *is_a_field_of_this, struct symtab **symtab)
4047{
struct cleanup *old_chain
  = make_cleanup (restore_language, (void *) current_language->la_language);
struct symbol *result;
set_language (lang);
result = lookup_symbol (name, block, domain, is_a_field_of_this, symtab);
do_cleanups (old_chain);
return result;
4055}

4057/* True if TYPE is definitely an artificial type supplied to a symbol
 for which no debugging information was given in the symbol file.  */

4060static int
4061is_nondebugging_type (struct type *type)
4062{
char *name = ada_type_name (type);
return (name != NULL((void*)0) && strcmp (name, "<variable, no debug info>") == 0);
4065}

4067/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
 duplicate other symbols in the list (The only case I know of where
 this happens is when object files containing stabs-in-ecoff are
 linked with files containing ordinary ecoff debugging symbols (or no
 debugging symbols)).  Modifies SYMS to squeeze out deleted entries.
 Returns the number of items in the modified list.  */

4074static int
4075remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4076{
int i, j;

i = 0;
while (i < nsyms)
  {
    if (SYMBOL_LINKAGE_NAME (syms[i].sym)(syms[i].sym)->ginfo.name != NULL((void*)0)
        && SYMBOL_CLASS (syms[i].sym)(syms[i].sym)->aclass == LOC_STATIC
        && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)(syms[i].sym)->type))
      {
        for (j = 0; j < nsyms; j += 1)
          {
            if (i != j
                && SYMBOL_LINKAGE_NAME (syms[j].sym)(syms[j].sym)->ginfo.name != NULL((void*)0)
                && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym)(syms[i].sym)->ginfo.name,
                           SYMBOL_LINKAGE_NAME (syms[j].sym)(syms[j].sym)->ginfo.name) == 0
                && SYMBOL_CLASS (syms[i].sym)(syms[i].sym)->aclass == SYMBOL_CLASS (syms[j].sym)(syms[j].sym)->aclass
                && SYMBOL_VALUE_ADDRESS (syms[i].sym)(syms[i].sym)->ginfo.value.address
                == SYMBOL_VALUE_ADDRESS (syms[j].sym)(syms[j].sym)->ginfo.value.address)
              {
                int k;
                for (k = i + 1; k < nsyms; k += 1)
                  syms[k - 1] = syms[k];
                nsyms -= 1;
                goto NextSymbol;
              }
          }
      }
    i += 1;
  NextSymbol:
    ;
  }
return nsyms;
4109}

4111/* Given a type that corresponds to a renaming entity, use the type name
 to extract the scope (package name or function name, fully qualified,
 and following the GNAT encoding convention) where this renaming has been
 defined.  The string returned needs to be deallocated after use.  */

4116static char *
4117xget_renaming_scope (struct type *renaming_type)
4118{
/* The renaming types adhere to the following convention:
   <scope>__<rename>___<XR extension>. 
   So, to extract the scope, we search for the "___XR" extension,
   and then backtrack until we find the first "__".  */

const char *name = type_name_no_tag (renaming_type);
char *suffix = strstr (name, "___XR");
char *last;
int scope_len;
char *scope;

/* Now, backtrack a bit until we find the first "__".  Start looking
   at suffix - 3, as the <rename> part is at least one character long.  */

for (last = suffix - 3; last > name; last--)
  if (last[0] == '_' && last[1] == '_')
    break;

/* Make a copy of scope and return it.  */

scope_len = last - name;
scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));

strncpy (scope, name, scope_len);
scope[scope_len] = '\0';

return scope;
4146}

4148/* Return nonzero if NAME corresponds to a package name.  */

4150static int
4151is_package_name (const char *name)
4152{
/* Here, We take advantage of the fact that no symbols are generated
   for packages, while symbols are generated for each function.
   So the condition for NAME represent a package becomes equivalent
   to NAME not existing in our list of symbols.  There is only one
   small complication with library-level functions (see below).  */

char *fun_name;

/* If it is a function that has not been defined at library level,
   then we should be able to look it up in the symbols.  */
if (standard_lookup (name, NULL((void*)0), VAR_DOMAIN) != NULL((void*)0))
  return 0;

/* Library-level function names start with "_ada_".  See if function
   "_ada_" followed by NAME can be found.  */

/* Do a quick check that NAME does not contain "__", since library-level
   functions names can not contain "__" in them.  */
if (strstr (name, "__") != NULL((void*)0))
  return 0;

fun_name = xstrprintf ("_ada_%s", name);

return (standard_lookup (fun_name, NULL((void*)0), VAR_DOMAIN) == NULL((void*)0));
4177}

4179/* Return nonzero if SYM corresponds to a renaming entity that is
 visible from FUNCTION_NAME.  */

4182static int
4183renaming_is_visible (const struct symbol *sym, char *function_name)
4184{
char *scope = xget_renaming_scope (SYMBOL_TYPE (sym)(sym)->type);

make_cleanup (xfree, scope);

/* If the rename has been defined in a package, then it is visible.  */
if (is_package_name (scope))
  return 1;

/* Check that the rename is in the current function scope by checking
   that its name starts with SCOPE.  */

/* If the function name starts with "_ada_", it means that it is
   a library-level function.  Strip this prefix before doing the
   comparison, as the encoding for the renaming does not contain
   this prefix.  */
if (strncmp (function_name, "_ada_", 5) == 0)
  function_name += 5;

return (strncmp (function_name, scope, strlen (scope)) == 0);
4204}

4206/* Iterates over the SYMS list and remove any entry that corresponds to
 a renaming entity that is not visible from the function associated
 with CURRENT_BLOCK. 
 
 Rationale:
 GNAT emits a type following a specified encoding for each renaming
 entity.  Unfortunately, STABS currently does not support the definition
 of types that are local to a given lexical block, so all renamings types
 are emitted at library level.  As a consequence, if an application
 contains two renaming entities using the same name, and a user tries to
 print the value of one of these entities, the result of the ada symbol
 lookup will also contain the wrong renaming type.

 This function partially covers for this limitation by attempting to
 remove from the SYMS list renaming symbols that should be visible
 from CURRENT_BLOCK.  However, there does not seem be a 100% reliable
 method with the current information available.  The implementation
 below has a couple of limitations (FIXME: brobecker-2003-05-12):  
 
    - When the user tries to print a rename in a function while there
      is another rename entity defined in a package:  Normally, the
      rename in the function has precedence over the rename in the
      package, so the latter should be removed from the list.  This is
      currently not the case.
      
    - This function will incorrectly remove valid renames if
      the CURRENT_BLOCK corresponds to a function which symbol name
      has been changed by an "Export" pragma.  As a consequence,
      the user will be unable to print such rename entities.  */

4236static int
4237remove_out_of_scope_renamings (struct ada_symbol_info *syms,
                             int nsyms, struct block *current_block)
4239{
struct symbol *current_function;
char *current_function_name;
int i;

/* Extract the function name associated to CURRENT_BLOCK.
   Abort if unable to do so.  */

if (current_block == NULL((void*)0))
  return nsyms;

current_function = block_function (current_block);
if (current_function == NULL((void*)0))
  return nsyms;

current_function_name = SYMBOL_LINKAGE_NAME (current_function)(current_function)->ginfo.name;
if (current_function_name == NULL((void*)0))
  return nsyms;

/* Check each of the symbols, and remove it from the list if it is
   a type corresponding to a renaming that is out of the scope of
   the current block.  */

i = 0;
while (i < nsyms)
  {
    if (ada_is_object_renaming (syms[i].sym)
        && !renaming_is_visible (syms[i].sym, current_function_name))
      {
        int j;
        for (j = i + 1; j < nsyms; j++)
          syms[j - 1] = syms[j];
        nsyms -= 1;
      }
    else
      i += 1;
  }

return nsyms;
4278}

4280/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
 scope and in global scopes, returning the number of matches.  Sets
 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
 indicating the symbols found and the blocks and symbol tables (if
 any) in which they were found.  This vector are transient---good only to 
 the next call of ada_lookup_symbol_list.  Any non-function/non-enumeral 
 symbol match within the nest of blocks whose innermost member is BLOCK0,
 is the one match returned (no other matches in that or
   enclosing blocks is returned).  If there are any matches in or
 surrounding BLOCK0, then these alone are returned.  Otherwise, the
 search extends to global and file-scope (static) symbol tables.
 Names prefixed with "standard__" are handled specially: "standard__" 
 is first stripped off, and only static and global symbols are searched.  */

4294int
4295ada_lookup_symbol_list (const char *name0, const struct block *block0,
                      domain_enum namespace,
                      struct ada_symbol_info **results)
4298{
struct symbol *sym;
struct symtab *s;
struct partial_symtab *ps;
struct blockvector *bv;
struct objfile *objfile;
struct block *block;
const char *name;
struct minimal_symbol *msymbol;
int wild_match;
int cacheIfUnique;
int block_depth;
int ndefns;

obstack_free (&symbol_list_obstack, NULL)__extension__ ({ struct obstack *__o = (&symbol_list_obstack
); void *__obj = (((void*)0)); if (__obj > (void *)__o->
chunk && __obj < (void *)__o->chunk_limit) __o->
next_free = __o->object_base = __obj; else (obstack_free) (
__o, __obj); });
obstack_init (&symbol_list_obstack)_obstack_begin ((&symbol_list_obstack), 0, 0, (void *(*) (
long)) xmalloc, (void (*) (void *)) xfree);

cacheIfUnique = 0;

/* Search specified block and its superiors.  */

wild_match = (strstr (name0, "__") == NULL((void*)0));
name = name0;
block = (struct block *) block0;      /* FIXME: No cast ought to be
                                         needed, but adding const will
                                         have a cascade effect.  */
if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
  {
    wild_match = 0;
    block = NULL((void*)0);
    name = name0 + sizeof ("standard__") - 1;
  }

block_depth = 0;
while (block != NULL((void*)0))
  {
    block_depth += 1;
    ada_add_block_symbols (&symbol_list_obstack, block, name,
                           namespace, NULL((void*)0), NULL((void*)0), wild_match);

    /* If we found a non-function match, assume that's the one.  */
    if (is_nonfunction (defns_collected (&symbol_list_obstack, 0),
                        num_defns_collected (&symbol_list_obstack)))
      goto done;

    block = BLOCK_SUPERBLOCK (block)(block)->superblock;
  }

/* If no luck so far, try to find NAME as a local symbol in some lexically
   enclosing subprogram.  */
if (num_defns_collected (&symbol_list_obstack) == 0 && block_depth > 2)
  add_symbols_from_enclosing_procs (&symbol_list_obstack,
                                    name, namespace, wild_match);

/* If we found ANY matches among non-global symbols, we're done.  */

if (num_defns_collected (&symbol_list_obstack) > 0)
  goto done;

cacheIfUnique = 1;
if (lookup_cached_symbol (name0, namespace, &sym, &block, &s))
  {
    if (sym != NULL((void*)0))
      add_defn_to_vec (&symbol_list_obstack, sym, block, s);
    goto done;
  }

/* Now add symbols from all global blocks: symbol tables, minimal symbol
   tables, and psymtab's.  */

ALL_SYMTABS (objfile, s)for ((objfile) = object_files; (objfile) != ((void*)0); (objfile
) = (objfile)->next) for ((s) = (objfile) -> symtabs; (
s) != ((void*)0); (s) = (s) -> next)
{
  QUIT{ if (quit_flag) quit (); if (deprecated_interactive_hook) deprecated_interactive_hook
 (); };
  if (!s->primary)
    continue;
  bv = BLOCKVECTOR (s)(s)->blockvector;
  block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK)(bv)->block[GLOBAL_BLOCK];
  ada_add_block_symbols (&symbol_list_obstack, block, name, namespace,
                         objfile, s, wild_match);
}

if (namespace == VAR_DOMAIN)
  {
    ALL_MSYMBOLS (objfile, msymbol)for ((objfile) = object_files; (objfile) != ((void*)0); (objfile
) = (objfile)->next) for ((msymbol) = (objfile) -> msymbols
; (msymbol)->ginfo.name != ((void*)0); (msymbol)++)
    {
      if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol)(msymbol)->ginfo.name, name, wild_match))
        {
          switch (MSYMBOL_TYPE (msymbol)(msymbol)->type)
            {
            case mst_solib_trampoline:
              break;
            default:
              s = find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol)(msymbol)->ginfo.value.address);
              if (s != NULL((void*)0))
                {
                  int ndefns0 = num_defns_collected (&symbol_list_obstack);
                  QUIT{ if (quit_flag) quit (); if (deprecated_interactive_hook) deprecated_interactive_hook
 (); };
                  bv = BLOCKVECTOR (s)(s)->blockvector;
                  block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK)(bv)->block[GLOBAL_BLOCK];
                  ada_add_block_symbols (&symbol_list_obstack, block,
                                         SYMBOL_LINKAGE_NAME (msymbol)(msymbol)->ginfo.name,
                                         namespace, objfile, s, wild_match);

                  if (num_defns_collected (&symbol_list_obstack) == ndefns0)
                    {
                      block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK)(bv)->block[STATIC_BLOCK];
                      ada_add_block_symbols (&symbol_list_obstack, block,
                                             SYMBOL_LINKAGE_NAME (msymbol)(msymbol)->ginfo.name,
                                             namespace, objfile, s,
                                             wild_match);
                    }
                }
            }
        }
    }
  }

ALL_PSYMTABS (objfile, ps)for ((objfile) = object_files; (objfile) != ((void*)0); (objfile
) = (objfile)->next) for ((ps) = (objfile) -> psymtabs;
 (ps) != ((void*)0); (ps) = (ps) -> next)
{
  QUIT{ if (quit_flag) quit (); if (deprecated_interactive_hook) deprecated_interactive_hook
 (); };
  if (!ps->readin
      && ada_lookup_partial_symbol (ps, name, 1, namespace, wild_match))
    {
      s = PSYMTAB_TO_SYMTAB (ps)((ps) -> symtab != ((void*)0) ? (ps) -> symtab : psymtab_to_symtab
 (ps));
      if (!s->primary)
        continue;
      bv = BLOCKVECTOR (s)(s)->blockvector;
      block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK)(bv)->block[GLOBAL_BLOCK];
      ada_add_block_symbols (&symbol_list_obstack, block, name,
                             namespace, objfile, s, wild_match);
    }
}

/* Now add symbols from all per-file blocks if we've gotten no hits
   (Not strictly correct, but perhaps better than an error).
   Do the symtabs first, then check the psymtabs.  */

if (num_defns_collected (&symbol_list_obstack) == 0)
  {

    ALL_SYMTABS (objfile, s)for ((objfile) = object_files; (objfile) != ((void*)0); (objfile
) = (objfile)->next) for ((s) = (objfile) -> symtabs; (
s) != ((void*)0); (s) = (s) -> next)
    {
      QUIT{ if (quit_flag) quit (); if (deprecated_interactive_hook) deprecated_interactive_hook
 (); };
      if (!s->primary)
        continue;
      bv = BLOCKVECTOR (s)(s)->blockvector;
      block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK)(bv)->block[STATIC_BLOCK];
      ada_add_block_symbols (&symbol_list_obstack, block, name, namespace,
                             objfile, s, wild_match);
    }

    ALL_PSYMTABS (objfile, ps)for ((objfile) = object_files; (objfile) != ((void*)0); (objfile
) = (objfile)->next) for ((ps) = (objfile) -> psymtabs;
 (ps) != ((void*)0); (ps) = (ps) -> next)
    {
      QUIT{ if (quit_flag) quit (); if (deprecated_interactive_hook) deprecated_interactive_hook
 (); };
      if (!ps->readin
          && ada_lookup_partial_symbol (ps, name, 0, namespace, wild_match))
        {
          s = PSYMTAB_TO_SYMTAB (ps)((ps) -> symtab != ((void*)0) ? (ps) -> symtab : psymtab_to_symtab
 (ps));
          bv = BLOCKVECTOR (s)(s)->blockvector;
          if (!s->primary)
            continue;
          block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK)(bv)->block[STATIC_BLOCK];
          ada_add_block_symbols (&symbol_list_obstack, block, name,
                                 namespace, objfile, s, wild_match);
        }
    }
  }

4466done:
ndefns = num_defns_collected (&symbol_list_obstack);
*results = defns_collected (&symbol_list_obstack, 1);

ndefns = remove_extra_symbols (*results, ndefns);

if (ndefns == 0)
  cache_symbol (name0, namespace, NULL((void*)0), NULL((void*)0), NULL((void*)0));

if (ndefns == 1 && cacheIfUnique)
  cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block,
                (*results)[0].symtab);

ndefns = remove_out_of_scope_renamings (*results, ndefns,
                                        (struct block *) block0);

return ndefns;
4483}

4485/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
 scope and in global scopes, or NULL if none.  NAME is folded and
 encoded first.  Otherwise, the result is as for ada_lookup_symbol_list,
 choosing the first symbol if there are multiple choices.  
 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
 table in which the symbol was found (in both cases, these
 assignments occur only if the pointers are non-null).  */

4493struct symbol *
4494ada_lookup_symbol (const char *name, const struct block *block0,
                 domain_enum namespace, int *is_a_field_of_this,
                 struct symtab **symtab)
4497{
struct ada_symbol_info *candidates;
int n_candidates;

n_candidates = ada_lookup_symbol_list (ada_encode (ada_fold_name (name)),
                                       block0, namespace, &candidates);

if (n_candidates == 0)
  return NULL((void*)0);

if (is_a_field_of_this != NULL((void*)0))
  *is_a_field_of_this = 0;

if (symtab != NULL((void*)0))
  {
    *symtab = candidates[0].symtab;
    if (*symtab == NULL((void*)0) && candidates[0].block != NULL((void*)0))
      {
        struct objfile *objfile;
        struct symtab *s;
        struct block *b;
        struct blockvector *bv;

        /* Search the list of symtabs for one which contains the
           address of the start of this block.  */
        ALL_SYMTABS (objfile, s)for ((objfile) = object_files; (objfile) != ((void*)0); (objfile
) = (objfile)->next) for ((s) = (objfile) -> symtabs; (
s) != ((void*)0); (s) = (s) -> next)
        {
          bv = BLOCKVECTOR (s)(s)->blockvector;
          b = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK)(bv)->block[GLOBAL_BLOCK];
          if (BLOCK_START (b)(b)->startaddr <= BLOCK_START (candidates[0].block)(candidates[0].block)->startaddr
              && BLOCK_END (b)(b)->endaddr > BLOCK_START (candidates[0].block)(candidates[0].block)->startaddr)
            {
              *symtab = s;
              return fixup_symbol_section (candidates[0].sym, objfile);
            }
          return fixup_symbol_section (candidates[0].sym, NULL((void*)0));
        }
      }
  }
return candidates[0].sym;
4537}

4539static struct symbol *
4540ada_lookup_symbol_nonlocal (const char *name,
                          const char *linkage_name,
                          const struct block *block,
                          const domain_enum domain, struct symtab **symtab)
4544{
if (linkage_name == NULL((void*)0))
  linkage_name = name;
return ada_lookup_symbol (linkage_name, block_static_block (block), domain,
                          NULL((void*)0), symtab);
4549}


4552/* True iff STR is a possible encoded suffix of a normal Ada name
 that is to be ignored for matching purposes.  Suffixes of parallel
 names (e.g., XVE) are not included here.  Currently, the possible suffixes
 are given by either of the regular expression:

 (__[0-9]+)?\.[0-9]+  [nested subprogram suffix, on platforms such 
                       as GNU/Linux]
 ___[0-9]+            [nested subprogram suffix, on platforms such as HP/UX]
 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
*/

4563static int
4564is_name_suffix (const char *str)
4565{
int k;
const char *matching;
const int len = strlen (str);

/* (__[0-9]+)?\.[0-9]+ */
matching = str;
if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
  {
    matching += 3;
    while (isdigit (matching[0]))
      matching += 1;
    if (matching[0] == '\0')
      return 1;
  }

if (matching[0] == '.')
  {
    matching += 1;
    while (isdigit (matching[0]))
      matching += 1;
    if (matching[0] == '\0')
      return 1;
  }

/* ___[0-9]+ */
if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
  {
    matching = str + 3;
    while (isdigit (matching[0]))
      matching += 1;
    if (matching[0] == '\0')
      return 1;
  }

/* ??? We should not modify STR directly, as we are doing below.  This
   is fine in this case, but may become problematic later if we find
   that this alternative did not work, and want to try matching
   another one from the begining of STR.  Since we modified it, we
   won't be able to find the begining of the string anymore!  */
if (str[0] == 'X')
  {
    str += 1;
    while (str[0] != '_' && str[0] != '\0')
      {
        if (str[0] != 'n' && str[0] != 'b')
          return 0;
        str += 1;
      }
  }
if (str[0] == '\000')
  return 1;
if (str[0] == '_')
  {
    if (str[1] != '_' || str[2] == '\000')
      return 0;
    if (str[2] == '_')
      {
        if (strcmp (str + 3, "JM") == 0)
          return 1;
        /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
           the LJM suffix in favor of the JM one.  But we will
           still accept LJM as a valid suffix for a reasonable
           amount of time, just to allow ourselves to debug programs
           compiled using an older version of GNAT.  */
        if (strcmp (str + 3, "LJM") == 0)
          return 1;
        if (str[3] != 'X')
          return 0;
        if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
            || str[4] == 'U' || str[4] == 'P')
          return 1;
        if (str[4] == 'R' && str[5] != 'T')
          return 1;
        return 0;
      }
    if (!isdigit (str[2]))
      return 0;
    for (k = 3; str[k] != '\0'; k += 1)
      if (!isdigit (str[k]) && str[k] != '_')
        return 0;
    return 1;
  }
if (str[0] == '$' && isdigit (str[1]))
  {
    for (k = 2; str[k] != '\0'; k += 1)
      if (!isdigit (str[k]) && str[k] != '_')
        return 0;
    return 1;
  }
return 0;
4656}

4658/* Return nonzero if the given string starts with a dot ('.')
 followed by zero or more digits.  
 
 Note: brobecker/2003-11-10: A forward declaration has not been
 added at the begining of this file yet, because this function
 is only used to work around a problem found during wild matching
 when trying to match minimal symbol names against symbol names
 obtained from dwarf-2 data.  This function is therefore currently
 only used in wild_match() and is likely to be deleted when the
 problem in dwarf-2 is fixed.  */

4669static int
4670is_dot_digits_suffix (const char *str)
4671{
if (str[0] != '.')
  return 0;

str++;
while (isdigit (str[0]))
  str++;
return (str[0] == '\0');
4679}

4681/* True if NAME represents a name of the form A1.A2....An, n>=1 and
 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1.  Ignores
 informational suffixes of NAME (i.e., for which is_name_suffix is
 true).  */

4686static int
4687wild_match (const char *patn0, int patn_len, const char *name0)
4688{
int name_len;
char *name;
char *patn;

/* FIXME: brobecker/2003-11-10: For some reason, the symbol name
   stored in the symbol table for nested function names is sometimes
   different from the name of the associated entity stored in
   the dwarf-2 data: This is the case for nested subprograms, where
   the minimal symbol name contains a trailing ".[:digit:]+" suffix,
   while the symbol name from the dwarf-2 data does not.

   Although the DWARF-2 standard documents that entity names stored
   in the dwarf-2 data should be identical to the name as seen in
   the source code, GNAT takes a different approach as we already use
   a special encoding mechanism to convey the information so that
   a C debugger can still use the information generated to debug
   Ada programs.  A corollary is that the symbol names in the dwarf-2
   data should match the names found in the symbol table.  I therefore
   consider this issue as a compiler defect.

   Until the compiler is properly fixed, we work-around the problem
   by ignoring such suffixes during the match.  We do so by making
   a copy of PATN0 and NAME0, and then by stripping such a suffix
   if present.  We then perform the match on the resulting strings.  */
{
  char *dot;
  name_len = strlen (name0);

  name = (char *) alloca ((name_len + 1) * sizeof (char))__builtin_alloca((name_len + 1) * sizeof (char));
  strcpy (name, name0);
  dot = strrchr (name, '.');
  if (dot != NULL((void*)0) && is_dot_digits_suffix (dot))
    *dot = '\0';

  patn = (char *) alloca ((patn_len + 1) * sizeof (char))__builtin_alloca((patn_len + 1) * sizeof (char));
  strncpy (patn, patn0, patn_len);
  patn[patn_len] = '\0';
  dot = strrchr (patn, '.');
  if (dot != NULL((void*)0) && is_dot_digits_suffix (dot))
    {
      *dot = '\0';
      patn_len = dot - patn;
    }
}

/* Now perform the wild match.  */

name_len = strlen (name);
if (name_len >= patn_len + 5 && strncmp (name, "_ada_", 5) == 0
    && strncmp (patn, name + 5, patn_len) == 0
    && is_name_suffix (name + patn_len + 5))
  return 1;

while (name_len >= patn_len)
  {
    if (strncmp (patn, name, patn_len) == 0
        && is_name_suffix (name + patn_len))
      return 1;
    do
      {
        name += 1;
        name_len -= 1;
      }
    while (name_len > 0
           && name[0] != '.' && (name[0] != '_' || name[1] != '_'));
    if (name_len <= 0)
      return 0;
    if (name[0] == '_')
      {
        if (!islower (name[2]))
          return 0;
        name += 2;
        name_len -= 2;
      }
    else
      {
        if (!islower (name[1]))
          return 0;
        name += 1;
        name_len -= 1;
      }
  }

return 0;
4773}


4776/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
 vector *defn_symbols, updating the list of symbols in OBSTACKP 
 (if necessary).  If WILD, treat as NAME with a wildcard prefix. 
 OBJFILE is the section containing BLOCK.
 SYMTAB is recorded with each symbol added.  */

4782static void
4783ada_add_block_symbols (struct obstack *obstackp,
                     struct block *block, const char *name,
                     domain_enum domain, struct objfile *objfile,
                     struct symtab *symtab, int wild)
4787{
struct dict_iterator iter;
int name_len = strlen (name);
/* A matching argument symbol, if any.  */
struct symbol *arg_sym;
/* Set true when we find a matching non-argument symbol.  */
int found_sym;
struct symbol *sym;

arg_sym = NULL((void*)0);
found_sym = 0;
if (wild)
  {
    struct symbol *sym;
    ALL_BLOCK_SYMBOLS (block, iter, sym)for ((sym) = dict_iterator_first (((block)->dict), &(iter
)); (sym); (sym) = dict_iterator_next (&(iter)))
    {
      if (SYMBOL_DOMAIN (sym)(sym)->domain == domain
          && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (sym)(sym)->ginfo.name))
        {
          switch (SYMBOL_CLASS (sym)(sym)->aclass)
            {
            case LOC_ARG:
            case LOC_LOCAL_ARG:
            case LOC_REF_ARG:
            case LOC_REGPARM:
            case LOC_REGPARM_ADDR:
            case LOC_BASEREG_ARG:
            case LOC_COMPUTED_ARG:
              arg_sym = sym;
              break;
            case LOC_UNRESOLVED:
              continue;
            default:
              found_sym = 1;
              add_defn_to_vec (obstackp,
                               fixup_symbol_section (sym, objfile),
                               block, symtab);
              break;
            }
        }
    }
  }
else
  {
    ALL_BLOCK_SYMBOLS (block, iter, sym)for ((sym) = dict_iterator_first (((block)->dict), &(iter
)); (sym); (sym) = dict_iterator_next (&(iter)))
    {
      if (SYMBOL_DOMAIN (sym)(sym)->domain == domain)
        {
          int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym)(sym)->ginfo.name, name_len);
          if (cmp == 0
              && is_name_suffix (SYMBOL_LINKAGE_NAME (sym)(sym)->ginfo.name + name_len))
            {
              switch (SYMBOL_CLASS (sym)(sym)->aclass)
                {
                case LOC_ARG:
                case LOC_LOCAL_ARG:
                case LOC_REF_ARG:
                case LOC_REGPARM:
                case LOC_REGPARM_ADDR:
                case LOC_BASEREG_ARG:
                case LOC_COMPUTED_ARG:
                  arg_sym = sym;
                  break;
                case LOC_UNRESOLVED:
                  break;
                default:
                  found_sym = 1;
                  add_defn_to_vec (obstackp,
                                   fixup_symbol_section (sym, objfile),
                                   block, symtab);
                  break;
                }
            }
        }
    }
  }

if (!found_sym && arg_sym != NULL((void*)0))
  {
    add_defn_to_vec (obstackp,
                     fixup_symbol_section (arg_sym, objfile),
                     block, symtab);
  }

if (!wild)
  {
    arg_sym = NULL((void*)0);
    found_sym = 0;

    ALL_BLOCK_SYMBOLS (block, iter, sym)for ((sym) = dict_iterator_first (((block)->dict), &(iter
)); (sym); (sym) = dict_iterator_next (&(iter)))
    {
      if (SYMBOL_DOMAIN (sym)(sym)->domain == domain)
        {
          int cmp;

          cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)(sym)->ginfo.name[0];
          if (cmp == 0)
            {
              cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym)(sym)->ginfo.name, 5);
              if (cmp == 0)
                cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym)(sym)->ginfo.name + 5,
                               name_len);
            }

          if (cmp == 0
              && is_name_suffix (SYMBOL_LINKAGE_NAME (sym)(sym)->ginfo.name + name_len + 5))
            {
              switch (SYMBOL_CLASS (sym)(sym)->aclass)
                {
                case LOC_ARG:
                case LOC_LOCAL_ARG:
                case LOC_REF_ARG:
                case LOC_REGPARM:
                case LOC_REGPARM_ADDR:
                case LOC_BASEREG_ARG:
                case LOC_COMPUTED_ARG:
                  arg_sym = sym;
                  break;
                case LOC_UNRESOLVED:
                  break;
                default:
                  found_sym = 1;
                  add_defn_to_vec (obstackp,
                                   fixup_symbol_section (sym, objfile),
                                   block, symtab);
                  break;
                }
            }
        }
    }

    /* NOTE: This really shouldn't be needed for _ada_ symbols.
       They aren't parameters, right?  */
    if (!found_sym && arg_sym != NULL((void*)0))
      {
        add_defn_to_vec (obstackp,
                         fixup_symbol_section (arg_sym, objfile),
                         block, symtab);
      }
  }
4927}
4928
                              /* Field Access */

4931/* True if field number FIELD_NUM in struct or union type TYPE is supposed
 to be invisible to users.  */

4934int
4935ada_is_ignored_field (struct type *type, int field_num)
4936{
if (field_num < 0 || field_num > TYPE_NFIELDS (type)(type)->main_type->nfields)
  return 1;
else
  {
    const char *name = TYPE_FIELD_NAME (type, field_num)(((type)->main_type->fields[field_num]).name);
    return (name == NULL((void*)0)
            || (name[0] == '_' && strncmp (name, "_parent", 7) != 0));
  }
4945}

4947/* True iff TYPE has a tag field.  If REFOK, then TYPE may also be a
 pointer or reference type whose ultimate target has a tag field. */

4950int
4951ada_is_tagged_type (struct type *type, int refok)
4952{
return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL((void*)0)) != NULL((void*)0));
4954}

4956/* True iff TYPE represents the type of X'Tag */

4958int
4959ada_is_tag_type (struct type *type)
4960{
if (type == NULL((void*)0) || TYPE_CODE (type)(type)->main_type->code != TYPE_CODE_PTR)
  return 0;
else
  {
    const char *name = ada_type_name (TYPE_TARGET_TYPE (type)(type)->main_type->target_type);
    return (name != NULL((void*)0)
            && strcmp (name, "ada__tags__dispatch_table") == 0);
  }
4969}

4971/* The type of the tag on VAL.  */

4973struct type *
4974ada_tag_type (struct value *val)
4975{
return ada_lookup_struct_elt_type (VALUE_TYPE (val)(val)->type, "_tag", 1, 0, NULL((void*)0));
4977}

4979/* The value of the tag on VAL.  */

4981struct value *
4982ada_value_tag (struct value *val)
4983{
return ada_value_struct_elt (val, "_tag", "record");
4985}

4987/* The value of the tag on the object of type TYPE whose contents are
 saved at VALADDR, if it is non-null, or is at memory address
 ADDRESS. */

4991static struct value *
4992value_tag_from_contents_and_address (struct type *type, char *valaddr,
                                   CORE_ADDR address)
4994{
int tag_byte_offset, dummy1, dummy2;
struct type *tag_type;
if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
                       &dummy1, &dummy2))
  {
    char *valaddr1 = (valaddr == NULL((void*)0)) ? NULL((void*)0) : valaddr + tag_byte_offset;
    CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;

    return value_from_contents_and_address (tag_type, valaddr1, address1);
  }
return NULL((void*)0);
5006}

5008static struct type *
5009type_from_tag (struct value *tag)
5010{
const char *type_name = ada_tag_name (tag);
if (type_name != NULL((void*)0))
  return ada_find_any_type (ada_encode (type_name));
return NULL((void*)0);
5015}

5017struct tag_args
5018{
struct value *tag;
char *name;
5021};

5023/* Wrapper function used by ada_tag_name.  Given a struct tag_args*
 value ARGS, sets ARGS->name to the tag name of ARGS->tag.  
 The value stored in ARGS->name is valid until the next call to 
 ada_tag_name_1.  */

5028static int
5029ada_tag_name_1 (void *args0)
5030{
struct tag_args *args = (struct tag_args *) args0;
static char name[1024];
char *p;
struct value *val;
args->name = NULL((void*)0);
val = ada_value_struct_elt (args->tag, "tsd", NULL((void*)0));
if (val == NULL((void*)0))
  return 0;
val = ada_value_struct_elt (val, "expanded_name", NULL((void*)0));
if (val == NULL((void*)0))
  return 0;
read_memory_string (value_as_address (val), name, sizeof (name) - 1);
for (p = name; *p != '\0'; p += 1)
  if (isalpha (*p))
    *p = tolower (*p);
args->name = name;
return 0;
5048}

5050/* The type name of the dynamic type denoted by the 'tag value TAG, as
* a C string.  */

5053const char *
5054ada_tag_name (struct value *tag)
5055{
struct tag_args args;
if (!ada_is_tag_type (VALUE_TYPE (tag)(tag)->type))
  return NULL((void*)0);
args.tag = tag;
args.name = NULL((void*)0);
catch_errors (ada_tag_name_1, &args, NULL((void*)0), RETURN_MASK_ALL((1 << (int)(-RETURN_QUIT)) | (1 << (int)(-RETURN_ERROR
))));
return args.name;
5063}

5065/* The parent type of TYPE, or NULL if none.  */

5067struct type *
5068ada_parent_type (struct type *type)
5069{
int i;

type = ada_check_typedef (type);

if (type == NULL((void*)0) || TYPE_CODE (type)(type)->main_type->code != TYPE_CODE_STRUCT)
  return NULL((void*)0);

for (i = 0; i < TYPE_NFIELDS (type)(type)->main_type->nfields; i += 1)
  if (ada_is_parent_field (type, i))
    return ada_check_typedef (TYPE_FIELD_TYPE (type, i)(((type)->main_type->fields[i]).type));

return NULL((void*)0);
5082}

5084/* True iff field number FIELD_NUM of structure type TYPE contains the
 parent-type (inherited) fields of a derived type.  Assumes TYPE is
 a structure type with at least FIELD_NUM+1 fields.  */

5088int
5089ada_is_parent_field (struct type *type, int field_num)
5090{
const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num)(((ada_check_typedef (type))->main_type->fields[field_num
]).name);
return (name != NULL((void*)0)
        && (strncmp (name, "PARENT", 6) == 0
            || strncmp (name, "_parent", 7) == 0));
5095}

5097/* True iff field number FIELD_NUM of structure type TYPE is a
 transparent wrapper field (which should be silently traversed when doing
 field selection and flattened when printing).  Assumes TYPE is a
 structure type with at least FIELD_NUM+1 fields.  Such fields are always
 structures.  */

5103int
5104ada_is_wrapper_field (struct type *type, int field_num)
5105{
const char *name = TYPE_FIELD_NAME (type, field_num)(((type)->main_type->fields[field_num]).name);
return (name != NULL((void*)0)
        && (strncmp (name, "PARENT", 6) == 0
            || strcmp (name, "REP") == 0
            || strncmp (name, "_parent", 7) == 0
            || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
5112}

5114/* True iff field number FIELD_NUM of structure or union type TYPE
 is a variant wrapper.  Assumes TYPE is a structure type with at least
 FIELD_NUM+1 fields.  */

5118int
5119ada_is_variant_part (struct type *type, int field_num)
5120{
struct type *field_type = TYPE_FIELD_TYPE (type, field_num)(((type)->main_type->fields[field_num]).type);
return (TYPE_CODE (field_type)(field_type)->main_type->code == TYPE_CODE_UNION
        || (is_dynamic_field (type, field_num)
            && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))((field_type)->main_type->target_type)->main_type->
code 
  == TYPE_CODE_UNION)));
5126}

5128/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
 whose discriminants are contained in the record type OUTER_TYPE,
 returns the type of the controlling discriminant for the variant.  */

5132struct type *
5133ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
5134{
char *name = ada_variant_discrim_name (var_type);
struct type *type =
  ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL((void*)0));
if (type == NULL((void*)0))
  return builtin_type_int;
else
  return type;
5142}

5144/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
 represents a 'when others' clause; otherwise 0.  */

5148int
5149ada_is_others_clause (struct type *type, int field_num)
5150{
const char *name = TYPE_FIELD_NAME (type, field_num)(((type)->main_type->fields[field_num]).name);
return (name != NULL((void*)0) && name[0] == 'O');
5153}

5155/* Assuming that TYPE0 is the type of the variant part of a record,
 returns the name of the discriminant controlling the variant.
 The value is valid until the next call to ada_variant_discrim_name.  */

5159char *
5160ada_variant_discrim_name (struct type *type0)
5161{
static char *result = NULL((void*)0);
static size_t result_len = 0;
struct type *type;
const char *name;
const char *discrim_end;
const char *discrim_start;

if (TYPE_CODE (type0)(type0)->main_type->code == TYPE_CODE_PTR)
  type = TYPE_TARGET_TYPE (type0)(type0)->main_type->target_type;
else
  type = type0;

name = ada_type_name (type);

if (name == NULL((void*)0) || name[0] == '\000')
  return "";

for (discrim_end = name + strlen (name) - 6; discrim_end != name;
     discrim_end -= 1)
  {
    if (strncmp (discrim_end, "___XVN", 6) == 0)
      break;
  }
if (discrim_end == name)
  return "";

for (discrim_start = discrim_end; discrim_start != name + 3;
     discrim_start -= 1)
  {
    if (discrim_start == name + 1)
      return "";
    if ((discrim_start > name + 3
         && strncmp (discrim_start - 3, "___", 3) == 0)
        || discrim_start[-1] == '.')
      break;
  }

GROW_VECT (result, result_len, discrim_end - discrim_start + 1)if ((result_len) < (discrim_end - discrim_start + 1)) grow_vect
 ((void**) &(result), &(result_len), (discrim_end - discrim_start
 + 1), sizeof(*(result)));;
strncpy (result, discrim_start, discrim_end - discrim_start);
result[discrim_end - discrim_start] = '\0';
return result;
5203}

5205/* Scan STR for a subtype-encoded number, beginning at position K.
 Put the position of the character just past the number scanned in
 *NEW_K, if NEW_K!=NULL.  Put the scanned number in *R, if R!=NULL.
 Return 1 if there was a valid number at the given position, and 0
 otherwise.  A "subtype-encoded" number consists of the absolute value
 in decimal, followed by the letter 'm' to indicate a negative number.
 Assumes 0m does not occur.  */

5213int
5214ada_scan_number (const char str[], int k, LONGESTlong * R, int *new_k)
5215{
ULONGESTunsigned long RU;

if (!isdigit (str[k]))
  return 0;

/* Do it the hard way so as not to make any assumption about
   the relationship of unsigned long (%lu scan format code) and
   LONGEST.  */
RU = 0;
while (isdigit (str[k]))
  {
    RU = RU * 10 + (str[k] - '0');
    k += 1;
  }

if (str[k] == 'm')
  {
    if (R != NULL((void*)0))
      *R = (-(LONGESTlong) (RU - 1)) - 1;
    k += 1;
  }
else if (R != NULL((void*)0))
  *R = (LONGESTlong) RU;

/* NOTE on the above: Technically, C does not say what the results of
   - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
   number representable as a LONGEST (although either would probably work
   in most implementations).  When RU>0, the locution in the then branch
   above is always equivalent to the negative of RU.  */

if (new_k != NULL((void*)0))
  *new_k = k;
return 1;
5249}

5251/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
 in the range encoded by field FIELD_NUM of TYPE; otherwise 0.  */

5255int
5256ada_in_variant (LONGESTlong val, struct type *type, int field_num)
5257{
const char *name = TYPE_FIELD_NAME (type, field_num)(((type)->main_type->fields[field_num]).name);
int p;

p = 0;
while (1)
  {
    switch (name[p])
      {
      case '\0':
        return 0;
      case 'S':
        {
          LONGESTlong W;
          if (!ada_scan_number (name, p + 1, &W, &p))
            return 0;
          if (val == W)
            return 1;
          break;
        }
      case 'R':
        {
          LONGESTlong L, U;
          if (!ada_scan_number (name, p + 1, &L, &p)
              || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
            return 0;
          if (val >= L && val <= U)
            return 1;
          break;
        }
      case 'O':
        return 1;
      default:
        return 0;
      }
  }
5293}

5295/* FIXME: Lots of redundancy below.  Try to consolidate. */

5297/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
 ARG_TYPE, extract and return the value of one of its (non-static)
 fields.  FIELDNO says which field.   Differs from value_primitive_field
 only in that it can handle packed values of arbitrary type.  */

5302static struct value *
5303ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
                         struct type *arg_type)
5305{
struct type *type;

arg_type = ada_check_typedef (arg_type);
type = TYPE_FIELD_TYPE (arg_type, fieldno)(((arg_type)->main_type->fields[fieldno]).type);

/* Handle packed fields.  */

if (TYPE_FIELD_BITSIZE (arg_type, fieldno)(((arg_type)->main_type->fields[fieldno]).bitsize) != 0)
  {
    int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno)(((arg_type)->main_type->fields[fieldno]).loc.bitpos);
    int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno)(((arg_type)->main_type->fields[fieldno]).bitsize);

    return ada_value_primitive_packed_val (arg1, VALUE_CONTENTS (arg1)((void)((arg1)->lazy && value_fetch_lazy(arg1)), (
(char *) (arg1)->aligner.contents + (arg1)->embedded_offset
)),
                                           offset + bit_pos / 8,
                                           bit_pos % 8, bit_size, type);
  }
else
  return value_primitive_field (arg1, offset, fieldno, arg_type);
5324}

5326/* Find field with name NAME in object of type TYPE.  If found, return 1
 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to 
 OFFSET + the byte offset of the field within an object of that type, 
 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
 Looks inside wrappers for the field.  Returns 0 if field not
 found. */
5333static int
5334find_struct_field (char *name, struct type *type, int offset,
                 struct type **field_type_p,
                 int *byte_offset_p, int *bit_offset_p, int *bit_size_p)
5337{
int i;

type = ada_check_typedef (type);
*field_type_p = NULL((void*)0);
*byte_offset_p = *bit_offset_p = *bit_size_p = 0;

for (i = TYPE_NFIELDS (type)(type)->main_type->nfields - 1; i >= 0; i -= 1)
  {
    int bit_pos = TYPE_FIELD_BITPOS (type, i)(((type)->main_type->fields[i]).loc.bitpos);
    int fld_offset = offset + bit_pos / 8;
    char *t_field_name = TYPE_FIELD_NAME (type, i)(((type)->main_type->fields[i]).name);

    if (t_field_name == NULL((void*)0))
      continue;

    else if (field_name_match (t_field_name, name))
      {
        int bit_size = TYPE_FIELD_BITSIZE (type, i)(((type)->main_type->fields[i]).bitsize);
        *field_type_p = TYPE_FIELD_TYPE (type, i)(((type)->main_type->fields[i]).type);
        *byte_offset_p = fld_offset;
        *bit_offset_p = bit_pos % 8;
        *bit_size_p = bit_size;
        return 1;
      }
    else if (ada_is_wrapper_field (type, i))
      {
        if (find_struct_field (name, TYPE_FIELD_TYPE (type, i)(((type)->main_type->fields[i]).type), fld_offset,
                               field_type_p, byte_offset_p, bit_offset_p,
                               bit_size_p))
          return 1;
      }
    else if (ada_is_variant_part (type, i))
      {
        int j;
        struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i)(((type)->main_type->fields[i]).type));

        for (j = TYPE_NFIELDS (field_type)(field_type)->main_type->nfields - 1; j >= 0; j -= 1)
          {
            if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j)(((field_type)->main_type->fields[j]).type),
                                   fld_offset
                                   + TYPE_FIELD_BITPOS (field_type, j)(((field_type)->main_type->fields[j]).loc.bitpos) / 8,
                                   field_type_p, byte_offset_p,
                                   bit_offset_p, bit_size_p))
              return 1;
          }
      }
  }
return 0;
5386}



5390/* Look for a field NAME in ARG.  Adjust the address of ARG by OFFSET bytes,
 and search in it assuming it has (class) type TYPE.
 If found, return value, else return NULL.

 Searches recursively through wrapper fields (e.g., '_parent').  */

5396static struct value *
5397ada_search_struct_field (char *name, struct value *arg, int offset,
                       struct type *type)
5399{
int i;
type = ada_check_typedef (type);

for (i = TYPE_NFIELDS (type)(type)->main_type->nfields - 1; i >= 0; i -= 1)
  {
    char *t_field_name = TYPE_FIELD_NAME (type, i)(((type)->main_type->fields[i]).name);

    if (t_field_name == NULL((void*)0))
      continue;

    else if (field_name_match (t_field_name, name))
      return ada_value_primitive_field (arg, offset, i, type);

    else if (ada_is_wrapper_field (type, i))
      {
        struct value *v =     /* Do not let indent join lines here. */
          ada_search_struct_field (name, arg,
                                   offset + TYPE_FIELD_BITPOS (type, i)(((type)->main_type->fields[i]).loc.bitpos) / 8,
                                   TYPE_FIELD_TYPE (type, i)(((type)->main_type->fields[i]).type));
        if (v != NULL((void*)0))
          return v;
      }

    else if (ada_is_variant_part (type, i))
      {
        int j;
        struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i)(((type)->main_type->fields[i]).type));
        int var_offset = offset + TYPE_FIELD_BITPOS (type, i)(((type)->main_type->fields[i]).loc.bitpos) / 8;

        for (j = TYPE_NFIELDS (field_type)(field_type)->main_type->nfields - 1; j >= 0; j -= 1)
          {
            struct value *v = ada_search_struct_field /* Force line break.  */
              (name, arg,
               var_offset + TYPE_FIELD_BITPOS (field_type, j)(((field_type)->main_type->fields[j]).loc.bitpos) / 8,
               TYPE_FIELD_TYPE (field_type, j)(((field_type)->main_type->fields[j]).type));
            if (v != NULL((void*)0))
              return v;
          }
      }
  }
return NULL((void*)0);
5441}

5443/* Given ARG, a value of type (pointer or reference to a)*
 structure/union, extract the component named NAME from the ultimate
 target structure/union and return it as a value with its
 appropriate type.  If ARG is a pointer or reference and the field
 is not packed, returns a reference to the field, otherwise the
 value of the field (an lvalue if ARG is an lvalue).     

 The routine searches for NAME among all members of the structure itself
 and (recursively) among all members of any wrapper members
 (e.g., '_parent').

 ERR is a name (for use in error messages) that identifies the class
 of entity that ARG is supposed to be.  ERR may be null, indicating
 that on error, the function simply returns NULL, and does not
 throw an error.  (FIXME: True only if ARG is a pointer or reference
 at the moment). */

5460struct value *
5461ada_value_struct_elt (struct value *arg, char *name, char *err)
5462{
struct type *t, *t1;
struct value *v;

v = NULL((void*)0);
t1 = t = ada_check_typedef (VALUE_TYPE (arg)(arg)->type);
if (TYPE_CODE (t)(t)->main_type->code == TYPE_CODE_REF)
  {
    t1 = TYPE_TARGET_TYPE (t)(t)->main_type->target_type;
    if (t1 == NULL((void*)0))
      {
        if (err == NULL((void*)0))
          return NULL((void*)0);
        else
          error ("Bad value type in a %s.", err);
      }
    t1 = ada_check_typedef (t1);
    if (TYPE_CODE (t1)(t1)->main_type->code == TYPE_CODE_PTR)
      {
        COERCE_REF (arg)do { struct type *value_type_arg_tmp = check_typedef ((arg)->
type); if ((value_type_arg_tmp)->main_type->code == TYPE_CODE_REF
) arg = value_at_lazy ((value_type_arg_tmp)->main_type->
target_type, unpack_pointer ((arg)->type, ((void)((arg)->
lazy && value_fetch_lazy(arg)), ((char *) (arg)->aligner
.contents + (arg)->embedded_offset))), ((arg)->bfd_section
)); } while (0);
        t = t1;
      }
  }

while (TYPE_CODE (t)(t)->main_type->code == TYPE_CODE_PTR)
  {
    t1 = TYPE_TARGET_TYPE (t)(t)->main_type->target_type;
    if (t1 == NULL((void*)0))
      {
        if (err == NULL((void*)0))
          return NULL((void*)0);
        else
          error ("Bad value type in a %s.", err);
      }
    t1 = ada_check_typedef (t1);
    if (TYPE_CODE (t1)(t1)->main_type->code == TYPE_CODE_PTR)
      {
        arg = value_ind (arg);
        t = t1;
      }
    else
      break;
  }

if (TYPE_CODE (t1)(t1)->main_type->code != TYPE_CODE_STRUCT && TYPE_CODE (t1)(t1)->main_type->code != TYPE_CODE_UNION)
  {
    if (err == NULL((void*)0))
      return NULL((void*)0);
    else
      error ("Attempt to extract a component of a value that is not a %s.",
             err);
  }

if (t1 == t)
  v = ada_search_struct_field (name, arg, 0, t);
else
  {
    int bit_offset, bit_size, byte_offset;
    struct type *field_type;
    CORE_ADDR address;

    if (TYPE_CODE (t)(t)->main_type->code == TYPE_CODE_PTR)
      address = value_as_address (arg);
    else
      address = unpack_pointer (t, VALUE_CONTENTS (arg)((void)((arg)->lazy && value_fetch_lazy(arg)), ((char
 *) (arg)->aligner.contents + (arg)->embedded_offset)));

    t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL((void*)0), address, NULL((void*)0));
    if (find_struct_field (name, t1, 0,
                           &field_type, &byte_offset, &bit_offset,
                           &bit_size))
      {
        if (bit_size != 0)
          {
            if (TYPE_CODE (t)(t)->main_type->code == TYPE_CODE_REF)
              arg = ada_coerce_ref (arg);
            else
              arg = ada_value_ind (arg);
            v = ada_value_primitive_packed_val (arg, NULL((void*)0), byte_offset,
                                                bit_offset, bit_size,
                                                field_type);
          }
        else
          v = value_from_pointer (lookup_reference_type (field_type),
                                  address + byte_offset);
      }
  }

if (v == NULL((void*)0) && err != NULL((void*)0))
  error ("There is no member named %s.", name);

return v;
5553}

5555/* Given a type TYPE, look up the type of the component of type named NAME.
 If DISPP is non-null, add its byte displacement from the beginning of a
 structure (pointed to by a value) of type TYPE to *DISPP (does not
 work for packed fields).

 Matches any field whose name has NAME as a prefix, possibly
 followed by "___".

 TYPE can be either a struct or union. If REFOK, TYPE may also 
 be a (pointer or reference)+ to a struct or union, and the
 ultimate target type will be searched.

 Looks recursively into variant clauses and parent types.

 If NOERR is nonzero, return NULL if NAME is not suitably defined or
 TYPE is not a type of the right kind.  */

5572static struct type *
5573ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
                          int noerr, int *dispp)
5575{
int i;

if (name == NULL((void*)0))
  goto BadName;

if (refok && type != NULL((void*)0))
  while (1)
    {
      type = ada_check_typedef (type);
      if (TYPE_CODE (type)(type)->main_type->code != TYPE_CODE_PTR
          && TYPE_CODE (type)(type)->main_type->code != TYPE_CODE_REF)
        break;
      type = TYPE_TARGET_TYPE (type)(type)->main_type->target_type;
    }

if (type == NULL((void*)0)
    || (TYPE_CODE (type)(type)->main_type->code != TYPE_CODE_STRUCT
        && TYPE_CODE (type)(type)->main_type->code != TYPE_CODE_UNION))
  {
    if (noerr)
      return NULL((void*)0);
    else
      {
        target_terminal_ours ()(*current_target.to_terminal_ours) ();
        gdb_flush (gdb_stdout);
        fprintf_unfiltered (gdb_stderr, "Type ");
        if (type == NULL((void*)0))
          fprintf_unfiltered (gdb_stderr, "(null)");
        else
          type_print (type, "", gdb_stderr, -1);
        error (" is not a structure or union type");
      }
  }

type = to_static_fixed_type (type);

for (i = 0; i < TYPE_NFIELDS (type)(type)->main_type->nfields; i += 1)
  {
    char *t_field_name = TYPE_FIELD_NAME (type, i)(((type)->main_type->fields[i]).name);
    struct type *t;
    int disp;

    if (t_field_name == NULL((void*)0))
      continue;

    else if (field_name_match (t_field_name, name))
      {
        if (dispp != NULL((void*)0))
          *dispp += TYPE_FIELD_BITPOS (type, i)(((type)->main_type->fields[i]).loc.bitpos) / 8;
        return ada_check_typedef (TYPE_FIELD_TYPE (type, i)(((type)->main_type->fields[i]).type));
      }

    else if (ada_is_wrapper_field (type, i))
      {
        disp = 0;
        t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i)(((type)->main_type->fields[i]).type), name,
                                        0, 1, &disp);
        if (t != NULL((void*)0))
          {
            if (dispp != NULL((void*)0))
              *dispp += disp + TYPE_FIELD_BITPOS (type, i)(((type)->main_type->fields[i]).loc.bitpos) / 8;
            return t;
          }
      }

    else if (ada_is_variant_part (type, i))
      {
        int j;
        struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i)(((type)->main_type->fields[i]).type));

        for (j = TYPE_NFIELDS (field_type)(field_type)->main_type->nfields - 1; j >= 0; j -= 1)
          {
            disp = 0;
            t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j)(((field_type)->main_type->fields[j]).type),
                                            name, 0, 1, &disp);
            if (t != NULL((void*)0))
              {
                if (dispp != NULL((void*)0))
                  *dispp += disp + TYPE_FIELD_BITPOS (type, i)(((type)->main_type->fields[i]).loc.bitpos) / 8;
                return t;
              }
          }
      }

  }

5662BadName:
if (!noerr)
  {
    target_terminal_ours ()(*current_target.to_terminal_ours) ();
    gdb_flush (gdb_stdout);
    fprintf_unfiltered (gdb_stderr, "Type ");
    type_print (type, "", gdb_stderr, -1);
    fprintf_unfiltered (gdb_stderr, " has no component named ");
    error ("%s", name == NULL((void*)0) ? "<null>" : name);
  }

return NULL((void*)0);
5674}

5676/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
 within a value of type OUTER_TYPE that is stored in GDB at
 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
 numbering from 0) is applicable.  Returns -1 if none are.  */

5681int
5682ada_which_variant_applies (struct type *var_type, struct type *outer_type,
                         char *outer_valaddr)
5684{
int others_clause;
int i;
int disp;
struct type *discrim_type;
char *discrim_name = ada_variant_discrim_name (var_type);
LONGESTlong discrim_val;

disp = 0;
discrim_type =
  ada_lookup_struct_elt_type (outer_type, discrim_name, 1, 1, &disp);
if (discrim_type == NULL((void*)0))
  return -1;
discrim_val = unpack_long (discrim_type, outer_valaddr + disp);

others_clause = -1;
for (i = 0; i < TYPE_NFIELDS (var_type)(var_type)->main_type->nfields; i += 1)
  {
    if (ada_is_others_clause (var_type, i))
      others_clause = i;
    else if (ada_in_variant (discrim_val, var_type, i))
      return i;
  }

return others_clause;
5709}
5710


                              /* Dynamic-Sized Records */

5715/* Strategy: The type ostensibly attached to a value with dynamic size
 (i.e., a size that is not statically recorded in the debugging
 data) does not accurately reflect the size or layout of the value.
 Our strategy is to convert these values to values with accurate,
 conventional types that are constructed on the fly.  */

5721/* There is a subtle and tricky problem here.  In general, we cannot
 determine the size of dynamic records without its data.  However,
 the 'struct value' data structure, which GDB uses to represent
 quantities in the inferior process (the target), requires the size
 of the type at the time of its allocation in order to reserve space
 for GDB's internal copy of the data.  That's why the
 'to_fixed_xxx_type' routines take (target) addresses as parameters,
 rather than struct value*s.

 However, GDB's internal history variables ($1, $2, etc.) are
 struct value*s containing internal copies of the data that are not, in
 general, the same as the data at their corresponding addresses in
 the target.  Fortunately, the types we give to these values are all
 conventional, fixed-size types (as per the strategy described
 above), so that we don't usually have to perform the
 'to_fixed_xxx_type' conversions to look at their values.
 Unfortunately, there is one exception: if one of the internal
 history variables is an array whose elements are unconstrained
 records, then we will need to create distinct fixed types for each
 element selected.  */

5742/* The upshot of all of this is that many routines take a (type, host
 address, target address) triple as arguments to represent a value.
 The host address, if non-null, is supposed to contain an internal
 copy of the relevant data; otherwise, the program is to consult the
 target at the target address.  */

5748/* Assuming that VAL0 represents a pointer value, the result of
 dereferencing it.  Differs from value_ind in its treatment of
 dynamic-sized types.  */

5752struct value *
5753ada_value_ind (struct value *val0)
5754{
struct value *val = unwrap_value (value_ind (val0));
return ada_to_fixed_value (val);
5757}

5759/* The value resulting from dereferencing any "reference to"
 qualifiers on VAL0.  */

5762static struct value *
5763ada_coerce_ref (struct value *val0)
5764{
if (TYPE_CODE (VALUE_TYPE (val0))((val0)->type)->main_type->code == TYPE_CODE_REF)
  {
    struct value *val = val0;
    COERCE_REF (val)do { struct type *value_type_arg_tmp = check_typedef ((val)->
type); if ((value_type_arg_tmp)->main_type->code == TYPE_CODE_REF
) val = value_at_lazy ((value_type_arg_tmp)->main_type->
target_type, unpack_pointer ((val)->type, ((void)((val)->
lazy && value_fetch_lazy(val)), ((char *) (val)->aligner
.contents + (val)->embedded_offset))), ((val)->bfd_section
)); } while (0);
    val = unwrap_value (val);
    return ada_to_fixed_value (val);
  }
else
  return val0;
5774}

5776/* Return OFF rounded upward if necessary to a multiple of
 ALIGNMENT (a power of 2).  */

5779static unsigned int
5780align_value (unsigned int off, unsigned int alignment)
5781{
return (off + alignment - 1) & ~(alignment - 1);
5783}

5785/* Return the bit alignment required for field #F of template type TYPE.  */

5787static unsigned int
5788field_alignment (struct type *type, int f)
5789{
const char *name = TYPE_FIELD_NAME (type, f)(((type)->main_type->fields[f]).name);
int len = (name == NULL((void*)0)) ? 0 : strlen (name);
int align_offset;

if (!isdigit (name[len - 1]))
  return 1;

if (isdigit (name[len - 2]))
  align_offset = len - 2;
else
  align_offset = len - 1;

if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
  return TARGET_CHAR_BIT8;

return atoi (name + align_offset) * TARGET_CHAR_BIT8;
5806}

5808/* Find a symbol named NAME.  Ignores ambiguity.  */

5810struct symbol *
5811ada_find_any_symbol (const char *name)
5812{
struct symbol *sym;

sym = standard_lookup (name, get_selected_block (NULL((void*)0)), VAR_DOMAIN);
if (sym != NULL((void*)0) && SYMBOL_CLASS (sym)(sym)->aclass == LOC_TYPEDEF)
  return sym;

sym = standard_lookup (name, NULL((void*)0), STRUCT_DOMAIN);
return sym;
5821}

5823/* Find a type named NAME.  Ignores ambiguity.  */

5825struct type *
5826ada_find_any_type (const char *name)
5827{
struct symbol *sym = ada_find_any_symbol (name);

if (sym != NULL((void*)0))
  return SYMBOL_TYPE (sym)(sym)->type;

return NULL((void*)0);
5834}

5836/* Given a symbol NAME and its associated BLOCK, search all symbols
 for its ___XR counterpart, which is the ``renaming'' symbol
 associated to NAME.  Return this symbol if found, return
 NULL otherwise.  */

5841struct symbol *
5842ada_find_renaming_symbol (const char *name, struct block *block)
5843{
const struct symbol *function_sym = block_function (block);
char *rename;

if (function_sym != NULL((void*)0))
  {
    /* If the symbol is defined inside a function, NAME is not fully
       qualified.  This means we need to prepend the function name
       as well as adding the ``___XR'' suffix to build the name of
       the associated renaming symbol.  */
    char *function_name = SYMBOL_LINKAGE_NAME (function_sym)(function_sym)->ginfo.name;
    const int function_name_len = strlen (function_name);
    const int rename_len = function_name_len + 2      /*  "__" */
      + strlen (name) + 6 /* "___XR\0" */ ;

    /* Library-level functions are a special case, as GNAT adds
       a ``_ada_'' prefix to the function name to avoid namespace
       pollution.  However, the renaming symbol themselves do not
       have this prefix, so we need to skip this prefix if present.  */
    if (function_name_len > 5 /* "_ada_" */
        && strstr (function_name, "_ada_") == function_name)
      function_name = function_name + 5;

    rename = (char *) alloca (rename_len * sizeof (char))__builtin_alloca(rename_len * sizeof (char));
    sprintf (rename, "%s__%s___XR", function_name, name);
  }
else
  {
    const int rename_len = strlen (name) + 6;
    rename = (char *) alloca (rename_len * sizeof (char))__builtin_alloca(rename_len * sizeof (char));
    sprintf (rename, "%s___XR", name);
  }

return ada_find_any_symbol (rename);
5877}

5879/* Because of GNAT encoding conventions, several GDB symbols may match a
 given type name.  If the type denoted by TYPE0 is to be preferred to
 that of TYPE1 for purposes of type printing, return non-zero;
 otherwise return 0.  */

5884int
5885ada_prefer_type (struct type *type0, struct type *type1)
5886{
if (type1 == NULL((void*)0))
  return 1;
else if (type0 == NULL((void*)0))
  return 0;
else if (TYPE_CODE (type1)(type1)->main_type->code == TYPE_CODE_VOID)
  return 1;
else if (TYPE_CODE (type0)(type0)->main_type->code == TYPE_CODE_VOID)
  return 0;
else if (TYPE_NAME (type1)(type1)->main_type->name == NULL((void*)0) && TYPE_NAME (type0)(type0)->main_type->name != NULL((void*)0))
  return 1;
else if (ada_is_packed_array_type (type0))
  return 1;
else if (ada_is_array_descriptor_type (type0)
         && !ada_is_array_descriptor_type (type1))
  return 1;
else if (ada_renaming_type (type0) != NULL((void*)0)
         && ada_renaming_type (type1) == NULL((void*)0))
  return 1;
return 0;
5906}

5908/* The name of TYPE, which is either its TYPE_NAME, or, if that is
 null, its TYPE_TAG_NAME.  Null if TYPE is null.  */

5911char *
5912ada_type_name (struct type *type)
5913{
if (type == NULL((void*)0))
  return NULL((void*)0);
else if (TYPE_NAME (type)(type)->main_type->name != NULL((void*)0))
  return TYPE_NAME (type)(type)->main_type->name;
else
  return TYPE_TAG_NAME (type)(type)->main_type->tag_name;
5920}

5922/* Find a parallel type to TYPE whose name is formed by appending
 SUFFIX to the name of TYPE.  */

5925struct type *
5926ada_find_parallel_type (struct type *type, const char *suffix)
5927{
static char *name;
static size_t name_len = 0;
int len;
char *typename = ada_type_name (type);

if (typename == NULL((void*)0))
  return NULL((void*)0);

len = strlen (typename);

GROW_VECT (name, name_len, len + strlen (suffix) + 1)if ((name_len) < (len + strlen (suffix) + 1)) grow_vect ((
void**) &(name), &(name_len), (len + strlen (suffix) +
 1), sizeof(*(name)));;

strcpy (name, typename);
strcpy (name + len, suffix);

return ada_find_any_type (name);
5944}


5947/* If TYPE is a variable-size record type, return the corresponding template
 type describing its fields.  Otherwise, return NULL.  */

5950static struct type *
5951dynamic_template_type (struct type *type)
5952{
type = ada_check_typedef (type);

if (type == NULL((void*)0) || TYPE_CODE (type)(type)->main_type->code != TYPE_CODE_STRUCT
    || ada_type_name (type) == NULL((void*)0))
  return NULL((void*)0);
else
  {
    int len = strlen (ada_type_name (type));
    if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
      return type;
    else
      return ada_find_parallel_type (type, "___XVE");
  }
5966}

5968/* Assuming that TEMPL_TYPE is a union or struct type, returns
 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size.  */

5971static int
5972is_dynamic_field (struct type *templ_type, int field_num)
5973{
const char *name = TYPE_FIELD_NAME (templ_type, field_num)(((templ_type)->main_type->fields[field_num]).name);
return name != NULL((void*)0)
  && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num))((((templ_type)->main_type->fields[field_num]).type))->
main_type->code == TYPE_CODE_PTR
  && strstr (name, "___XVL") != NULL((void*)0);
5978}

5980/* The index of the variant field of TYPE, or -1 if TYPE does not
 represent a variant record type.  */

5983static int
5984variant_field_index (struct type *type)
5985{
int f;

if (type == NULL((void*)0) || TYPE_CODE (type)(type)->main_type->code != TYPE_CODE_STRUCT)
  return -1;

for (f = 0; f < TYPE_NFIELDS (type)(type)->main_type->nfields; f += 1)
  {
    if (ada_is_variant_part (type, f))
      return f;
  }
return -1;
5997}

5999/* A record type with no fields.  */

6001static struct type *
6002empty_record (struct objfile *objfile)
6003{
struct type *type = alloc_type (objfile);
TYPE_CODE (type)(type)->main_type->code = TYPE_CODE_STRUCT;
TYPE_NFIELDS (type)(type)->main_type->nfields = 0;
TYPE_FIELDS (type)(type)->main_type->fields = NULL((void*)0);
TYPE_NAME (type)(type)->main_type->name = "<empty>";
TYPE_TAG_NAME (type)(type)->main_type->tag_name = NULL((void*)0);
TYPE_FLAGS (type)(type)->main_type->flags = 0;
TYPE_LENGTH (type)(type)->length = 0;
return type;
6013}

6015/* An ordinary record type (with fixed-length fields) that describes
 the value of type TYPE at VALADDR or ADDRESS (see comments at
 the beginning of this section) VAL according to GNAT conventions.
 DVAL0 should describe the (portion of a) record that contains any
 necessary discriminants.  It should be NULL if VALUE_TYPE (VAL) is
 an outer-level type (i.e., as opposed to a branch of a variant.)  A
 variant field (unless unchecked) is replaced by a particular branch
 of the variant.

 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
 length are not statically known are discarded.  As a consequence,
 VALADDR, ADDRESS and DVAL0 are ignored.

 NOTE: Limitations: For now, we assume that dynamic fields and
 variants occupy whole numbers of bytes.  However, they need not be
 byte-aligned.  */

6032struct type *
6033ada_template_to_fixed_record_type_1 (struct type *type, char *valaddr,
                                   CORE_ADDR address, struct value *dval0,
                                   int keep_dynamic_fields)
6036{
struct value *mark = value_mark ();
struct value *dval;
struct type *rtype;
int nfields, bit_len;
int variant_field;
long off;
int fld_bit_len, bit_incr;
int f;

/* Compute the number of fields in this record type that are going
   to be processed: unless keep_dynamic_fields, this includes only
   fields whose position and length are static will be processed.  */
if (keep_dynamic_fields)
  nfields = TYPE_NFIELDS (type)(type)->main_type->nfields;
else
  {
    nfields = 0;
    while (nfields < TYPE_NFIELDS (type)(type)->main_type->nfields
           && !ada_is_variant_part (type, nfields)
           && !is_dynamic_field (type, nfields))
      nfields++;
  }

rtype = alloc_type (TYPE_OBJFILE (type)(type)->main_type->objfile);
TYPE_CODE (rtype)(rtype)->main_type->code = TYPE_CODE_STRUCT;
INIT_CPLUS_SPECIFIC (rtype)((rtype)->main_type->type_specific.cplus_stuff=(struct cplus_struct_type
*)&cplus_struct_default);
TYPE_NFIELDS (rtype)(rtype)->main_type->nfields = nfields;
TYPE_FIELDS (rtype)(rtype)->main_type->fields = (struct field *)
  TYPE_ALLOC (rtype, nfields * sizeof (struct field))((rtype)->main_type->objfile != ((void*)0) ? __extension__
 ({ struct obstack *__h = (&(rtype)->main_type->objfile
 -> objfile_obstack); __extension__ ({ struct obstack *__o
 = (__h); int __len = ((nfields * sizeof (struct field))); if
 (__o->chunk_limit - __o->next_free < __len) _obstack_newchunk
 (__o, __len); ((__o)->next_free += (__len)); (void) 0; })
; __extension__ ({ struct obstack *__o1 = (__h); void *value;
 value = (void *) __o1->object_base; if (__o1->next_free
 == value) __o1->maybe_empty_object = 1; __o1->next_free
 = (((((__o1->next_free) - (char *) 0)+__o1->alignment_mask
) & ~ (__o1->alignment_mask)) + (char *) 0); if (__o1->
next_free - (char *)__o1->chunk > __o1->chunk_limit -
 (char *)__o1->chunk) __o1->next_free = __o1->chunk_limit
; __o1->object_base = __o1->next_free; value; }); }) : xmalloc
 (nfields * sizeof (struct field)));
memset (TYPE_FIELDS (rtype)(rtype)->main_type->fields, 0, sizeof (struct field) * nfields);
TYPE_NAME (rtype)(rtype)->main_type->name = ada_type_name (type);
TYPE_TAG_NAME (rtype)(rtype)->main_type->tag_name = NULL((void*)0);
TYPE_FLAGS (rtype)(rtype)->main_type->flags |= TYPE_FLAG_FIXED_INSTANCE(1 << 15);

off = 0;
bit_len = 0;
variant_field = -1;

for (f = 0; f < nfields; f += 1)
  {
    off = align_value (off, field_alignment (type, f))
+ TYPE_FIELD_BITPOS (type, f)(((type)->main_type->fields[f]).loc.bitpos);
    TYPE_FIELD_BITPOS (rtype, f)(((rtype)->main_type->fields[f]).loc.bitpos) = off;
    TYPE_FIELD_BITSIZE (rtype, f)(((rtype)->main_type->fields[f]).bitsize) = 0;

    if (ada_is_variant_part (type, f))
      {
        variant_field = f;
        fld_bit_len = bit_incr = 0;
      }
    else if (is_dynamic_field (type, f))
      {
        if (dval0 == NULL((void*)0))
          dval = value_from_contents_and_address (rtype, valaddr, address);
        else
          dval = dval0;

        TYPE_FIELD_TYPE (rtype, f)(((rtype)->main_type->fields[f]).type) =
          ada_to_fixed_type
          (ada_get_base_type
           (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))((((type)->main_type->fields[f]).type))->main_type->
target_type),
           cond_offset_host (valaddr, off / TARGET_CHAR_BIT8),
           cond_offset_target (address, off / TARGET_CHAR_BIT8), dval);
        TYPE_FIELD_NAME (rtype, f)(((rtype)->main_type->fields[f]).name) = TYPE_FIELD_NAME (type, f)(((type)->main_type->fields[f]).name);
        bit_incr = fld_bit_len =
          TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f))((((rtype)->main_type->fields[f]).type))->length * TARGET_CHAR_BIT8;
      }
    else
      {
        TYPE_FIELD_TYPE (rtype, f)(((rtype)->main_type->fields[f]).type) = TYPE_FIELD_TYPE (type, f)(((type)->main_type->fields[f]).type);
        TYPE_FIELD_NAME (rtype, f)(((rtype)->main_type->fields[f]).name) = TYPE_FIELD_NAME (type, f)(((type)->main_type->fields[f]).name);
        if (TYPE_FIELD_BITSIZE (type, f)(((type)->main_type->fields[f]).bitsize) > 0)
          bit_incr = fld_bit_len =
            TYPE_FIELD_BITSIZE (rtype, f)(((rtype)->main_type->fields[f]).bitsize) = TYPE_FIELD_BITSIZE (type, f)(((type)->main_type->fields[f]).bitsize);
        else
          bit_incr = fld_bit_len =
            TYPE_LENGTH (TYPE_FIELD_TYPE (type, f))((((type)->main_type->fields[f]).type))->length * TARGET_CHAR_BIT8;
      }
    if (off + fld_bit_len > bit_len)
      bit_len = off + fld_bit_len;
    off += bit_incr;
    TYPE_LENGTH (rtype)(rtype)->length =
      align_value (bit_len, TARGET_CHAR_BIT8) / TARGET_CHAR_BIT8;
  }

/* We handle the variant part, if any, at the end because of certain
   odd cases in which it is re-ordered so as NOT the last field of
   the record.  This can happen in the presence of representation
   clauses.  */
if (variant_field >= 0)
  {
    struct type *branch_type;

    off = TYPE_FIELD_BITPOS (rtype, variant_field)(((rtype)->main_type->fields[variant_field]).loc.bitpos
);

    if (dval0 == NULL((void*)0))
      dval = value_from_contents_and_address (rtype, valaddr, address);
    else
      dval = dval0;

    branch_type =
      to_fixed_variant_branch_type
      (TYPE_FIELD_TYPE (type, variant_field)(((type)->main_type->fields[variant_field]).type),
       cond_offset_host (valaddr, off / TARGET_CHAR_BIT8),
       cond_offset_target (address, off / TARGET_CHAR_BIT8), dval);
    if (branch_type == NULL((void*)0))
      {
        for (f = variant_field + 1; f < TYPE_NFIELDS (rtype)(rtype)->main_type->nfields; f += 1)
          TYPE_FIELDS (rtype)(rtype)->main_type->fields[f - 1] = TYPE_FIELDS (rtype)(rtype)->main_type->fields[f];
        TYPE_NFIELDS (rtype)(rtype)->main_type->nfields -= 1;
      }
    else
      {
        TYPE_FIELD_TYPE (rtype, variant_field)(((rtype)->main_type->fields[variant_field]).type) = branch_type;
        TYPE_FIELD_NAME (rtype, variant_field)(((rtype)->main_type->fields[variant_field]).name) = "S";
        fld_bit_len =
          TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field))((((rtype)->main_type->fields[variant_field]).type))->
length *
          TARGET_CHAR_BIT8;
        if (off + fld_bit_len > bit_len)
          bit_len = off + fld_bit_len;
        TYPE_LENGTH (rtype)(rtype)->length =
          align_value (bit_len, TARGET_CHAR_BIT8) / TARGET_CHAR_BIT8;
      }
  }

/* According to exp_dbug.ads, the size of TYPE for variable-size records
   should contain the alignment of that record, which should be a strictly
   positive value.  If null or negative, then something is wrong, most
   probably in the debug info.  In that case, we don't round up the size
   of the resulting type. If this record is not part of another structure,
   the current RTYPE length might be good enough for our purposes.  */
if (TYPE_LENGTH (type)(type)->length <= 0)
  {
    warning ("Invalid type size for `%s' detected: %d.",
             TYPE_NAME (rtype)(rtype)->main_type->name ? TYPE_NAME (rtype)(rtype)->main_type->name : "<unnamed>",
             TYPE_LENGTH (type)(type)->length);
  }
else
  {
    TYPE_LENGTH (rtype)(rtype)->length = align_value (TYPE_LENGTH (rtype)(rtype)->length,
                                       TYPE_LENGTH (type)(type)->length);
  }

value_free_to_mark (mark);
if (TYPE_LENGTH (rtype)(rtype)->length > varsize_limit)
  error ("record type with dynamic size is larger than varsize-limit");
return rtype;
6184}

6186/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
 of 1.  */

6189static struct type *
6190template_to_fixed_record_type (struct type *type, char *valaddr,
                             CORE_ADDR address, struct value *dval0)
6192{
return ada_template_to_fixed_record_type_1 (type, valaddr,
                                            address, dval0, 1);
6195}

6197/* An ordinary record type in which ___XVL-convention fields and
 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
 static approximations, containing all possible fields.  Uses
 no runtime values.  Useless for use in values, but that's OK,
 since the results are used only for type determinations.   Works on both
 structs and unions.  Representation note: to save space, we memorize
 the result of this function in the TYPE_TARGET_TYPE of the
 template type.  */

6206static struct type *
6207template_to_static_fixed_type (struct type *type0)
6208{
struct type *type;
int nfields;
int f;

if (TYPE_TARGET_TYPE (type0)(type0)->main_type->target_type != NULL((void*)0))
  return TYPE_TARGET_TYPE (type0)(type0)->main_type->target_type;

nfields = TYPE_NFIELDS (type0)(type0)->main_type->nfields;
type = type0;

for (f = 0; f < nfields; f += 1)
  {
    struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f)(((type0)->main_type->fields[f]).type));
    struct type *new_type;

    if (is_dynamic_field (type0, f))
      new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type)(field_type)->main_type->target_type);
    else
      new_type = to_static_fixed_type (field_type);
    if (type == type0 && new_type != field_type)
      {
        TYPE_TARGET_TYPE (type0)(type0)->main_type->target_type = type = alloc_type (TYPE_OBJFILE (type0)(type0)->main_type->objfile);
        TYPE_CODE (type)(type)->main_type->code = TYPE_CODE (type0)(type0)->main_type->code;
        INIT_CPLUS_SPECIFIC (type)((type)->main_type->type_specific.cplus_stuff=(struct cplus_struct_type
*)&cplus_struct_default);
        TYPE_NFIELDS (type)(type)->main_type->nfields = nfields;
        TYPE_FIELDS (type)(type)->main_type->fields = (struct field *)
          TYPE_ALLOC (type, nfields * sizeof (struct field))((type)->main_type->objfile != ((void*)0) ? __extension__
 ({ struct obstack *__h = (&(type)->main_type->objfile
 -> objfile_obstack); __extension__ ({ struct obstack *__o
 = (__h); int __len = ((nfields * sizeof (struct field))); if
 (__o->chunk_limit - __o->next_free < __len) _obstack_newchunk
 (__o, __len); ((__o)->next_free += (__len)); (void) 0; })
; __extension__ ({ struct obstack *__o1 = (__h); void *value;
 value = (void *) __o1->object_base; if (__o1->next_free
 == value) __o1->maybe_empty_object = 1; __o1->next_free
 = (((((__o1->next_free) - (char *) 0)+__o1->alignment_mask
) & ~ (__o1->alignment_mask)) + (char *) 0); if (__o1->
next_free - (char *)__o1->chunk > __o1->chunk_limit -
 (char *)__o1->chunk) __o1->next_free = __o1->chunk_limit
; __o1->object_base = __o1->next_free; value; }); }) : xmalloc
 (nfields * sizeof (struct field)));
        memcpy (TYPE_FIELDS (type)(type)->main_type->fields, TYPE_FIELDS (type0)(type0)->main_type->fields,
                sizeof (struct field) * nfields);
        TYPE_NAME (type)(type)->main_type->name = ada_type_name (type0);
        TYPE_TAG_NAME (type)(type)->main_type->tag_name = NULL((void*)0);
        TYPE_FLAGS (type)(type)->main_type->flags |= TYPE_FLAG_FIXED_INSTANCE(1 << 15);
        TYPE_LENGTH (type)(type)->length = 0;
      }
    TYPE_FIELD_TYPE (type, f)(((type)->main_type->fields[f]).type) = new_type;
    TYPE_FIELD_NAME (type, f)(((type)->main_type->fields[f]).name) = TYPE_FIELD_NAME (type0, f)(((type0)->main_type->fields[f]).name);
  }
return type;
6247}

6249/* Given an object of type TYPE whose contents are at VALADDR and
 whose address in memory is ADDRESS, returns a revision of TYPE --
 a non-dynamic-sized record with a variant part -- in which
 the variant part is replaced with the appropriate branch.  Looks
 for discriminant values in DVAL0, which can be NULL if the record
 contains the necessary discriminant values.  */

6256static struct type *
6257to_record_with_fixed_variant_part (struct type *type, char *valaddr,
                                 CORE_ADDR address, struct value *dval0)
6259{
struct value *mark = value_mark ();
struct value *dval;
struct type *rtype;
struct type *branch_type;
int nfields = TYPE_NFIELDS (type)(type)->main_type->nfields;
int variant_field = variant_field_index (type);

if (variant_field == -1)
  return type;

if (dval0 == NULL((void*)0))
  dval = value_from_contents_and_address (type, valaddr, address);
else
  dval = dval0;

rtype = alloc_type (TYPE_OBJFILE (type)(type)->main_type->objfile);
TYPE_CODE (rtype)(rtype)->main_type->code = TYPE_CODE_STRUCT;
INIT_CPLUS_SPECIFIC (rtype)((rtype)->main_type->type_specific.cplus_stuff=(struct cplus_struct_type
*)&cplus_struct_default);
TYPE_NFIELDS (rtype)(rtype)->main_type->nfields = nfields;
TYPE_FIELDS (rtype)(rtype)->main_type->fields =
  (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field))((rtype)->main_type->objfile != ((void*)0) ? __extension__
 ({ struct obstack *__h = (&(rtype)->main_type->objfile
 -> objfile_obstack); __extension__ ({ struct obstack *__o
 = (__h); int __len = ((nfields * sizeof (struct field))); if
 (__o->chunk_limit - __o->next_free < __len) _obstack_newchunk
 (__o, __len); ((__o)->next_free += (__len)); (void) 0; })
; __extension__ ({ struct obstack *__o1 = (__h); void *value;
 value = (void *) __o1->object_base; if (__o1->next_free
 == value) __o1->maybe_empty_object = 1; __o1->next_free
 = (((((__o1->next_free) - (char *) 0)+__o1->alignment_mask
) & ~ (__o1->alignment_mask)) + (char *) 0); if (__o1->
next_free - (char *)__o1->chunk > __o1->chunk_limit -
 (char *)__o1->chunk) __o1->next_free = __o1->chunk_limit
; __o1->object_base = __o1->next_free; value; }); }) : xmalloc
 (nfields * sizeof (struct field)));
memcpy (TYPE_FIELDS (rtype)(rtype)->main_type->fields, TYPE_FIELDS (type)(type)->main_type->fields,
        sizeof (struct field) * nfields);
TYPE_NAME (rtype)(rtype)->main_type->name = ada_type_name (type);
TYPE_TAG_NAME (rtype)(rtype)->main_type->tag_name = NULL((void*)0);
TYPE_FLAGS (rtype)(rtype)->main_type->flags |= TYPE_FLAG_FIXED_INSTANCE(1 << 15);
TYPE_LENGTH (rtype)(rtype)->length = TYPE_LENGTH (type)(type)->length;

branch_type = to_fixed_variant_branch_type
  (TYPE_FIELD_TYPE (type, variant_field)(((type)->main_type->fields[variant_field]).type),
   cond_offset_host (valaddr,
                     TYPE_FIELD_BITPOS (type, variant_field)(((type)->main_type->fields[variant_field]).loc.bitpos)
                     / TARGET_CHAR_BIT8),
   cond_offset_target (address,
                       TYPE_FIELD_BITPOS (type, variant_field)(((type)->main_type->fields[variant_field]).loc.bitpos)
                       / TARGET_CHAR_BIT8), dval);
if (branch_type == NULL((void*)0))
  {
    int f;
    for (f = variant_field + 1; f < nfields; f += 1)
      TYPE_FIELDS (rtype)(rtype)->main_type->fields[f - 1] = TYPE_FIELDS (rtype)(rtype)->main_type->fields[f];
    TYPE_NFIELDS (rtype)(rtype)->main_type->nfields -= 1;
  }
else
  {
    TYPE_FIELD_TYPE (rtype, variant_field)(((rtype)->main_type->fields[variant_field]).type) = branch_type;
    TYPE_FIELD_NAME (rtype, variant_field)(((rtype)->main_type->fields[variant_field]).name) = "S";
    TYPE_FIELD_BITSIZE (rtype, variant_field)(((rtype)->main_type->fields[variant_field]).bitsize) = 0;
    TYPE_LENGTH (rtype)(rtype)->length += TYPE_LENGTH (branch_type)(branch_type)->length;
  }
TYPE_LENGTH (rtype)(rtype)->length -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field))((((type)->main_type->fields[variant_field]).type))->
length;

value_free_to_mark (mark);
return rtype;
6314}

6316/* An ordinary record type (with fixed-length fields) that describes
 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
 beginning of this section].   Any necessary discriminants' values
 should be in DVAL, a record value; it may be NULL if the object
 at ADDR itself contains any necessary discriminant values.
 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
 values from the record are needed.  Except in the case that DVAL,
 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
 unchecked) is replaced by a particular branch of the variant.

 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
 is questionable and may be removed.  It can arise during the
 processing of an unconstrained-array-of-record type where all the
 variant branches have exactly the same size.  This is because in
 such cases, the compiler does not bother to use the XVS convention
 when encoding the record.  I am currently dubious of this
 shortcut and suspect the compiler should be altered.  FIXME.  */

6334static struct type *
6335to_fixed_record_type (struct type *type0, char *valaddr,
                    CORE_ADDR address, struct value *dval)
6337{
struct type *templ_type;

if (TYPE_FLAGS (type0)(type0)->main_type->flags & TYPE_FLAG_FIXED_INSTANCE(1 << 15))
  return type0;

templ_type = dynamic_template_type (type0);

if (templ_type != NULL((void*)0))
  return template_to_fixed_record_type (templ_type, valaddr, address, dval);
else if (variant_field_index (type0) >= 0)
  {
    if (dval == NULL((void*)0) && valaddr == NULL((void*)0) && address == 0)
      return type0;
    return to_record_with_fixed_variant_part (type0, valaddr, address,
                                              dval);
  }
else
  {
    TYPE_FLAGS (type0)(type0)->main_type->flags |= TYPE_FLAG_FIXED_INSTANCE(1 << 15);
    return type0;
  }

6360}

6362/* An ordinary record type (with fixed-length fields) that describes
 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
 union type.  Any necessary discriminants' values should be in DVAL,
 a record value.  That is, this routine selects the appropriate
 branch of the union at ADDR according to the discriminant value
 indicated in the union's type name.  */

6369static struct type *
6370to_fixed_variant_branch_type (struct type *var_type0, char *valaddr,
                            CORE_ADDR address, struct value *dval)
6372{
int which;
struct type *templ_type;
struct type *var_type;

if (TYPE_CODE (var_type0)(var_type0)->main_type->code == TYPE_CODE_PTR)
  var_type = TYPE_TARGET_TYPE (var_type0)(var_type0)->main_type->target_type;
else
  var_type = var_type0;

templ_type = ada_find_parallel_type (var_type, "___XVU");

if (templ_type != NULL((void*)0))
  var_type = templ_type;

which =
  ada_which_variant_applies (var_type,
                             VALUE_TYPE (dval)(dval)->type, VALUE_CONTENTS (dval)((void)((dval)->lazy && value_fetch_lazy(dval)), (
(char *) (dval)->aligner.contents + (dval)->embedded_offset
)));

if (which < 0)
  return empty_record (TYPE_OBJFILE (var_type)(var_type)->main_type->objfile);
else if (is_dynamic_field (var_type, which))
  return to_fixed_record_type
    (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which))((((var_type)->main_type->fields[which]).type))->main_type
->target_type,
     valaddr, address, dval);
else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)(((var_type)->main_type->fields[which]).type)) >= 0)
  return
    to_fixed_record_type
    (TYPE_FIELD_TYPE (var_type, which)(((var_type)->main_type->fields[which]).type), valaddr, address, dval);
else
  return TYPE_FIELD_TYPE (var_type, which)(((var_type)->main_type->fields[which]).type);
6403}

6405/* Assuming that TYPE0 is an array type describing the type of a value
 at ADDR, and that DVAL describes a record containing any
 discriminants used in TYPE0, returns a type for the value that
 contains no dynamic components (that is, no components whose sizes
 are determined by run-time quantities).  Unless IGNORE_TOO_BIG is
 true, gives an error message if the resulting type's size is over
 varsize_limit.  */

6413static struct type *
6414to_fixed_array_type (struct type *type0, struct value *dval,
                   int ignore_too_big)
6416{
struct type *index_type_desc;
struct type *result;

if (ada_is_packed_array_type (type0)  /* revisit? */
    || (TYPE_FLAGS (type0)(type0)->main_type->flags & TYPE_FLAG_FIXED_INSTANCE(1 << 15)))
  return type0;

index_type_desc = ada_find_parallel_type (type0, "___XA");
if (index_type_desc == NULL((void*)0))
  {
    struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0)(type0)->main_type->target_type);
    /* NOTE: elt_type---the fixed version of elt_type0---should never
       depend on the contents of the array in properly constructed
       debugging data.  */
    struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval);

    if (elt_type0 == elt_type)
      result = type0;
    else
      result = create_array_type (alloc_type (TYPE_OBJFILE (type0)(type0)->main_type->objfile),
                                  elt_type, TYPE_INDEX_TYPE (type0)(((type0)->main_type->fields[0]).type));
  }
else
  {
    int i;
    struct type *elt_type0;

    elt_type0 = type0;
    for (i = TYPE_NFIELDS (index_type_desc)(index_type_desc)->main_type->nfields; i > 0; i -= 1)
      elt_type0 = TYPE_TARGET_TYPE (elt_type0)(elt_type0)->main_type->target_type;

    /* NOTE: result---the fixed version of elt_type0---should never
       depend on the contents of the array in properly constructed
       debugging data.  */
    result = ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval);
    for (i = TYPE_NFIELDS (index_type_desc)(index_type_desc)->main_type->nfields - 1; i >= 0; i -= 1)
      {
        struct type *range_type =
          to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, i)(((index_type_desc)->main_type->fields[i]).name),
                               dval, TYPE_OBJFILE (type0)(type0)->main_type->objfile);
        result = create_array_type (alloc_type (TYPE_OBJFILE (type0)(type0)->main_type->objfile),
                                    result, range_type);
      }
    if (!ignore_too_big && TYPE_LENGTH (result)(result)->length > varsize_limit)
      error ("array type with dynamic size is larger than varsize-limit");
  }

TYPE_FLAGS (result)(result)->main_type->flags |= TYPE_FLAG_FIXED_INSTANCE(1 << 15);
return result;
6466}


6469/* A standard type (containing no dynamically sized components)
 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
 DVAL describes a record containing any discriminants used in TYPE0,
 and may be NULL if there are none, or if the object of type TYPE at
 ADDRESS or in VALADDR contains these discriminants.  */

6475struct type *
6476ada_to_fixed_type (struct type *type, char *valaddr,
                 CORE_ADDR address, struct value *dval)
6478{
type = ada_check_typedef (type);
switch (TYPE_CODE (type)(type)->main_type->code)
  {
  default:
    return type;
  case TYPE_CODE_STRUCT:
    {
      struct type *static_type = to_static_fixed_type (type);
      if (ada_is_tagged_type (static_type, 0))
        {
          struct type *real_type =
            type_from_tag (value_tag_from_contents_and_address (static_type,
                                                                valaddr,
                                                                address));
          if (real_type != NULL((void*)0))
            type = real_type;
        }
      return to_fixed_record_type (type, valaddr, address, NULL((void*)0));
    }
  case TYPE_CODE_ARRAY:
    return to_fixed_array_type (type, dval, 1);
  case TYPE_CODE_UNION:
    if (dval == NULL((void*)0))
      return type;
    else
      return to_fixed_variant_branch_type (type, valaddr, address, dval);
  }
6506}

6508/* A standard (static-sized) type corresponding as well as possible to
 TYPE0, but based on no runtime data.  */

6511static struct type *
6512to_static_fixed_type (struct type *type0)
6513{
struct type *type;

if (type0 == NULL((void*)0))
  return NULL((void*)0);

if (TYPE_FLAGS (type0)(type0)->main_type->flags & TYPE_FLAG_FIXED_INSTANCE(1 << 15))
  return type0;

type0 = ada_check_typedef (type0);

switch (TYPE_CODE (type0)(type0)->main_type->code)
  {
  default:
    return type0;
  case TYPE_CODE_STRUCT:
    type = dynamic_template_type (type0);
    if (type != NULL((void*)0))
      return template_to_static_fixed_type (type);
    else
      return template_to_static_fixed_type (type0);
  case TYPE_CODE_UNION:
    type = ada_find_parallel_type (type0, "___XVU");
    if (type != NULL((void*)0))
      return template_to_static_fixed_type (type);
    else
      return template_to_static_fixed_type (type0);
  }
6541}

6543/* A static approximation of TYPE with all type wrappers removed.  */

6545static struct type *
6546static_unwrap_type (struct type *type)
6547{
if (ada_is_aligner_type (type))
  {
    struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0)(((ada_check_typedef (type))->main_type->fields[0]).type
);
    if (ada_type_name (type1) == NULL((void*)0))
      TYPE_NAME (type1)(type1)->main_type->name = ada_type_name (type);

    return static_unwrap_type (type1);
  }
else
  {
    struct type *raw_real_type = ada_get_base_type (type);
    if (raw_real_type == type)
      return type;
    else
      return to_static_fixed_type (raw_real_type);
  }
6564}

6566/* In some cases, incomplete and private types require
 cross-references that are not resolved as records (for example,
    type Foo;
    type FooP is access Foo;
    V: FooP;
    type Foo is array ...;
 ).  In these cases, since there is no mechanism for producing
 cross-references to such types, we instead substitute for FooP a
 stub enumeration type that is nowhere resolved, and whose tag is
 the name of the actual type.  Call these types "non-record stubs".  */

6577/* A type equivalent to TYPE that is not a non-record stub, if one
 exists, otherwise TYPE.  */

6580struct type *
6581ada_check_typedef (struct type *type)
6582{
CHECK_TYPEDEF (type)(type) = check_typedef (type);
if (type == NULL((void*)0) || TYPE_CODE (type)(type)->main_type->code != TYPE_CODE_ENUM
    || (TYPE_FLAGS (type)(type)->main_type->flags & TYPE_FLAG_STUB(1 << 2)) == 0
    || TYPE_TAG_NAME (type)(type)->main_type->tag_name == NULL((void*)0))
  return type;
else
  {
    char *name = TYPE_TAG_NAME (type)(type)->main_type->tag_name;
    struct type *type1 = ada_find_any_type (name);
    return (type1 == NULL((void*)0)) ? type : type1;
  }
6594}

6596/* A value representing the data at VALADDR/ADDRESS as described by
 type TYPE0, but with a standard (static-sized) type that correctly
 describes it.  If VAL0 is not NULL and TYPE0 already is a standard
 type, then return VAL0 [this feature is simply to avoid redundant
 creation of struct values].  */

6602static struct value *
6603ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
                         struct value *val0)
6605{
struct type *type = ada_to_fixed_type (type0, 0, address, NULL((void*)0));
if (type == type0 && val0 != NULL((void*)0))
  return val0;
else
  return value_from_contents_and_address (type, 0, address);
6611}

6613/* A value representing VAL, but with a standard (static-sized) type
 that correctly describes it.  Does not necessarily create a new
 value.  */

6617static struct value *
6618ada_to_fixed_value (struct value *val)
6619{
return ada_to_fixed_value_create (VALUE_TYPE (val)(val)->type,
                                  VALUE_ADDRESS (val)(val)->location.address + VALUE_OFFSET (val)(val)->offset,
                                  val);
6623}

6625/* A value representing VAL, but with a standard (static-sized) type
 chosen to approximate the real type of VAL as well as possible, but
 without consulting any runtime values.  For Ada dynamic-sized
 types, therefore, the type of the result is likely to be inaccurate.  */

6630struct value *
6631ada_to_static_fixed_value (struct value *val)
6632{
struct type *type =
  to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val)(val)->type));
if (type == VALUE_TYPE (val)(val)->type)
  return val;
else
  return coerce_unspec_val_to_type (val, type);
6639}
6640

6642/* Attributes */

6644/* Table mapping attribute numbers to names.
 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h.  */

6647static const char *attribute_names[] = {
"<?>",

"first",
"last",
"length",
"image",
"max",
"min",
"modulus",
"pos",
"size",
"tag",
"val",
0
6662};

6664const char *
6665ada_attribute_name (enum exp_opcode n)
6666{
if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
  return attribute_names[n - OP_ATR_FIRST + 1];
else
  return attribute_names[0];
6671}

6673/* Evaluate the 'POS attribute applied to ARG.  */

6675static LONGESTlong
6676pos_atr (struct value *arg)
6677{
struct type *type = VALUE_TYPE (arg)(arg)->type;

if (!discrete_type_p (type))
  error ("'POS only defined on discrete types");

if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_ENUM)
  {
    int i;
    LONGESTlong v = value_as_long (arg);

    for (i = 0; i < TYPE_NFIELDS (type)(type)->main_type->nfields; i += 1)
      {
        if (v == TYPE_FIELD_BITPOS (type, i)(((type)->main_type->fields[i]).loc.bitpos))
          return i;
      }
    error ("enumeration value is invalid: can't find 'POS");
  }
else
  return value_as_long (arg);
6697}

6699static struct value *
6700value_pos_atr (struct value *arg)
6701{
return value_from_longest (builtin_type_int, pos_atr (arg));
6703}

6705/* Evaluate the TYPE'VAL attribute applied to ARG.  */

6707static struct value *
6708value_val_atr (struct type *type, struct value *arg)
6709{
if (!discrete_type_p (type))
  error ("'VAL only defined on discrete types");
if (!integer_type_p (VALUE_TYPE (arg)(arg)->type))
  error ("'VAL requires integral argument");

if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_ENUM)
  {
    long pos = value_as_long (arg);
    if (pos < 0 || pos >= TYPE_NFIELDS (type)(type)->main_type->nfields)
      error ("argument to 'VAL out of range");
    return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos)(((type)->main_type->fields[pos]).loc.bitpos));
  }
else
  return value_from_longest (type, value_as_long (arg));
6724}
6725

                              /* Evaluation */

6729/* True if TYPE appears to be an Ada character type.
 [At the moment, this is true only for Character and Wide_Character;
 It is a heuristic test that could stand improvement].  */

6733int
6734ada_is_character_type (struct type *type)
6735{
const char *name = ada_type_name (type);
return
  name != NULL((void*)0)
  && (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_CHAR
      || TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_INT
      || TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_RANGE)
  && (strcmp (name, "character") == 0
      || strcmp (name, "wide_character") == 0
      || strcmp (name, "unsigned char") == 0);
6745}

6747/* True if TYPE appears to be an Ada string type.  */

6749int
6750ada_is_string_type (struct type *type)
6751{
type = ada_check_typedef (type);
if (type != NULL((void*)0)
    && TYPE_CODE (type)(type)->main_type->code != TYPE_CODE_PTR
    && (ada_is_simple_array_type (type)
        || ada_is_array_descriptor_type (type))
    && ada_array_arity (type) == 1)
  {
    struct type *elttype = ada_array_element_type (type, 1);

    return ada_is_character_type (elttype);
  }
else
  return 0;
6765}


6768/* True if TYPE is a struct type introduced by the compiler to force the
 alignment of a value.  Such types have a single field with a
 distinctive name.  */

6772int
6773ada_is_aligner_type (struct type *type)
6774{
type = ada_check_typedef (type);

/* If we can find a parallel XVS type, then the XVS type should
   be used instead of this type.  And hence, this is not an aligner
   type.  */
if (ada_find_parallel_type (type, "___XVS") != NULL((void*)0))
  return 0;

return (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_STRUCT
        && TYPE_NFIELDS (type)(type)->main_type->nfields == 1
        && strcmp (TYPE_FIELD_NAME (type, 0)(((type)->main_type->fields[0]).name), "F") == 0);
6786}

6788/* If there is an ___XVS-convention type parallel to SUBTYPE, return
 the parallel type.  */

6791struct type *
6792ada_get_base_type (struct type *raw_type)
6793{
struct type *real_type_namer;
struct type *raw_real_type;

if (raw_type == NULL((void*)0) || TYPE_CODE (raw_type)(raw_type)->main_type->code != TYPE_CODE_STRUCT)
  return raw_type;

real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
if (real_type_namer == NULL((void*)0)
    || TYPE_CODE (real_type_namer)(real_type_namer)->main_type->code != TYPE_CODE_STRUCT
    || TYPE_NFIELDS (real_type_namer)(real_type_namer)->main_type->nfields != 1)
  return raw_type;

raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0)(((real_type_namer)->main_type->fields[0]).name));
if (raw_real_type == NULL((void*)0))
  return raw_type;
else
  return raw_real_type;
6811}

6813/* The type of value designated by TYPE, with all aligners removed.  */

6815struct type *
6816ada_aligned_type (struct type *type)
6817{
if (ada_is_aligner_type (type))
  return ada_aligned_type (TYPE_FIELD_TYPE (type, 0)(((type)->main_type->fields[0]).type));
else
  return ada_get_base_type (type);
6822}


6825/* The address of the aligned value in an object at address VALADDR
 having type TYPE.  Assumes ada_is_aligner_type (TYPE).  */

6828char *
6829ada_aligned_value_addr (struct type *type, char *valaddr)
6830{
if (ada_is_aligner_type (type))
  return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0)(((type)->main_type->fields[0]).type),
                                 valaddr +
                                 TYPE_FIELD_BITPOS (type,(((type)->main_type->fields[0]).loc.bitpos)
                                                    0)(((type)->main_type->fields[0]).loc.bitpos) / TARGET_CHAR_BIT8);
else
  return valaddr;
6838}



6842/* The printed representation of an enumeration literal with encoded
 name NAME.  The value is good to the next call of ada_enum_name.  */
6844const char *
6845ada_enum_name (const char *name)
6846{
static char *result;
static size_t result_len = 0;
char *tmp;

/* First, unqualify the enumeration name:
   1. Search for the last '.' character.  If we find one, then skip
   all the preceeding characters, the unqualified name starts
   right after that dot.
   2. Otherwise, we may be debugging on a target where the compiler
   translates dots into "__".  Search forward for double underscores,
   but stop searching when we hit an overloading suffix, which is
   of the form "__" followed by digits.  */

tmp = strrchr (name, '.');
if (tmp != NULL((void*)0))
  name = tmp + 1;
else
  {
    while ((tmp = strstr (name, "__")) != NULL((void*)0))
      {
        if (isdigit (tmp[2]))
          break;
        else
          name = tmp + 2;
      }
  }

if (name[0] == 'Q')
  {
    int v;
    if (name[1] == 'U' || name[1] == 'W')
      {
        if (sscanf (name + 2, "%x", &v) != 1)
          return name;
      }
    else
      return name;

    GROW_VECT (result, result_len, 16)if ((result_len) < (16)) grow_vect ((void**) &(result)
, &(result_len), (16), sizeof(*(result)));;
    if (isascii (v) && isprint (v))
      sprintf (result, "'%c'", v);
    else if (name[1] == 'U')
      sprintf (result, "[\"%02x\"]", v);
    else
      sprintf (result, "[\"%04x\"]", v);

    return result;
  }
else
  {
    tmp = strstr (name, "__");
    if (tmp == NULL((void*)0))
tmp = strstr (name, "$");
    if (tmp != NULL((void*)0))
      {
        GROW_VECT (result, result_len, tmp - name + 1)if ((result_len) < (tmp - name + 1)) grow_vect ((void**) &
(result), &(result_len), (tmp - name + 1), sizeof(*(result
)));;
        strncpy (result, name, tmp - name);
        result[tmp - name] = '\0';
        return result;
      }

    return name;
  }
6910}

6912static struct value *
6913evaluate_subexp (struct type *expect_type, struct expression *exp, int *pos,
               enum noside noside)
6915{
return (*exp->language_defn->la_exp_desc->evaluate_exp)
  (expect_type, exp, pos, noside);
6918}

6920/* Evaluate the subexpression of EXP starting at *POS as for
 evaluate_type, updating *POS to point just past the evaluated
 expression.  */

6924static struct value *
6925evaluate_subexp_type (struct expression *exp, int *pos)
6926{
return (*exp->language_defn->la_exp_desc->evaluate_exp)
  (NULL_TYPE((struct type *) 0), exp, pos, EVAL_AVOID_SIDE_EFFECTS);
6929}

6931/* If VAL is wrapped in an aligner or subtype wrapper, return the
 value it wraps.  */

6934static struct value *
6935unwrap_value (struct value *val)
6936{
struct type *type = ada_check_typedef (VALUE_TYPE (val)(val)->type);
if (ada_is_aligner_type (type))
  {
    struct value *v = value_struct_elt (&val, NULL((void*)0), "F",
                                        NULL((void*)0), "internal structure");
    struct type *val_type = ada_check_typedef (VALUE_TYPE (v)(v)->type);
    if (ada_type_name (val_type) == NULL((void*)0))
      TYPE_NAME (val_type)(val_type)->main_type->name = ada_type_name (type);

    return unwrap_value (v);
  }
else
  {
    struct type *raw_real_type =
      ada_check_typedef (ada_get_base_type (type));

    if (type == raw_real_type)
      return val;

    return
      coerce_unspec_val_to_type
      (val, ada_to_fixed_type (raw_real_type, 0,
                               VALUE_ADDRESS (val)(val)->location.address + VALUE_OFFSET (val)(val)->offset,
                               NULL((void*)0)));
  }
6962}

6964static struct value *
6965cast_to_fixed (struct type *type, struct value *arg)
6966{
LONGESTlong val;

if (type == VALUE_TYPE (arg)(arg)->type)
  return arg;
else if (ada_is_fixed_point_type (VALUE_TYPE (arg)(arg)->type))
  val = ada_float_to_fixed (type,
                            ada_fixed_to_float (VALUE_TYPE (arg)(arg)->type,
                                                value_as_long (arg)));
else
  {
    DOUBLEST argd =
      value_as_double (value_cast (builtin_type_double, value_copy (arg)));
    val = ada_float_to_fixed (type, argd);
  }

return value_from_longest (type, val);
6983}

6985static struct value *
6986cast_from_fixed_to_double (struct value *arg)
6987{
DOUBLEST val = ada_fixed_to_float (VALUE_TYPE (arg)(arg)->type,
                                   value_as_long (arg));
return value_from_double (builtin_type_double, val);
6991}

6993/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
 return the converted value.  */

6996static struct value *
6997coerce_for_assign (struct type *type, struct value *val)
6998{
struct type *type2 = VALUE_TYPE (val)(val)->type;
if (type == type2)
  return val;

type2 = ada_check_typedef (type2);
type = ada_check_typedef (type);

if (TYPE_CODE (type2)(type2)->main_type->code == TYPE_CODE_PTR
    && TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_ARRAY)
  {
    val = ada_value_ind (val);
    type2 = VALUE_TYPE (val)(val)->type;
  }

if (TYPE_CODE (type2)(type2)->main_type->code == TYPE_CODE_ARRAY
    && TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_ARRAY)
  {
    if (TYPE_LENGTH (type2)(type2)->length != TYPE_LENGTH (type)(type)->length
        || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))((type2)->main_type->target_type)->length
        != TYPE_LENGTH (TYPE_TARGET_TYPE (type2))((type2)->main_type->target_type)->length)
      error ("Incompatible types in assignment");
    VALUE_TYPE (val)(val)->type = type;
  }
return val;
7023}

7025static struct value *
7026ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
7027{
struct value *val;
struct type *type1, *type2;
LONGESTlong v, v1, v2;

COERCE_REF (arg1)do { struct type *value_type_arg_tmp = check_typedef ((arg1)->
type); if ((value_type_arg_tmp)->main_type->code == TYPE_CODE_REF
) arg1 = value_at_lazy ((value_type_arg_tmp)->main_type->
target_type, unpack_pointer ((arg1)->type, ((void)((arg1)->
lazy && value_fetch_lazy(arg1)), ((char *) (arg1)->
aligner.contents + (arg1)->embedded_offset))), ((arg1)->
bfd_section)); } while (0);
COERCE_REF (arg2)do { struct type *value_type_arg_tmp = check_typedef ((arg2)->
type); if ((value_type_arg_tmp)->main_type->code == TYPE_CODE_REF
) arg2 = value_at_lazy ((value_type_arg_tmp)->main_type->
target_type, unpack_pointer ((arg2)->type, ((void)((arg2)->
lazy && value_fetch_lazy(arg2)), ((char *) (arg2)->
aligner.contents + (arg2)->embedded_offset))), ((arg2)->
bfd_section)); } while (0);
type1 = base_type (ada_check_typedef (VALUE_TYPE (arg1)(arg1)->type));
type2 = base_type (ada_check_typedef (VALUE_TYPE (arg2)(arg2)->type));

if (TYPE_CODE (type1)(type1)->main_type->code != TYPE_CODE_INT
    || TYPE_CODE (type2)(type2)->main_type->code != TYPE_CODE_INT)
  return value_binop (arg1, arg2, op);

switch (op)
  {
  case BINOP_MOD:
  case BINOP_DIV:
  case BINOP_REM:
    break;
  default:
    return value_binop (arg1, arg2, op);
  }

v2 = value_as_long (arg2);
if (v2 == 0)
  error ("second operand of %s must not be zero.", op_string (op));

if (TYPE_UNSIGNED (type1)((type1)->main_type->flags & (1 << 0)) || op == BINOP_MOD)
  return value_binop (arg1, arg2, op);

v1 = value_as_long (arg1);
switch (op)
  {
  case BINOP_DIV:
    v = v1 / v2;
    if (!TRUNCATION_TOWARDS_ZERO((-5 / 2) == -2) && v1 * (v1 % v2) < 0)
      v += v > 0 ? -1 : 1;
    break;
  case BINOP_REM:
    v = v1 % v2;
    if (v * v1 < 0)
      v -= v2;
    break;
  default:
    /* Should not reach this point.  */
    v = 0;
  }

val = allocate_value (type1);
store_unsigned_integer (VALUE_CONTENTS_RAW (val)((char *) (val)->aligner.contents + (val)->embedded_offset
),
                        TYPE_LENGTH (VALUE_TYPE (val))((val)->type)->length, v);
return val;
7080}

7082static int
7083ada_value_equal (struct value *arg1, struct value *arg2)
7084{
if (ada_is_direct_array_type (VALUE_TYPE (arg1)(arg1)->type)
    || ada_is_direct_array_type (VALUE_TYPE (arg2)(arg2)->type))
  {
    arg1 = ada_coerce_to_simple_array (arg1);
    arg2 = ada_coerce_to_simple_array (arg2);
    if (TYPE_CODE (VALUE_TYPE (arg1))((arg1)->type)->main_type->code != TYPE_CODE_ARRAY
        || TYPE_CODE (VALUE_TYPE (arg2))((arg2)->type)->main_type->code != TYPE_CODE_ARRAY)
      error ("Attempt to compare array with non-array");
    /* FIXME: The following works only for types whose
       representations use all bits (no padding or undefined bits)
       and do not have user-defined equality.  */
    return
      TYPE_LENGTH (VALUE_TYPE (arg1))((arg1)->type)->length == TYPE_LENGTH (VALUE_TYPE (arg2))((arg2)->type)->length
      && memcmp (VALUE_CONTENTS (arg1)((void)((arg1)->lazy && value_fetch_lazy(arg1)), (
(char *) (arg1)->aligner.contents + (arg1)->embedded_offset
)), VALUE_CONTENTS (arg2)((void)((arg2)->lazy && value_fetch_lazy(arg2)), (
(char *) (arg2)->aligner.contents + (arg2)->embedded_offset
)),
                 TYPE_LENGTH (VALUE_TYPE (arg1))((arg1)->type)->length) == 0;
  }
return value_equal (arg1, arg2);
7102}

7104struct value *
7105ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
                   int *pos, enum noside noside)
7107{
enum exp_opcode op;
int tem, tem2, tem3;
int pc;
struct value *arg1 = NULL((void*)0), *arg2 = NULL((void*)0), *arg3;
struct type *type;
int nargs;
struct value **argvec;

pc = *pos;
*pos += 1;
op = exp->elts[pc].opcode;

switch (op)
  {
  default:
    *pos -= 1;
    return
      unwrap_value (evaluate_subexp_standard
                    (expect_type, exp, pos, noside));

  case OP_STRING:
    {
      struct value *result;
      *pos -= 1;
      result = evaluate_subexp_standard (expect_type, exp, pos, noside);
      /* The result type will have code OP_STRING, bashed there from 
         OP_ARRAY.  Bash it back.  */
      if (TYPE_CODE (VALUE_TYPE (result))((result)->type)->main_type->code == TYPE_CODE_STRING)
        TYPE_CODE (VALUE_TYPE (result))((result)->type)->main_type->code = TYPE_CODE_ARRAY;
      return result;
    }

  case UNOP_CAST:
    (*pos) += 2;
    type = exp->elts[pc + 1].type;
    arg1 = evaluate_subexp (type, exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    if (type != ada_check_typedef (VALUE_TYPE (arg1)(arg1)->type))
      {
        if (ada_is_fixed_point_type (type))
          arg1 = cast_to_fixed (type, arg1);
        else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)(arg1)->type))
          arg1 = value_cast (type, cast_from_fixed_to_double (arg1));
        else if (VALUE_LVAL (arg1)(arg1)->lval == lval_memory)
          {
            /* This is in case of the really obscure (and undocumented,
               but apparently expected) case of (Foo) Bar.all, where Bar
               is an integer constant and Foo is a dynamic-sized type.
               If we don't do this, ARG1 will simply be relabeled with
               TYPE.  */
            if (noside == EVAL_AVOID_SIDE_EFFECTS)
              return value_zero (to_static_fixed_type (type), not_lval);
            arg1 =
              ada_to_fixed_value_create
              (type, VALUE_ADDRESS (arg1)(arg1)->location.address + VALUE_OFFSET (arg1)(arg1)->offset, 0);
          }
        else
          arg1 = value_cast (type, arg1);
      }
    return arg1;

  case UNOP_QUAL:
    (*pos) += 2;
    type = exp->elts[pc + 1].type;
    return ada_evaluate_subexp (type, exp, pos, noside);

  case BINOP_ASSIGN:
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    arg2 = evaluate_subexp (VALUE_TYPE (arg1)(arg1)->type, exp, pos, noside);
    if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
      return arg1;
    if (ada_is_fixed_point_type (VALUE_TYPE (arg1)(arg1)->type))
      arg2 = cast_to_fixed (VALUE_TYPE (arg1)(arg1)->type, arg2);
    else if (ada_is_fixed_point_type (VALUE_TYPE (arg2)(arg2)->type))
      error
        ("Fixed-point values must be assigned to fixed-point variables");
    else
      arg2 = coerce_for_assign (VALUE_TYPE (arg1)(arg1)->type, arg2);
    return ada_value_assign (arg1, arg2);

  case BINOP_ADD:
    arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
    arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    if ((ada_is_fixed_point_type (VALUE_TYPE (arg1)(arg1)->type)
         || ada_is_fixed_point_type (VALUE_TYPE (arg2)(arg2)->type))
        && VALUE_TYPE (arg1)(arg1)->type != VALUE_TYPE (arg2)(arg2)->type)
      error ("Operands of fixed-point addition must have the same type");
    return value_cast (VALUE_TYPE (arg1)(arg1)->type, value_add (arg1, arg2));

  case BINOP_SUB:
    arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
    arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    if ((ada_is_fixed_point_type (VALUE_TYPE (arg1)(arg1)->type)
         || ada_is_fixed_point_type (VALUE_TYPE (arg2)(arg2)->type))
        && VALUE_TYPE (arg1)(arg1)->type != VALUE_TYPE (arg2)(arg2)->type)
      error ("Operands of fixed-point subtraction must have the same type");
    return value_cast (VALUE_TYPE (arg1)(arg1)->type, value_sub (arg1, arg2));

  case BINOP_MUL:
  case BINOP_DIV:
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    arg2 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    else if (noside == EVAL_AVOID_SIDE_EFFECTS
             && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
      return value_zero (VALUE_TYPE (arg1)(arg1)->type, not_lval);
    else
      {
        if (ada_is_fixed_point_type (VALUE_TYPE (arg1)(arg1)->type))
          arg1 = cast_from_fixed_to_double (arg1);
        if (ada_is_fixed_point_type (VALUE_TYPE (arg2)(arg2)->type))
          arg2 = cast_from_fixed_to_double (arg2);
        return ada_value_binop (arg1, arg2, op);
      }

  case BINOP_REM:
  case BINOP_MOD:
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    arg2 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    else if (noside == EVAL_AVOID_SIDE_EFFECTS
             && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
      return value_zero (VALUE_TYPE (arg1)(arg1)->type, not_lval);
    else
      return ada_value_binop (arg1, arg2, op);

  case BINOP_EQUAL:
  case BINOP_NOTEQUAL:
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    arg2 = evaluate_subexp (VALUE_TYPE (arg1)(arg1)->type, exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    if (noside == EVAL_AVOID_SIDE_EFFECTS)
      tem = 0;
    else
      tem = ada_value_equal (arg1, arg2);
    if (op == BINOP_NOTEQUAL)
      tem = !tem;
    return value_from_longest (LA_BOOL_TYPElang_bool_type (), (LONGESTlong) tem);

  case UNOP_NEG:
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)(arg1)->type))
      return value_cast (VALUE_TYPE (arg1)(arg1)->type, value_neg (arg1));
    else
      return value_neg (arg1);

  case OP_VAR_VALUE:
    *pos -= 1;
    if (noside == EVAL_SKIP)
      {
        *pos += 4;
        goto nosideret;
      }
    else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol)(exp->elts[pc + 2].symbol)->domain == UNDEF_DOMAIN)
      /* Only encountered when an unresolved symbol occurs in a
         context other than a function call, in which case, it is
         illegal.  */
      error ("Unexpected unresolved symbol, %s, during evaluation",
             SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)(demangle ? (symbol_natural_name (&(exp->elts[pc + 2].
symbol)->ginfo)) : (exp->elts[pc + 2].symbol)->ginfo
.name));
    else if (noside == EVAL_AVOID_SIDE_EFFECTS)
      {
        *pos += 4;
        return value_zero
          (to_static_fixed_type
           (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol)(exp->elts[pc + 2].symbol)->type)),
           not_lval);
      }
    else
      {
        arg1 =
          unwrap_value (evaluate_subexp_standard
                        (expect_type, exp, pos, noside));
        return ada_to_fixed_value (arg1);
      }

  case OP_FUNCALL:
    (*pos) += 2;

    /* Allocate arg vector, including space for the function to be
       called in argvec[0] and a terminating NULL.  */
    nargs = longest_to_int (exp->elts[pc + 1].longconst);
    argvec =
      (struct value **) alloca (sizeof (struct value *) * (nargs + 2))__builtin_alloca(sizeof (struct value *) * (nargs + 2));

    if (exp->elts[*pos].opcode == OP_VAR_VALUE
        && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol)(exp->elts[pc + 5].symbol)->domain == UNDEF_DOMAIN)
      error ("Unexpected unresolved symbol, %s, during evaluation",
             SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol)(demangle ? (symbol_natural_name (&(exp->elts[pc + 5].
symbol)->ginfo)) : (exp->elts[pc + 5].symbol)->ginfo
.name));
    else
      {
        for (tem = 0; tem <= nargs; tem += 1)
          argvec[tem] = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
        argvec[tem] = 0;

        if (noside == EVAL_SKIP)
          goto nosideret;
      }

    if (ada_is_packed_array_type (desc_base_type (VALUE_TYPE (argvec[0])(argvec[0])->type)))
      argvec[0] = ada_coerce_to_simple_array (argvec[0]);
    else if (TYPE_CODE (VALUE_TYPE (argvec[0]))((argvec[0])->type)->main_type->code == TYPE_CODE_REF
             || (TYPE_CODE (VALUE_TYPE (argvec[0]))((argvec[0])->type)->main_type->code == TYPE_CODE_ARRAY
                 && VALUE_LVAL (argvec[0])(argvec[0])->lval == lval_memory))
      argvec[0] = value_addr (argvec[0]);

    type = ada_check_typedef (VALUE_TYPE (argvec[0])(argvec[0])->type);
    if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_PTR)
      {
        switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))(ada_check_typedef ((type)->main_type->target_type))->
main_type->code)
          {
          case TYPE_CODE_FUNC:
            type = ada_check_typedef (TYPE_TARGET_TYPE (type)(type)->main_type->target_type);
            break;
          case TYPE_CODE_ARRAY:
            break;
          case TYPE_CODE_STRUCT:
            if (noside != EVAL_AVOID_SIDE_EFFECTS)
              argvec[0] = ada_value_ind (argvec[0]);
            type = ada_check_typedef (TYPE_TARGET_TYPE (type)(type)->main_type->target_type);
            break;
          default:
            error ("cannot subscript or call something of type `%s'",
                   ada_type_name (VALUE_TYPE (argvec[0])(argvec[0])->type));
            break;
          }
      }

    switch (TYPE_CODE (type)(type)->main_type->code)
      {
      case TYPE_CODE_FUNC:
        if (noside == EVAL_AVOID_SIDE_EFFECTS)
          return allocate_value (TYPE_TARGET_TYPE (type)(type)->main_type->target_type);
        return call_function_by_hand (argvec[0], nargs, argvec + 1);
      case TYPE_CODE_STRUCT:
        {
          int arity;

          arity = ada_array_arity (type);
          type = ada_array_element_type (type, nargs);
          if (type == NULL((void*)0))
            error ("cannot subscript or call a record");
          if (arity != nargs)
            error ("wrong number of subscripts; expecting %d", arity);
          if (noside == EVAL_AVOID_SIDE_EFFECTS)
            return allocate_value (ada_aligned_type (type));
          return
            unwrap_value (ada_value_subscript
                          (argvec[0], nargs, argvec + 1));
        }
      case TYPE_CODE_ARRAY:
        if (noside == EVAL_AVOID_SIDE_EFFECTS)
          {
            type = ada_array_element_type (type, nargs);
            if (type == NULL((void*)0))
              error ("element type of array unknown");
            else
              return allocate_value (ada_aligned_type (type));
          }
        return
          unwrap_value (ada_value_subscript
                        (ada_coerce_to_simple_array (argvec[0]),
                         nargs, argvec + 1));
      case TYPE_CODE_PTR:     /* Pointer to array */
        type = to_fixed_array_type (TYPE_TARGET_TYPE (type)(type)->main_type->target_type, NULL((void*)0), 1);
        if (noside == EVAL_AVOID_SIDE_EFFECTS)
          {
            type = ada_array_element_type (type, nargs);
            if (type == NULL((void*)0))
              error ("element type of array unknown");
            else
              return allocate_value (ada_aligned_type (type));
          }
        return
          unwrap_value (ada_value_ptr_subscript (argvec[0], type,
                                                 nargs, argvec + 1));

      default:
        error ("Attempt to index or call something other than an "
 "array or function");
      }

  case TERNOP_SLICE:
    {
      struct value *array = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
      struct value *low_bound_val =
        evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
      struct value *high_bound_val =
        evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
      LONGESTlong low_bound;
      LONGESTlong high_bound;
      COERCE_REF (low_bound_val)do { struct type *value_type_arg_tmp = check_typedef ((low_bound_val
)->type); if ((value_type_arg_tmp)->main_type->code ==
 TYPE_CODE_REF) low_bound_val = value_at_lazy ((value_type_arg_tmp
)->main_type->target_type, unpack_pointer ((low_bound_val
)->type, ((void)((low_bound_val)->lazy && value_fetch_lazy
(low_bound_val)), ((char *) (low_bound_val)->aligner.contents
 + (low_bound_val)->embedded_offset))), ((low_bound_val)->
bfd_section)); } while (0);
      COERCE_REF (high_bound_val)do { struct type *value_type_arg_tmp = check_typedef ((high_bound_val
)->type); if ((value_type_arg_tmp)->main_type->code ==
 TYPE_CODE_REF) high_bound_val = value_at_lazy ((value_type_arg_tmp
)->main_type->target_type, unpack_pointer ((high_bound_val
)->type, ((void)((high_bound_val)->lazy && value_fetch_lazy
(high_bound_val)), ((char *) (high_bound_val)->aligner.contents
 + (high_bound_val)->embedded_offset))), ((high_bound_val)
->bfd_section)); } while (0);
      low_bound = pos_atr (low_bound_val);
      high_bound = pos_atr (high_bound_val);

      if (noside == EVAL_SKIP)
        goto nosideret;

      /* If this is a reference to an aligner type, then remove all
         the aligners.  */
      if (TYPE_CODE (VALUE_TYPE (array))((array)->type)->main_type->code == TYPE_CODE_REF
          && ada_is_aligner_type (TYPE_TARGET_TYPE (VALUE_TYPE (array))((array)->type)->main_type->target_type))
        TYPE_TARGET_TYPE (VALUE_TYPE (array))((array)->type)->main_type->target_type =
          ada_aligned_type (TYPE_TARGET_TYPE (VALUE_TYPE (array))((array)->type)->main_type->target_type);

      if (ada_is_packed_array_type (VALUE_TYPE (array)(array)->type))
        error ("cannot slice a packed array");

      /* If this is a reference to an array or an array lvalue,
         convert to a pointer.  */
      if (TYPE_CODE (VALUE_TYPE (array))((array)->type)->main_type->code == TYPE_CODE_REF
          || (TYPE_CODE (VALUE_TYPE (array))((array)->type)->main_type->code == TYPE_CODE_ARRAY
              && VALUE_LVAL (array)(array)->lval == lval_memory))
        array = value_addr (array);

      if (noside == EVAL_AVOID_SIDE_EFFECTS
          && ada_is_array_descriptor_type (ada_check_typedef
                                           (VALUE_TYPE (array)(array)->type)))
        return empty_array (ada_type_of_array (array, 0), low_bound);

      array = ada_coerce_to_simple_array_ptr (array);

      /* If we have more than one level of pointer indirection,
         dereference the value until we get only one level.  */
      while (TYPE_CODE (VALUE_TYPE (array))((array)->type)->main_type->code == TYPE_CODE_PTR
             && (TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array)))(((array)->type)->main_type->target_type)->main_type
->code
                   == TYPE_CODE_PTR))
        array = value_ind (array);

      /* Make sure we really do have an array type before going further,
         to avoid a SEGV when trying to get the index type or the target
         type later down the road if the debug info generated by
         the compiler is incorrect or incomplete.  */
      if (!ada_is_simple_array_type (VALUE_TYPE (array)(array)->type))
        error ("cannot take slice of non-array");

      if (TYPE_CODE (VALUE_TYPE (array))((array)->type)->main_type->code == TYPE_CODE_PTR)
        {
          if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
            return empty_array (TYPE_TARGET_TYPE (VALUE_TYPE (array))((array)->type)->main_type->target_type,
                                low_bound);
          else
            {
              struct type *arr_type0 =
                to_fixed_array_type (TYPE_TARGET_TYPE (VALUE_TYPE (array))((array)->type)->main_type->target_type,
                                     NULL((void*)0), 1);
              return ada_value_slice_ptr (array, arr_type0,
                                          (int) low_bound, 
			    (int) high_bound);
            }
        }
      else if (noside == EVAL_AVOID_SIDE_EFFECTS)
        return array;
      else if (high_bound < low_bound)
        return empty_array (VALUE_TYPE (array)(array)->type, low_bound);
      else
        return ada_value_slice (array, (int) low_bound, (int) high_bound);
    }

  case UNOP_IN_RANGE:
    (*pos) += 2;
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    type = exp->elts[pc + 1].type;

    if (noside == EVAL_SKIP)
      goto nosideret;

    switch (TYPE_CODE (type)(type)->main_type->code)
      {
      default:
        lim_warning ("Membership test incompletely implemented; "
                     "always returns true");
        return value_from_longest (builtin_type_int, (LONGESTlong) 1);

      case TYPE_CODE_RANGE:
        arg2 = value_from_longest (builtin_type_int, TYPE_LOW_BOUND (type)(((type)->main_type->fields[0]).loc.bitpos));
        arg3 = value_from_longest (builtin_type_int,
                                   TYPE_HIGH_BOUND (type)(((type)->main_type->fields[1]).loc.bitpos));
        return
          value_from_longest (builtin_type_int,
                              (value_less (arg1, arg3)
                               || value_equal (arg1, arg3))
                              && (value_less (arg2, arg1)
                                  || value_equal (arg2, arg1)));
      }

  case BINOP_IN_BOUNDS:
    (*pos) += 2;
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    arg2 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);

    if (noside == EVAL_SKIP)
      goto nosideret;

    if (noside == EVAL_AVOID_SIDE_EFFECTS)
      return value_zero (builtin_type_int, not_lval);

    tem = longest_to_int (exp->elts[pc + 1].longconst);

    if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)(arg2)->type))
      error ("invalid dimension number to '%s", "range");

    arg3 = ada_array_bound (arg2, tem, 1);
    arg2 = ada_array_bound (arg2, tem, 0);

    return
      value_from_longest (builtin_type_int,
                          (value_less (arg1, arg3)
                           || value_equal (arg1, arg3))
                          && (value_less (arg2, arg1)
                              || value_equal (arg2, arg1)));

  case TERNOP_IN_RANGE:
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    arg2 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    arg3 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);

    if (noside == EVAL_SKIP)
      goto nosideret;

    return
      value_from_longest (builtin_type_int,
                          (value_less (arg1, arg3)
                           || value_equal (arg1, arg3))
                          && (value_less (arg2, arg1)
                              || value_equal (arg2, arg1)));

  case OP_ATR_FIRST:
  case OP_ATR_LAST:
  case OP_ATR_LENGTH:
    {
      struct type *type_arg;
      if (exp->elts[*pos].opcode == OP_TYPE)
        {
          evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, EVAL_SKIP);
          arg1 = NULL((void*)0);
          type_arg = exp->elts[pc + 2].type;
        }
      else
        {
          arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
          type_arg = NULL((void*)0);
        }

      if (exp->elts[*pos].opcode != OP_LONG)
        error ("illegal operand to '%s", ada_attribute_name (op));
      tem = longest_to_int (exp->elts[*pos + 2].longconst);
      *pos += 4;

      if (noside == EVAL_SKIP)
        goto nosideret;

      if (type_arg == NULL((void*)0))
        {
          arg1 = ada_coerce_ref (arg1);

          if (ada_is_packed_array_type (VALUE_TYPE (arg1)(arg1)->type))
            arg1 = ada_coerce_to_simple_array (arg1);

          if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)(arg1)->type))
            error ("invalid dimension number to '%s",
                   ada_attribute_name (op));

          if (noside == EVAL_AVOID_SIDE_EFFECTS)
            {
              type = ada_index_type (VALUE_TYPE (arg1)(arg1)->type, tem);
              if (type == NULL((void*)0))
                error
                  ("attempt to take bound of something that is not an array");
              return allocate_value (type);
            }

          switch (op)
            {
            default:          /* Should never happen.  */
              error ("unexpected attribute encountered");
            case OP_ATR_FIRST:
              return ada_array_bound (arg1, tem, 0);
            case OP_ATR_LAST:
              return ada_array_bound (arg1, tem, 1);
            case OP_ATR_LENGTH:
              return ada_array_length (arg1, tem);
            }
        }
      else if (discrete_type_p (type_arg))
        {
          struct type *range_type;
          char *name = ada_type_name (type_arg);
          range_type = NULL((void*)0);
          if (name != NULL((void*)0) && TYPE_CODE (type_arg)(type_arg)->main_type->code != TYPE_CODE_ENUM)
            range_type =
              to_fixed_range_type (name, NULL((void*)0), TYPE_OBJFILE (type_arg)(type_arg)->main_type->objfile);
          if (range_type == NULL((void*)0))
            range_type = type_arg;
          switch (op)
            {
            default:
              error ("unexpected attribute encountered");
            case OP_ATR_FIRST:
              return discrete_type_low_bound (range_type);
            case OP_ATR_LAST:
              return discrete_type_high_bound (range_type);
            case OP_ATR_LENGTH:
              error ("the 'length attribute applies only to array types");
            }
        }
      else if (TYPE_CODE (type_arg)(type_arg)->main_type->code == TYPE_CODE_FLT)
        error ("unimplemented type attribute");
      else
        {
          LONGESTlong low, high;

          if (ada_is_packed_array_type (type_arg))
            type_arg = decode_packed_array_type (type_arg);

          if (tem < 1 || tem > ada_array_arity (type_arg))
            error ("invalid dimension number to '%s",
                   ada_attribute_name (op));

          type = ada_index_type (type_arg, tem);
          if (type == NULL((void*)0))
            error
              ("attempt to take bound of something that is not an array");
          if (noside == EVAL_AVOID_SIDE_EFFECTS)
            return allocate_value (type);

          switch (op)
            {
            default:
              error ("unexpected attribute encountered");
            case OP_ATR_FIRST:
              low = ada_array_bound_from_type (type_arg, tem, 0, &type);
              return value_from_longest (type, low);
            case OP_ATR_LAST:
              high = ada_array_bound_from_type (type_arg, tem, 1, &type);
              return value_from_longest (type, high);
            case OP_ATR_LENGTH:
              low = ada_array_bound_from_type (type_arg, tem, 0, &type);
              high = ada_array_bound_from_type (type_arg, tem, 1, NULL((void*)0));
              return value_from_longest (type, high - low + 1);
            }
        }
    }

  case OP_ATR_TAG:
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;

    if (noside == EVAL_AVOID_SIDE_EFFECTS)
      return value_zero (ada_tag_type (arg1), not_lval);

    return ada_value_tag (arg1);

  case OP_ATR_MIN:
  case OP_ATR_MAX:
    evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, EVAL_SKIP);
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    arg2 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    else if (noside == EVAL_AVOID_SIDE_EFFECTS)
      return value_zero (VALUE_TYPE (arg1)(arg1)->type, not_lval);
    else
      return value_binop (arg1, arg2,
                          op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);

  case OP_ATR_MODULUS:
    {
      struct type *type_arg = exp->elts[pc + 2].type;
      evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, EVAL_SKIP);

      if (noside == EVAL_SKIP)
        goto nosideret;

      if (!ada_is_modular_type (type_arg))
        error ("'modulus must be applied to modular type");

      return value_from_longest (TYPE_TARGET_TYPE (type_arg)(type_arg)->main_type->target_type,
                                 ada_modulus (type_arg));
    }


  case OP_ATR_POS:
    evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, EVAL_SKIP);
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    else if (noside == EVAL_AVOID_SIDE_EFFECTS)
      return value_zero (builtin_type_int, not_lval);
    else
      return value_pos_atr (arg1);

  case OP_ATR_SIZE:
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    else if (noside == EVAL_AVOID_SIDE_EFFECTS)
      return value_zero (builtin_type_int, not_lval);
    else
      return value_from_longest (builtin_type_int,
                                 TARGET_CHAR_BIT8
                                 * TYPE_LENGTH (VALUE_TYPE (arg1))((arg1)->type)->length);

  case OP_ATR_VAL:
    evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, EVAL_SKIP);
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    type = exp->elts[pc + 2].type;
    if (noside == EVAL_SKIP)
      goto nosideret;
    else if (noside == EVAL_AVOID_SIDE_EFFECTS)
      return value_zero (type, not_lval);
    else
      return value_val_atr (type, arg1);

  case BINOP_EXP:
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    arg2 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    else if (noside == EVAL_AVOID_SIDE_EFFECTS)
      return value_zero (VALUE_TYPE (arg1)(arg1)->type, not_lval);
    else
      return value_binop (arg1, arg2, op);

  case UNOP_PLUS:
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    else
      return arg1;

  case UNOP_ABS:
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    if (value_less (arg1, value_zero (VALUE_TYPE (arg1)(arg1)->type, not_lval)))
      return value_neg (arg1);
    else
      return arg1;

  case UNOP_IND:
    if (expect_type && TYPE_CODE (expect_type)(expect_type)->main_type->code == TYPE_CODE_PTR)
      expect_type = TYPE_TARGET_TYPE (ada_check_typedef (expect_type))(ada_check_typedef (expect_type))->main_type->target_type;
    arg1 = evaluate_subexp (expect_type, exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    type = ada_check_typedef (VALUE_TYPE (arg1)(arg1)->type);
    if (noside == EVAL_AVOID_SIDE_EFFECTS)
      {
        if (ada_is_array_descriptor_type (type))
          /* GDB allows dereferencing GNAT array descriptors.  */
          {
            struct type *arrType = ada_type_of_array (arg1, 0);
            if (arrType == NULL((void*)0))
              error ("Attempt to dereference null array pointer.");
            return value_at_lazy (arrType, 0, NULL((void*)0));
          }
        else if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_PTR
                 || TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_REF
                 /* In C you can dereference an array to get the 1st elt.  */
                 || TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_ARRAY)
          {
            type = to_static_fixed_type
              (ada_aligned_type
               (ada_check_typedef (TYPE_TARGET_TYPE (type)(type)->main_type->target_type)));
            check_size (type);
            return value_zero (type, lval_memory);
          }
        else if (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_INT)
          /* GDB allows dereferencing an int.  */
          return value_zero (builtin_type_int, lval_memory);
        else
          error ("Attempt to take contents of a non-pointer value.");
      }
    arg1 = ada_coerce_ref (arg1);     /* FIXME: What is this for?? */
    type = ada_check_typedef (VALUE_TYPE (arg1)(arg1)->type);

    if (ada_is_array_descriptor_type (type))
      /* GDB allows dereferencing GNAT array descriptors.  */
      return ada_coerce_to_simple_array (arg1);
    else
      return ada_value_ind (arg1);

  case STRUCTOP_STRUCT:
    tem = longest_to_int (exp->elts[pc + 1].longconst);
    (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1)(((tem + 1) + sizeof (union exp_element) - 1) / sizeof (union
 exp_element));
    arg1 = evaluate_subexp (NULL_TYPE((struct type *) 0), exp, pos, noside);
    if (noside == EVAL_SKIP)
      goto nosideret;
    if (noside == EVAL_AVOID_SIDE_EFFECTS)
      {
        struct type *type1 = VALUE_TYPE (arg1)(arg1)->type;
        if (ada_is_tagged_type (type1, 1))
          {
            type = ada_lookup_struct_elt_type (type1,
                                               &exp->elts[pc + 2].string,
                                               1, 1, NULL((void*)0));
            if (type == NULL((void*)0))
              /* In this case, we assume that the field COULD exist
                 in some extension of the type.  Return an object of 
                 "type" void, which will match any formal 
                 (see ada_type_match). */
              return value_zero (builtin_type_void, lval_memory);
          }
        else
          type =
            ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
                                        0, NULL((void*)0));

        return value_zero (ada_aligned_type (type), lval_memory);
      }
    else
      return
        ada_to_fixed_value (unwrap_value
                            (ada_value_struct_elt
                             (arg1, &exp->elts[pc + 2].string, "record")));
  case OP_TYPE:
    /* The value is not supposed to be used.  This is here to make it
       easier to accommodate expressions that contain types.  */
    (*pos) += 2;
    if (noside == EVAL_SKIP)
      goto nosideret;
    else if (noside == EVAL_AVOID_SIDE_EFFECTS)
      return allocate_value (builtin_type_void);
    else
      error ("Attempt to use a type name as an expression");
  }

7847nosideret:
return value_from_longest (builtin_type_long, (LONGESTlong) 1);
7849}
7850

                              /* Fixed point */

7854/* If TYPE encodes an Ada fixed-point type, return the suffix of the
 type name that encodes the 'small and 'delta information.
 Otherwise, return NULL.  */

7858static const char *
7859fixed_type_info (struct type *type)
7860{
const char *name = ada_type_name (type);
enum type_code code = (type == NULL((void*)0)) ? TYPE_CODE_UNDEF : TYPE_CODE (type)(type)->main_type->code;

if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL((void*)0))
  {
    const char *tail = strstr (name, "___XF_");
    if (tail == NULL((void*)0))
      return NULL((void*)0);
    else
      return tail + 5;
  }
else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type)(type)->main_type->target_type != type)
  return fixed_type_info (TYPE_TARGET_TYPE (type)(type)->main_type->target_type);
else
  return NULL((void*)0);
7876}

7878/* Returns non-zero iff TYPE represents an Ada fixed-point type.  */

7880int
7881ada_is_fixed_point_type (struct type *type)
7882{
return fixed_type_info (type) != NULL((void*)0);
7884}

7886/* Return non-zero iff TYPE represents a System.Address type.  */

7888int
7889ada_is_system_address_type (struct type *type)
7890{
return (TYPE_NAME (type)(type)->main_type->name
        && strcmp (TYPE_NAME (type)(type)->main_type->name, "system__address") == 0);
7893}

7895/* Assuming that TYPE is the representation of an Ada fixed-point
 type, return its delta, or -1 if the type is malformed and the
 delta cannot be determined.  */

7899DOUBLEST
7900ada_delta (struct type *type)
7901{
const char *encoding = fixed_type_info (type);
long num, den;

if (sscanf (encoding, "_%ld_%ld", &num, &den) < 2)
  return -1.0;
else
  return (DOUBLEST) num / (DOUBLEST) den;
7909}

7911/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
 factor ('SMALL value) associated with the type.  */

7914static DOUBLEST
7915scaling_factor (struct type *type)
7916{
const char *encoding = fixed_type_info (type);
unsigned long num0, den0, num1, den1;
int n;

n = sscanf (encoding, "_%lu_%lu_%lu_%lu", &num0, &den0, &num1, &den1);

if (n < 2)
  return 1.0;
else if (n == 4)
  return (DOUBLEST) num1 / (DOUBLEST) den1;
else
  return (DOUBLEST) num0 / (DOUBLEST) den0;
7929}


7932/* Assuming that X is the representation of a value of fixed-point
 type TYPE, return its floating-point equivalent.  */

7935DOUBLEST
7936ada_fixed_to_float (struct type *type, LONGESTlong x)
7937{
return (DOUBLEST) x *scaling_factor (type);
7939}

7941/* The representation of a fixed-point value of type TYPE
 corresponding to the value X.  */

7944LONGESTlong
7945ada_float_to_fixed (struct type *type, DOUBLEST x)
7946{
return (LONGESTlong) (x / scaling_factor (type) + 0.5);
7948}


                              /* VAX floating formats */

7953/* Non-zero iff TYPE represents one of the special VAX floating-point
 types.  */

7956int
7957ada_is_vax_floating_type (struct type *type)
7958{
int name_len =
  (ada_type_name (type) == NULL((void*)0)) ? 0 : strlen (ada_type_name (type));
return
  name_len > 6
  && (TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_INT
      || TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_RANGE)
  && strncmp (ada_type_name (type) + name_len - 6, "___XF", 5) == 0;
7966}

7968/* The type of special VAX floating-point type this is, assuming
 ada_is_vax_floating_point.  */

7971int
7972ada_vax_float_type_suffix (struct type *type)
7973{
return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
7975}

7977/* A value representing the special debugging function that outputs
 VAX floating-point values of the type represented by TYPE.  Assumes
 ada_is_vax_floating_type (TYPE).  */

7981struct value *
7982ada_vax_float_print_function (struct type *type)
7983{
switch (ada_vax_float_type_suffix (type))
  {
  case 'F':
    return get_var_value ("DEBUG_STRING_F", 0);
  case 'D':
    return get_var_value ("DEBUG_STRING_D", 0);
  case 'G':
    return get_var_value ("DEBUG_STRING_G", 0);
  default:
    error ("invalid VAX floating-point type");
  }
7995}
7996

                              /* Range types */

8000/* Scan STR beginning at position K for a discriminant name, and
 return the value of that discriminant field of DVAL in *PX.  If
 PNEW_K is not null, put the position of the character beyond the
 name scanned in *PNEW_K.  Return 1 if successful; return 0 and do
 not alter *PX and *PNEW_K if unsuccessful.  */

8006static int
8007scan_discrim_bound (char *str, int k, struct value *dval, LONGESTlong * px,
                  int *pnew_k)
8009{
static char *bound_buffer = NULL((void*)0);
static size_t bound_buffer_len = 0;
char *bound;
char *pend;
struct value *bound_val;

if (dval == NULL((void*)0) || str == NULL((void*)0) || str[k] == '\0')
  return 0;

pend = strstr (str + k, "__");
if (pend == NULL((void*)0))
  {
    bound = str + k;
    k += strlen (bound);
  }
else
  {
    GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1)if ((bound_buffer_len) < (pend - (str + k) + 1)) grow_vect
 ((void**) &(bound_buffer), &(bound_buffer_len), (pend
 - (str + k) + 1), sizeof(*(bound_buffer)));;
    bound = bound_buffer;
    strncpy (bound_buffer, str + k, pend - (str + k));
    bound[pend - (str + k)] = '\0';
    k = pend - str;
  }

bound_val = ada_search_struct_field (bound, dval, 0, VALUE_TYPE (dval)(dval)->type);
if (bound_val == NULL((void*)0))
  return 0;

*px = value_as_long (bound_val);
if (pnew_k != NULL((void*)0))
  *pnew_k = k;
return 1;
8042}

8044/* Value of variable named NAME in the current environment.  If
 no such variable found, then if ERR_MSG is null, returns 0, and
 otherwise causes an error with message ERR_MSG.  */

8048static struct value *
8049get_var_value (char *name, char *err_msg)
8050{
struct ada_symbol_info *syms;
int nsyms;

nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
                                &syms);

if (nsyms != 1)
  {
    if (err_msg == NULL((void*)0))
      return 0;
    else
      error ("%s", err_msg);
  }

return value_of_variable (syms[0].sym, syms[0].block);
8066}

8068/* Value of integer variable named NAME in the current environment.  If
 no such variable found, returns 0, and sets *FLAG to 0.  If
 successful, sets *FLAG to 1.  */

8072LONGESTlong
8073get_int_var_value (char *name, int *flag)
8074{
struct value *var_val = get_var_value (name, 0);

if (var_val == 0)
  {
    if (flag != NULL((void*)0))
      *flag = 0;
    return 0;
  }
else
  {
    if (flag != NULL((void*)0))
      *flag = 1;
    return value_as_long (var_val);
  }
8089}


8092/* Return a range type whose base type is that of the range type named
 NAME in the current environment, and whose bounds are calculated
 from NAME according to the GNAT range encoding conventions.
 Extract discriminant values, if needed, from DVAL.  If a new type
 must be created, allocate in OBJFILE's space.  The bounds
 information, in general, is encoded in NAME, the base type given in
 the named range type.  */

8100static struct type *
8101to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
8102{
struct type *raw_type = ada_find_any_type (name);
struct type *base_type;
char *subtype_info;

if (raw_type == NULL((void*)0))
  base_type = builtin_type_int;
else if (TYPE_CODE (raw_type)(raw_type)->main_type->code == TYPE_CODE_RANGE)
  base_type = TYPE_TARGET_TYPE (raw_type)(raw_type)->main_type->target_type;
else
  base_type = raw_type;

subtype_info = strstr (name, "___XD");
if (subtype_info == NULL((void*)0))
  return raw_type;
else
  {
    static char *name_buf = NULL((void*)0);
    static size_t name_len = 0;
    int prefix_len = subtype_info - name;
    LONGESTlong L, U;
    struct type *type;
    char *bounds_str;
    int n;

    GROW_VECT (name_buf, name_len, prefix_len + 5)if ((name_len) < (prefix_len + 5)) grow_vect ((void**) &
(name_buf), &(name_len), (prefix_len + 5), sizeof(*(name_buf
)));;
    strncpy (name_buf, name, prefix_len);
    name_buf[prefix_len] = '\0';

    subtype_info += 5;
    bounds_str = strchr (subtype_info, '_');
    n = 1;

    if (*subtype_info == 'L')
      {
        if (!ada_scan_number (bounds_str, n, &L, &n)
            && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
          return raw_type;
        if (bounds_str[n] == '_')
          n += 2;
        else if (bounds_str[n] == '.')        /* FIXME? SGI Workshop kludge.  */
          n += 1;
        subtype_info += 1;
      }
    else
      {
        int ok;
        strcpy (name_buf + prefix_len, "___L");
        L = get_int_var_value (name_buf, &ok);
        if (!ok)
          {
            lim_warning ("Unknown lower bound, using 1.");
            L = 1;
          }
      }

    if (*subtype_info == 'U')
      {
        if (!ada_scan_number (bounds_str, n, &U, &n)
            && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
          return raw_type;
      }
    else
      {
        int ok;
        strcpy (name_buf + prefix_len, "___U");
        U = get_int_var_value (name_buf, &ok);
        if (!ok)
          {
            lim_warning ("Unknown upper bound, using %ld.", (long) L);
            U = L;
          }
      }

    if (objfile == NULL((void*)0))
      objfile = TYPE_OBJFILE (base_type)(base_type)->main_type->objfile;
    type = create_range_type (alloc_type (objfile), base_type, L, U);
    TYPE_NAME (type)(type)->main_type->name = name;
    return type;
  }
8182}

8184/* True iff NAME is the name of a range type.  */

8186int
8187ada_is_range_type_name (const char *name)
8188{
return (name != NULL((void*)0) && strstr (name, "___XD"));
8190}
8191

                              /* Modular types */

8195/* True iff TYPE is an Ada modular type.  */

8197int
8198ada_is_modular_type (struct type *type)
8199{
struct type *subranged_type = base_type (type);

return (subranged_type != NULL((void*)0) && TYPE_CODE (type)(type)->main_type->code == TYPE_CODE_RANGE
        && TYPE_CODE (subranged_type)(subranged_type)->main_type->code != TYPE_CODE_ENUM
        && TYPE_UNSIGNED (subranged_type)((subranged_type)->main_type->flags & (1 << 0
)));
8205}

8207/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE.  */

8209ULONGESTunsigned long
8210ada_modulus (struct type * type)
8211{
return (ULONGESTunsigned long) TYPE_HIGH_BOUND (type)(((type)->main_type->fields[1]).loc.bitpos) + 1;
8213}
8214
                              /* Operators */
8216/* Information about operators given special treatment in functions
 below.  */
8218/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>).  */

8220#define ADA_OPERATORSOP_DEFN (OP_VAR_VALUE, 4, 0, 0) OP_DEFN (BINOP_IN_BOUNDS, 3, 2
, 0) OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) OP_DEFN (OP_ATR_FIRST
, 1, 2, 0) OP_DEFN (OP_ATR_LAST, 1, 2, 0) OP_DEFN (OP_ATR_LENGTH
, 1, 2, 0) OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) OP_DEFN (OP_ATR_MAX
, 1, 3, 0) OP_DEFN (OP_ATR_MIN, 1, 3, 0) OP_DEFN (OP_ATR_MODULUS
, 1, 1, 0) OP_DEFN (OP_ATR_POS, 1, 2, 0) OP_DEFN (OP_ATR_SIZE
, 1, 1, 0) OP_DEFN (OP_ATR_TAG, 1, 1, 0) OP_DEFN (OP_ATR_VAL,
 1, 2, 0) OP_DEFN (UNOP_QUAL, 3, 1, 0) OP_DEFN (UNOP_IN_RANGE
, 3, 1, 0) \
  OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
  OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
  OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
  OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
  OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
  OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
  OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
  OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
  OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
  OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
  OP_DEFN (OP_ATR_POS, 1, 2, 0) \
  OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
  OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
  OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
  OP_DEFN (UNOP_QUAL, 3, 1, 0) \
  OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)

8238static void
8239ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp)
8240{
switch (exp->elts[pc - 1].opcode)
  {
  default:
    operator_length_standard (exp, pc, oplenp, argsp);
    break;

8247#define OP_DEFN(op, len, args, binop) \
  case op: *oplenp = len; *argsp = args; break;
    ADA_OPERATORSOP_DEFN (OP_VAR_VALUE, 4, 0, 0) OP_DEFN (BINOP_IN_BOUNDS, 3, 2
, 0) OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) OP_DEFN (OP_ATR_FIRST
, 1, 2, 0) OP_DEFN (OP_ATR_LAST, 1, 2, 0) OP_DEFN (OP_ATR_LENGTH
, 1, 2, 0) OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) OP_DEFN (OP_ATR_MAX
, 1, 3, 0) OP_DEFN (OP_ATR_MIN, 1, 3, 0) OP_DEFN (OP_ATR_MODULUS
, 1, 1, 0) OP_DEFN (OP_ATR_POS, 1, 2, 0) OP_DEFN (OP_ATR_SIZE
, 1, 1, 0) OP_DEFN (OP_ATR_TAG, 1, 1, 0) OP_DEFN (OP_ATR_VAL,
 1, 2, 0) OP_DEFN (UNOP_QUAL, 3, 1, 0) OP_DEFN (UNOP_IN_RANGE
, 3, 1, 0);
8250#undef OP_DEFN
  }
8252}

8254static char *
8255ada_op_name (enum exp_opcode opcode)
8256{
switch (opcode)
  {
  default:
    return op_name_standard (opcode);
8261#define OP_DEFN(op, len, args, binop) case op: return #op;
    ADA_OPERATORSOP_DEFN (OP_VAR_VALUE, 4, 0, 0) OP_DEFN (BINOP_IN_BOUNDS, 3, 2
, 0) OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) OP_DEFN (OP_ATR_FIRST
, 1, 2, 0) OP_DEFN (OP_ATR_LAST, 1, 2, 0) OP_DEFN (OP_ATR_LENGTH
, 1, 2, 0) OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) OP_DEFN (OP_ATR_MAX
, 1, 3, 0) OP_DEFN (OP_ATR_MIN, 1, 3, 0) OP_DEFN (OP_ATR_MODULUS
, 1, 1, 0) OP_DEFN (OP_ATR_POS, 1, 2, 0) OP_DEFN (OP_ATR_SIZE
, 1, 1, 0) OP_DEFN (OP_ATR_TAG, 1, 1, 0) OP_DEFN (OP_ATR_VAL,
 1, 2, 0) OP_DEFN (UNOP_QUAL, 3, 1, 0) OP_DEFN (UNOP_IN_RANGE
, 3, 1, 0);
8263#undef OP_DEFN
  }
8265}

8267/* As for operator_length, but assumes PC is pointing at the first
 element of the operator, and gives meaningful results only for the 
 Ada-specific operators.  */

8271static void
8272ada_forward_operator_length (struct expression *exp, int pc,
                           int *oplenp, int *argsp)
8274{
switch (exp->elts[pc].opcode)
  {
  default:
    *oplenp = *argsp = 0;
    break;
8280#define OP_DEFN(op, len, args, binop) \
  case op: *oplenp = len; *argsp = args; break;
    ADA_OPERATORSOP_DEFN (OP_VAR_VALUE, 4, 0, 0) OP_DEFN (BINOP_IN_BOUNDS, 3, 2
, 0) OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) OP_DEFN (OP_ATR_FIRST
, 1, 2, 0) OP_DEFN (OP_ATR_LAST, 1, 2, 0) OP_DEFN (OP_ATR_LENGTH
, 1, 2, 0) OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) OP_DEFN (OP_ATR_MAX
, 1, 3, 0) OP_DEFN (OP_ATR_MIN, 1, 3, 0) OP_DEFN (OP_ATR_MODULUS
, 1, 1, 0) OP_DEFN (OP_ATR_POS, 1, 2, 0) OP_DEFN (OP_ATR_SIZE
, 1, 1, 0) OP_DEFN (OP_ATR_TAG, 1, 1, 0) OP_DEFN (OP_ATR_VAL,
 1, 2, 0) OP_DEFN (UNOP_QUAL, 3, 1, 0) OP_DEFN (UNOP_IN_RANGE
, 3, 1, 0);
8283#undef OP_DEFN
  }
8285}

8287static int
8288ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
8289{
enum exp_opcode op = exp->elts[elt].opcode;
int oplen, nargs;
int pc = elt;
int i;

ada_forward_operator_length (exp, elt, &oplen, &nargs);

switch (op)
  {
    /* Ada attributes ('Foo).  */
  case OP_ATR_FIRST:
  case OP_ATR_LAST:
  case OP_ATR_LENGTH:
  case OP_ATR_IMAGE:
  case OP_ATR_MAX:
  case OP_ATR_MIN:
  case OP_ATR_MODULUS:
  case OP_ATR_POS:
  case OP_ATR_SIZE:
  case OP_ATR_TAG:
  case OP_ATR_VAL:
    break;

  case UNOP_IN_RANGE:
  case UNOP_QUAL:
    fprintf_filtered (stream, "Type @");
    gdb_print_host_address (exp->elts[pc + 1].type, stream);
    fprintf_filtered (stream, " (");
    type_print (exp->elts[pc + 1].type, NULL((void*)0), stream, 0);
    fprintf_filtered (stream, ")");
    break;
  case BINOP_IN_BOUNDS:
    fprintf_filtered (stream, " (%d)", (int) exp->elts[pc + 2].longconst);
    break;
  case TERNOP_IN_RANGE:
    break;

  default:
    return dump_subexp_body_standard (exp, stream, elt);
  }

elt += oplen;
for (i = 0; i < nargs; i += 1)
  elt = dump_subexp (exp, stream, elt);

return elt;
8336}

8338/* The Ada extension of print_subexp (q.v.).  */

8340static void
8341ada_print_subexp (struct expression *exp, int *pos,
                struct ui_file *stream, enum precedence prec)
8343{
int oplen, nargs;
int pc = *pos;
enum exp_opcode op = exp->elts[pc].opcode;

ada_forward_operator_length (exp, pc, &oplen, &nargs);

switch (op)
  {
  default:
    print_subexp_standard (exp, pos, stream, prec);
    return;

  case OP_VAR_VALUE:
    *pos += oplen;
    fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol)(symbol_natural_name (&(exp->elts[pc + 2].symbol)->
ginfo)), stream);
    return;

  case BINOP_IN_BOUNDS:
    *pos += oplen;
    print_subexp (exp, pos, stream, PREC_SUFFIX);
    fputs_filtered (" in ", stream);
    print_subexp (exp, pos, stream, PREC_SUFFIX);
    fputs_filtered ("'range", stream);
    if (exp->elts[pc + 1].longconst > 1)
      fprintf_filtered (stream, "(%ld)",
                        (long) exp->elts[pc + 1].longconst);
    return;

  case TERNOP_IN_RANGE:
    *pos += oplen;
    if (prec >= PREC_EQUAL)
      fputs_filtered ("(", stream);
    print_subexp (exp, pos, stream, PREC_SUFFIX);
    fputs_filtered (" in ", stream);
    print_subexp (exp, pos, stream, PREC_EQUAL);
    fputs_filtered (" .. ", stream);
    print_subexp (exp, pos, stream, PREC_EQUAL);
    if (prec >= PREC_EQUAL)
      fputs_filtered (")", stream);
    return;

  case OP_ATR_FIRST:
  case OP_ATR_LAST:
  case OP_ATR_LENGTH:
  case OP_ATR_IMAGE:
  case OP_ATR_MAX:
  case OP_ATR_MIN:
  case OP_ATR_MODULUS:
  case OP_ATR_POS:
  case OP_ATR_SIZE:
  case OP_ATR_TAG:
  case OP_ATR_VAL:
    *pos += oplen;
    if (exp->elts[*pos].opcode == OP_TYPE)
      {
        if (TYPE_CODE (exp->elts[*pos + 1].type)(exp->elts[*pos + 1].type)->main_type->code != TYPE_CODE_VOID)
          LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0)(current_language->la_print_type(exp->elts[*pos + 1].type
,"",stream,0,0));
        *pos += 3;
      }
    else
      print_subexp (exp, pos, stream, PREC_SUFFIX);
    fprintf_filtered (stream, "'%s", ada_attribute_name (op));
    if (nargs > 1)
      {
        int tem;
        for (tem = 1; tem < nargs; tem += 1)
          {
            fputs_filtered ((tem == 1) ? " (" : ", ", stream);
            print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
          }
        fputs_filtered (")", stream);
      }
    return;

  case UNOP_QUAL:
    *pos += oplen;
    type_print (exp->elts[pc + 1].type, "", stream, 0);
    fputs_filtered ("'(", stream);
    print_subexp (exp, pos, stream, PREC_PREFIX);
    fputs_filtered (")", stream);
    return;

  case UNOP_IN_RANGE:
    *pos += oplen;
    print_subexp (exp, pos, stream, PREC_SUFFIX);
    fputs_filtered (" in ", stream);
    LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0)(current_language->la_print_type(exp->elts[pc + 1].type
,"",stream,1,0));
    return;
  }
8433}

8435/* Table mapping opcodes into strings for printing operators
 and precedences of the operators.  */

8438static const struct op_print ada_op_print_tab[] = {
{":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
{"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
{"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
{"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
{"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
{"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
{"=", BINOP_EQUAL, PREC_EQUAL, 0},
{"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
{"<=", BINOP_LEQ, PREC_ORDER, 0},
{">=", BINOP_GEQ, PREC_ORDER, 0},
{">", BINOP_GTR, PREC_ORDER, 0},
{"<", BINOP_LESS, PREC_ORDER, 0},
{">>", BINOP_RSH, PREC_SHIFT, 0},
{"<<", BINOP_LSH, PREC_SHIFT, 0},
{"+", BINOP_ADD, PREC_ADD, 0},
{"-", BINOP_SUB, PREC_ADD, 0},
{"&", BINOP_CONCAT, PREC_ADD, 0},
{"*", BINOP_MUL, PREC_MUL, 0},
{"/", BINOP_DIV, PREC_MUL, 0},
{"rem", BINOP_REM, PREC_MUL, 0},
{"mod", BINOP_MOD, PREC_MUL, 0},
{"**", BINOP_EXP, PREC_REPEAT, 0},
{"@", BINOP_REPEAT, PREC_REPEAT, 0},
{"-", UNOP_NEG, PREC_PREFIX, 0},
{"+", UNOP_PLUS, PREC_PREFIX, 0},
{"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
{"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
{"abs ", UNOP_ABS, PREC_PREFIX, 0},
{".all", UNOP_IND, PREC_SUFFIX, 1},
{"'access", UNOP_ADDR, PREC_SUFFIX, 1},
{"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
{NULL((void*)0), 0, 0, 0}
8471};
8472
		/* Fundamental Ada Types */

8475/* Create a fundamental Ada type using default reasonable for the current
 target machine.

 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
 define fundamental types such as "int" or "double".  Others (stabs or
 DWARF version 2, etc) do define fundamental types.  For the formats which
 don't provide fundamental types, gdb can create such types using this
 function.

 FIXME:  Some compilers distinguish explicitly signed integral types
 (signed short, signed int, signed long) from "regular" integral types
 (short, int, long) in the debugging information.  There is some dis-
 agreement as to how useful this feature is.  In particular, gcc does
 not support this.  Also, only some debugging formats allow the
 distinction to be passed on to a debugger.  For now, we always just
 use "short", "int", or "long" as the type name, for both the implicit
 and explicitly signed types.  This also makes life easier for the
 gdb test suite since we don't have to account for the differences
 in output depending upon what the compiler and debugging format
 support.  We will probably have to re-examine the issue when gdb
 starts taking it's fundamental type information directly from the
 debugging information supplied by the compiler.  fnf@cygnus.com */

8498static struct type *
8499ada_create_fundamental_type (struct objfile *objfile, int typeid)
8500{
struct type *type = NULL((void*)0);

switch (typeid)
  {
  default:
    /* FIXME:  For now, if we are asked to produce a type not in this
       language, create the equivalent of a C integer type with the
       name "<?type?>".  When all the dust settles from the type
       reconstruction work, this should probably become an error.  */
    type = init_type (TYPE_CODE_INT,
                      TARGET_INT_BIT(gdbarch_int_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      0, "<?type?>", objfile);
    warning ("internal error: no Ada fundamental type %d", typeid);
    break;
  case FT_VOID0:
    type = init_type (TYPE_CODE_VOID,
                      TARGET_CHAR_BIT8 / TARGET_CHAR_BIT8,
                      0, "void", objfile);
    break;
  case FT_CHAR2:
    type = init_type (TYPE_CODE_INT,
                      TARGET_CHAR_BIT8 / TARGET_CHAR_BIT8,
                      0, "character", objfile);
    break;
  case FT_SIGNED_CHAR3:
    type = init_type (TYPE_CODE_INT,
                      TARGET_CHAR_BIT8 / TARGET_CHAR_BIT8,
                      0, "signed char", objfile);
    break;
  case FT_UNSIGNED_CHAR4:
    type = init_type (TYPE_CODE_INT,
                      TARGET_CHAR_BIT8 / TARGET_CHAR_BIT8,
                      TYPE_FLAG_UNSIGNED(1 << 0), "unsigned char", objfile);
    break;
  case FT_SHORT5:
    type = init_type (TYPE_CODE_INT,
                      TARGET_SHORT_BIT(gdbarch_short_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      0, "short_integer", objfile);
    break;
  case FT_SIGNED_SHORT6:
    type = init_type (TYPE_CODE_INT,
                      TARGET_SHORT_BIT(gdbarch_short_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      0, "short_integer", objfile);
    break;
  case FT_UNSIGNED_SHORT7:
    type = init_type (TYPE_CODE_INT,
                      TARGET_SHORT_BIT(gdbarch_short_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      TYPE_FLAG_UNSIGNED(1 << 0), "unsigned short", objfile);
    break;
  case FT_INTEGER8:
    type = init_type (TYPE_CODE_INT,
                      TARGET_INT_BIT(gdbarch_int_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      0, "integer", objfile);
    break;
  case FT_SIGNED_INTEGER9:
    type = init_type (TYPE_CODE_INT, TARGET_INT_BIT(gdbarch_int_bit (current_gdbarch)) /
	TARGET_CHAR_BIT8, 
	0, "integer", objfile);        /* FIXME -fnf */
    break;
  case FT_UNSIGNED_INTEGER10:
    type = init_type (TYPE_CODE_INT,
                      TARGET_INT_BIT(gdbarch_int_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      TYPE_FLAG_UNSIGNED(1 << 0), "unsigned int", objfile);
    break;
  case FT_LONG11:
    type = init_type (TYPE_CODE_INT,
                      TARGET_LONG_BIT(gdbarch_long_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      0, "long_integer", objfile);
    break;
  case FT_SIGNED_LONG12:
    type = init_type (TYPE_CODE_INT,
                      TARGET_LONG_BIT(gdbarch_long_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      0, "long_integer", objfile);
    break;
  case FT_UNSIGNED_LONG13:
    type = init_type (TYPE_CODE_INT,
                      TARGET_LONG_BIT(gdbarch_long_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      TYPE_FLAG_UNSIGNED(1 << 0), "unsigned long", objfile);
    break;
  case FT_LONG_LONG14:
    type = init_type (TYPE_CODE_INT,
                      TARGET_LONG_LONG_BIT(gdbarch_long_long_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      0, "long_long_integer", objfile);
    break;
  case FT_SIGNED_LONG_LONG15:
    type = init_type (TYPE_CODE_INT,
                      TARGET_LONG_LONG_BIT(gdbarch_long_long_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      0, "long_long_integer", objfile);
    break;
  case FT_UNSIGNED_LONG_LONG16:
    type = init_type (TYPE_CODE_INT,
                      TARGET_LONG_LONG_BIT(gdbarch_long_long_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      TYPE_FLAG_UNSIGNED(1 << 0), "unsigned long long", objfile);
    break;
  case FT_FLOAT17:
    type = init_type (TYPE_CODE_FLT,
                      TARGET_FLOAT_BIT(gdbarch_float_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      0, "float", objfile);
    break;
  case FT_DBL_PREC_FLOAT18:
    type = init_type (TYPE_CODE_FLT,
                      TARGET_DOUBLE_BIT(gdbarch_double_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      0, "long_float", objfile);
    break;
  case FT_EXT_PREC_FLOAT19:
    type = init_type (TYPE_CODE_FLT,
                      TARGET_LONG_DOUBLE_BIT(gdbarch_long_double_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
                      0, "long_long_float", objfile);
    break;
  }
return (type);
8612}

8614enum ada_primitive_types {
ada_primitive_type_int,
ada_primitive_type_long,
ada_primitive_type_short,
ada_primitive_type_char,
ada_primitive_type_float,
ada_primitive_type_double,
ada_primitive_type_void,
ada_primitive_type_long_long,
ada_primitive_type_long_double,
ada_primitive_type_natural,
ada_primitive_type_positive,
ada_primitive_type_system_address,
nr_ada_primitive_types
8628};

8630static void
8631ada_language_arch_info (struct gdbarch *current_gdbarch,
	struct language_arch_info *lai)
8633{
const struct builtin_type *builtin = builtin_type (current_gdbarch);
lai->primitive_type_vector
  = GDBARCH_OBSTACK_CALLOC (current_gdbarch, nr_ada_primitive_types + 1,((struct type * *) gdbarch_obstack_zalloc ((current_gdbarch),
 (nr_ada_primitive_types + 1) * sizeof (struct type *)))
	      struct type *)((struct type * *) gdbarch_obstack_zalloc ((current_gdbarch),
 (nr_ada_primitive_types + 1) * sizeof (struct type *)));
lai->primitive_type_vector [ada_primitive_type_int] =
  init_type (TYPE_CODE_INT, TARGET_INT_BIT(gdbarch_int_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
             0, "integer", (struct objfile *) NULL((void*)0));
lai->primitive_type_vector [ada_primitive_type_long] =
  init_type (TYPE_CODE_INT, TARGET_LONG_BIT(gdbarch_long_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
             0, "long_integer", (struct objfile *) NULL((void*)0));
lai->primitive_type_vector [ada_primitive_type_short] =
  init_type (TYPE_CODE_INT, TARGET_SHORT_BIT(gdbarch_short_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
             0, "short_integer", (struct objfile *) NULL((void*)0));
lai->string_char_type = 
  lai->primitive_type_vector [ada_primitive_type_char] =
  init_type (TYPE_CODE_INT, TARGET_CHAR_BIT8 / TARGET_CHAR_BIT8,
             0, "character", (struct objfile *) NULL((void*)0));
lai->primitive_type_vector [ada_primitive_type_float] =
  init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT(gdbarch_float_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
             0, "float", (struct objfile *) NULL((void*)0));
lai->primitive_type_vector [ada_primitive_type_double] =
  init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT(gdbarch_double_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
             0, "long_float", (struct objfile *) NULL((void*)0));
lai->primitive_type_vector [ada_primitive_type_long_long] =
  init_type (TYPE_CODE_INT, TARGET_LONG_LONG_BIT(gdbarch_long_long_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
             0, "long_long_integer", (struct objfile *) NULL((void*)0));
lai->primitive_type_vector [ada_primitive_type_long_double] =
  init_type (TYPE_CODE_FLT, TARGET_LONG_DOUBLE_BIT(gdbarch_long_double_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
             0, "long_long_float", (struct objfile *) NULL((void*)0));
lai->primitive_type_vector [ada_primitive_type_natural] =
  init_type (TYPE_CODE_INT, TARGET_INT_BIT(gdbarch_int_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
             0, "natural", (struct objfile *) NULL((void*)0));
lai->primitive_type_vector [ada_primitive_type_positive] =
  init_type (TYPE_CODE_INT, TARGET_INT_BIT(gdbarch_int_bit (current_gdbarch)) / TARGET_CHAR_BIT8,
             0, "positive", (struct objfile *) NULL((void*)0));
lai->primitive_type_vector [ada_primitive_type_void] = builtin->builtin_void;

lai->primitive_type_vector [ada_primitive_type_system_address] =
  lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
                                  (struct objfile *) NULL((void*)0)));
TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])(lai->primitive_type_vector [ada_primitive_type_system_address
])->main_type->name
  = "system__address";
8676}
8677
		/* Language vector */

8680/* Not really used, but needed in the ada_language_defn.  */

8682static void
8683emit_char (int c, struct ui_file *stream, int quoter)
8684{
ada_emit_char (c, stream, quoter, 1);
8686}

8688static int
8689parse (void)
8690{
warnings_issued = 0;
return ada_parse ();
8693}

8695static const struct exp_descriptor ada_exp_descriptor = {
ada_print_subexp,
ada_operator_length,
ada_op_name,
ada_dump_subexp_body,
ada_evaluate_subexp
8701};

8703const struct language_defn ada_language_defn = {
"ada",                        /* Language name */
language_ada,
NULL((void*)0),
range_check_off,
type_check_off,
case_sensitive_on,            /* Yes, Ada is case-insensitive, but
                                 that's not quite what this means.  */
array_row_major,
&ada_exp_descriptor,
parse,
ada_error,
resolve,
ada_printchar,                /* Print a character constant */
ada_printstr,                 /* Function to print string constant */
emit_char,                    /* Function to print single char (not used) */
ada_create_fundamental_type,  /* Create fundamental type in this language */
ada_print_type,               /* Print a type using appropriate syntax */
ada_val_print,                /* Print a value using appropriate syntax */
ada_value_print,              /* Print a top-level value */
NULL((void*)0),                         /* Language specific skip_trampoline */
NULL((void*)0),                         /* value_of_this */
ada_lookup_symbol_nonlocal,   /* Looking up non-local symbols.  */
basic_lookup_transparent_type,        /* lookup_transparent_type */
ada_la_decode,                /* Language specific symbol demangler */
NULL((void*)0),                         /* Language specific class_name_from_physname */
ada_op_print_tab,             /* expression operators for printing */
0,                            /* c-style arrays */
1,                            /* String lower bound */
NULL((void*)0),
ada_get_gdb_completer_word_break_characters,
ada_language_arch_info,
LANG_MAGIC910823L
8736};

8738void
8739_initialize_ada_language (void)
8740{
add_language (&ada_language_defn);

varsize_limit = 65536;

obstack_init (&symbol_list_obstack)_obstack_begin ((&symbol_list_obstack), 0, 0, (void *(*) (
long)) xmalloc, (void (*) (void *)) xfree);

decoded_names_store = htab_create_alloc
  (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
   NULL((void*)0), xcalloc, xfree);
8750}