Fixes for solaris compiler
[deliverable/binutils-gdb.git] / gdb / ada-lang.c
index 031609df71c9871f607884e7ca694225d6a57417..b4849a944e632e989a1b97ad843a44563d8a72c5 100644 (file)
@@ -1,7 +1,6 @@
 /* Ada language support routines for GDB, the GNU debugger.
 
-   Copyright (C) 1992-1994, 1997-2000, 2003-2005, 2007-2012 Free
-   Software Foundation, Inc.
+   Copyright (C) 1992-2013 Free Software Foundation, Inc.
 
    This file is part of GDB.
 
@@ -58,6 +57,7 @@
 #include "vec.h"
 #include "stack.h"
 #include "gdb_vecs.h"
+#include "typeprint.h"
 
 #include "psymtab.h"
 #include "value.h"
@@ -127,7 +127,7 @@ static struct value *resolve_subexp (struct expression **, int *, int,
                                      struct type *);
 
 static void replace_operator_with_call (struct expression **, int, int, int,
-                                        struct symbol *, struct block *);
+                                        struct symbol *, const struct block *);
 
 static int possible_user_operator_p (enum exp_opcode, struct value **);
 
@@ -149,7 +149,7 @@ static enum ada_renaming_category parse_old_style_renaming (struct type *,
                                                            const char **);
 
 static struct symbol *find_old_style_renaming_symbol (const char *,
-                                                     struct block *);
+                                                     const struct block *);
 
 static struct type *ada_lookup_struct_elt_type (struct type *, char *,
                                                 int, int, int *);
@@ -581,6 +581,7 @@ coerce_unspec_val_to_type (struct value *val, struct type *type)
       set_value_bitsize (result, value_bitsize (val));
       set_value_bitpos (result, value_bitpos (val));
       set_value_address (result, value_address (val));
+      set_value_optimized_out (result, value_optimized_out (val));
       return result;
     }
 }
@@ -690,7 +691,7 @@ ada_discrete_type_high_bound (struct type *type)
     case TYPE_CODE_RANGE:
       return TYPE_HIGH_BOUND (type);
     case TYPE_CODE_ENUM:
-      return TYPE_FIELD_BITPOS (type, TYPE_NFIELDS (type) - 1);
+      return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
     case TYPE_CODE_BOOL:
       return 1;
     case TYPE_CODE_CHAR:
@@ -701,7 +702,7 @@ ada_discrete_type_high_bound (struct type *type)
     }
 }
 
-/* The largest value in the domain of TYPE, a discrete type, as an integer.  */
+/* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
 LONGEST
 ada_discrete_type_low_bound (struct type *type)
 {
@@ -710,7 +711,7 @@ ada_discrete_type_low_bound (struct type *type)
     case TYPE_CODE_RANGE:
       return TYPE_LOW_BOUND (type);
     case TYPE_CODE_ENUM:
-      return TYPE_FIELD_BITPOS (type, 0);
+      return TYPE_FIELD_ENUMVAL (type, 0);
     case TYPE_CODE_BOOL:
       return 0;
     case TYPE_CODE_CHAR:
@@ -2534,8 +2535,7 @@ ada_value_assign (struct value *toval, struct value *fromval)
       else
         move_bits (buffer, value_bitpos (toval),
                   value_contents (fromval), 0, bits, 0);
-      write_memory (to_addr, buffer, len);
-      observer_notify_memory_changed (to_addr, len, buffer);
+      write_memory_with_notification (to_addr, buffer, len);
 
       val = value_copy (toval);
       memcpy (value_contents_raw (val), value_contents (fromval),
@@ -3582,7 +3582,7 @@ See set/show multiple-symbol."));
             (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
              && SYMBOL_TYPE (syms[i].sym) != NULL
              && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
-          struct symtab *symtab = syms[i].sym->symtab;
+          struct symtab *symtab = SYMBOL_SYMTAB (syms[i].sym);
 
           if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
             printf_unfiltered (_("[%d] %s at %s:%d\n"),
@@ -3594,7 +3594,7 @@ See set/show multiple-symbol."));
             {
               printf_unfiltered (("[%d] "), i + first_choice);
               ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
-                              gdb_stdout, -1, 0);
+                              gdb_stdout, -1, 0, &type_print_raw_options);
               printf_unfiltered (_("'(%s) (enumeral)\n"),
                                  SYMBOL_PRINT_NAME (syms[i].sym));
             }
@@ -3718,7 +3718,7 @@ get_selections (int *choices, int n_choices, int max_results,
 static void
 replace_operator_with_call (struct expression **expp, int pc, int nargs,
                             int oplen, struct symbol *sym,
-                            struct block *block)
+                            const struct block *block)
 {
   /* A new expression, with 6 more elements (3 for funcall, 4 for function
      symbol, -oplen for operator being replaced).  */
@@ -4061,7 +4061,7 @@ ada_read_renaming_var_value (struct symbol *renaming_sym,
 
   sym_name = xstrdup (SYMBOL_LINKAGE_NAME (renaming_sym));
   old_chain = make_cleanup (xfree, sym_name);
-  expr = parse_exp_1 (&sym_name, block, 0);
+  expr = parse_exp_1 (&sym_name, 0, block, 0);
   make_cleanup (free_current_contents, &expr);
   value = evaluate_expression (expr);
 
@@ -4139,7 +4139,7 @@ ada_convert_actual (struct value *actual, struct type *formal_type0)
         }
       else
        return actual;
-      return value_cast_pointers (formal_type, result);
+      return value_cast_pointers (formal_type, result, 0);
     }
   else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
     return ada_value_ind (actual);
@@ -4231,7 +4231,7 @@ lookup_cached_symbol (const char *name, domain_enum namespace,
 
 static void
 cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
-              struct block *block)
+              const struct block *block)
 {
 }
 \f
@@ -4256,7 +4256,8 @@ static struct symbol *
 standard_lookup (const char *name, const struct block *block,
                  domain_enum domain)
 {
-  struct symbol *sym;
+  /* Initialize it just to avoid a GCC false warning.  */
+  struct symbol *sym = NULL;
 
   if (lookup_cached_symbol (name, domain, &sym, NULL))
     return sym;
@@ -4479,7 +4480,7 @@ ada_identical_enum_types_p (struct type *type1, struct type *type2)
 
   /* All enums in the type should have an identical underlying value.  */
   for (i = 0; i < TYPE_NFIELDS (type1); i++)
-    if (TYPE_FIELD_BITPOS (type1, i) != TYPE_FIELD_BITPOS (type2, i))
+    if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
       return 0;
 
   /* All enumerals should also have the same name (modulo any numerical
@@ -4803,7 +4804,7 @@ remove_irrelevant_renamings (struct ada_symbol_info *syms,
   for (i = 0; i < nsyms; i += 1)
     {
       struct symbol *sym = syms[i].sym;
-      struct block *block = syms[i].block;
+      const struct block *block = syms[i].block;
       const char *name;
       const char *suffix;
 
@@ -5470,7 +5471,7 @@ advance_wild_match (const char **namep, const char *name0, int target0)
 static int
 wild_match (const char *name, const char *patn)
 {
-  const char *p, *n;
+  const char *p;
   const char *name0 = name;
 
   while (1)
@@ -5515,7 +5516,7 @@ ada_add_block_symbols (struct obstack *obstackp,
                        domain_enum domain, struct objfile *objfile,
                        int wild)
 {
-  struct dict_iterator iter;
+  struct block_iterator iter;
   int name_len = strlen (name);
   /* A matching argument symbol, if any.  */
   struct symbol *arg_sym;
@@ -5527,9 +5528,8 @@ ada_add_block_symbols (struct obstack *obstackp,
   found_sym = 0;
   if (wild)
     {
-      for (sym = dict_iter_match_first (BLOCK_DICT (block), name,
-                                       wild_match, &iter);
-          sym != NULL; sym = dict_iter_match_next (name, wild_match, &iter))
+      for (sym = block_iter_match_first (block, name, wild_match, &iter);
+          sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
       {
         if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
                                    SYMBOL_DOMAIN (sym), domain)
@@ -5551,9 +5551,8 @@ ada_add_block_symbols (struct obstack *obstackp,
     }
   else
     {
-     for (sym = dict_iter_match_first (BLOCK_DICT (block), name,
-                                      full_match, &iter);
-          sym != NULL; sym = dict_iter_match_next (name, full_match, &iter))
+     for (sym = block_iter_match_first (block, name, full_match, &iter);
+         sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
       {
         if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
                                    SYMBOL_DOMAIN (sym), domain))
@@ -5798,12 +5797,11 @@ ada_expand_partial_symbol_name (const char *name, void *user_data)
                                   data->wild_match, data->encoded) != NULL;
 }
 
-/* Return a list of possible symbol names completing TEXT0.  The list
-   is NULL terminated.  WORD is the entire command on which completion
-   is made.  */
+/* Return a list of possible symbol names completing TEXT0.  WORD is
+   the entire command on which completion is made.  */
 
-static char **
-ada_make_symbol_completion_list (char *text0, char *word)
+static VEC (char_ptr) *
+ada_make_symbol_completion_list (char *text0, char *word, enum type_code code)
 {
   char *text;
   int text_len;
@@ -5816,7 +5814,9 @@ ada_make_symbol_completion_list (char *text0, char *word)
   struct objfile *objfile;
   struct block *b, *surrounding_static_block = 0;
   int i;
-  struct dict_iterator iter;
+  struct block_iterator iter;
+
+  gdb_assert (code == TYPE_CODE_UNDEF);
 
   if (text0[0] == '<')
     {
@@ -5915,24 +5915,7 @@ ada_make_symbol_completion_list (char *text0, char *word)
     }
   }
 
-  /* Append the closing NULL entry.  */
-  VEC_safe_push (char_ptr, completions, NULL);
-
-  /* Make a copy of the COMPLETIONS VEC before we free it, and then
-     return the copy.  It's unfortunate that we have to make a copy
-     of an array that we're about to destroy, but there is nothing much
-     we can do about it.  Fortunately, it's typically not a very large
-     array.  */
-  {
-    const size_t completions_size = 
-      VEC_length (char_ptr, completions) * sizeof (char *);
-    char **result = xmalloc (completions_size);
-    
-    memcpy (result, VEC_address (char_ptr, completions), completions_size);
-
-    VEC_free (char_ptr, completions);
-    return result;
-  }
+  return completions;
 }
 
                                 /* Field Access */
@@ -5955,6 +5938,19 @@ ada_is_dispatch_table_ptr_type (struct type *type)
   return (strcmp (name, "ada__tags__dispatch_table") == 0);
 }
 
+/* Return non-zero if TYPE is an interface tag.  */
+
+static int
+ada_is_interface_tag (struct type *type)
+{
+  const char *name = TYPE_NAME (type);
+
+  if (name == NULL)
+    return 0;
+
+  return (strcmp (name, "ada__tags__interface_tag") == 0);
+}
+
 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
    to be invisible to users.  */
 
@@ -5985,9 +5981,11 @@ ada_is_ignored_field (struct type *type, int field_num)
       return 1;
   }
 
-  /* If this is the dispatch table of a tagged type, then ignore.  */
+  /* If this is the dispatch table of a tagged type or an interface tag,
+     then ignore.  */
   if (ada_is_tagged_type (type, 1)
-      && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num)))
+      && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
+         || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
     return 1;
 
   /* Not a special field, so it should not be ignored.  */
@@ -6027,6 +6025,15 @@ ada_tag_type (struct value *val)
   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
 }
 
+/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
+   retired at Ada 05).  */
+
+static int
+is_ada95_tag (struct value *tag)
+{
+  return ada_value_struct_elt (tag, "tsd", 1) != NULL;
+}
+
 /* The value of the tag on VAL.  */
 
 struct value *
@@ -6070,6 +6077,88 @@ type_from_tag (struct value *tag)
   return NULL;
 }
 
+/* Given a value OBJ of a tagged type, return a value of this
+   type at the base address of the object.  The base address, as
+   defined in Ada.Tags, it is the address of the primary tag of
+   the object, and therefore where the field values of its full
+   view can be fetched.  */
+
+struct value *
+ada_tag_value_at_base_address (struct value *obj)
+{
+  volatile struct gdb_exception e;
+  struct value *val;
+  LONGEST offset_to_top = 0;
+  struct type *ptr_type, *obj_type;
+  struct value *tag;
+  CORE_ADDR base_address;
+
+  obj_type = value_type (obj);
+
+  /* It is the responsability of the caller to deref pointers.  */
+
+  if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
+      || TYPE_CODE (obj_type) == TYPE_CODE_REF)
+    return obj;
+
+  tag = ada_value_tag (obj);
+  if (!tag)
+    return obj;
+
+  /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
+
+  if (is_ada95_tag (tag))
+    return obj;
+
+  ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
+  ptr_type = lookup_pointer_type (ptr_type);
+  val = value_cast (ptr_type, tag);
+  if (!val)
+    return obj;
+
+  /* It is perfectly possible that an exception be raised while
+     trying to determine the base address, just like for the tag;
+     see ada_tag_name for more details.  We do not print the error
+     message for the same reason.  */
+
+  TRY_CATCH (e, RETURN_MASK_ERROR)
+    {
+      offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
+    }
+
+  if (e.reason < 0)
+    return obj;
+
+  /* If offset is null, nothing to do.  */
+
+  if (offset_to_top == 0)
+    return obj;
+
+  /* -1 is a special case in Ada.Tags; however, what should be done
+     is not quite clear from the documentation.  So do nothing for
+     now.  */
+
+  if (offset_to_top == -1)
+    return obj;
+
+  base_address = value_address (obj) - offset_to_top;
+  tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
+
+  /* Make sure that we have a proper tag at the new address.
+     Otherwise, offset_to_top is bogus (which can happen when
+     the object is not initialized yet).  */
+
+  if (!tag)
+    return obj;
+
+  obj_type = type_from_tag (tag);
+
+  if (!obj_type)
+    return obj;
+
+  return value_from_contents_and_address (obj_type, NULL, base_address);
+}
+
 /* Return the "ada__tags__type_specific_data" type.  */
 
 static struct type *
@@ -6725,9 +6814,9 @@ ada_value_struct_elt (struct value *arg, char *name, int no_err)
       CORE_ADDR address;
 
       if (TYPE_CODE (t) == TYPE_CODE_PTR)
-        address = value_as_address (arg);
+       address = value_address (ada_value_ind (arg));
       else
-        address = unpack_pointer (t, value_contents (arg));
+       address = value_address (ada_coerce_ref (arg));
 
       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
       if (find_struct_field (name, t1, 0,
@@ -7003,6 +7092,9 @@ ada_value_ind (struct value *val0)
 {
   struct value *val = value_ind (val0);
 
+  if (ada_is_tagged_type (value_type (val), 0))
+    val = ada_tag_value_at_base_address (val);
+
   return ada_to_fixed_value (val);
 }
 
@@ -7017,6 +7109,10 @@ ada_coerce_ref (struct value *val0)
       struct value *val = val0;
 
       val = coerce_ref (val);
+
+      if (ada_is_tagged_type (value_type (val), 0))
+       val = ada_tag_value_at_base_address (val);
+
       return ada_to_fixed_value (val);
     }
   else
@@ -7100,7 +7196,7 @@ ada_find_any_type (const char *name)
    Return symbol if found, and NULL otherwise.  */
 
 struct symbol *
-ada_find_renaming_symbol (struct symbol *name_sym, struct block *block)
+ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
 {
   const char *name = SYMBOL_LINKAGE_NAME (name_sym);
   struct symbol *sym;
@@ -7122,7 +7218,7 @@ ada_find_renaming_symbol (struct symbol *name_sym, struct block *block)
 }
 
 static struct symbol *
-find_old_style_renaming_symbol (const char *name, struct block *block)
+find_old_style_renaming_symbol (const char *name, const struct block *block)
 {
   const struct symbol *function_sym = block_linkage_function (block);
   char *rename;
@@ -7445,7 +7541,7 @@ ada_template_to_fixed_record_type_1 (struct type *type,
     {
       off = align_value (off, field_alignment (type, f))
        + TYPE_FIELD_BITPOS (type, f);
-      TYPE_FIELD_BITPOS (rtype, f) = off;
+      SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
       TYPE_FIELD_BITSIZE (rtype, f) = 0;
 
       if (ada_is_variant_part (type, f))
@@ -7523,25 +7619,35 @@ ada_template_to_fixed_record_type_1 (struct type *type,
         }
       else
         {
-          struct type *field_type = TYPE_FIELD_TYPE (type, f);
-
-         /* If our field is a typedef type (most likely a typedef of
-            a fat pointer, encoding an array access), then we need to
-            look at its target type to determine its characteristics.
-            In particular, we would miscompute the field size if we took
-            the size of the typedef (zero), instead of the size of
-            the target type.  */
-         if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
-           field_type = ada_typedef_target_type (field_type);
-
-          TYPE_FIELD_TYPE (rtype, f) = field_type;
+         /* Note: If this field's type is a typedef, it is important
+            to preserve the typedef layer.
+
+            Otherwise, we might be transforming a typedef to a fat
+            pointer (encoding a pointer to an unconstrained array),
+            into a basic fat pointer (encoding an unconstrained
+            array).  As both types are implemented using the same
+            structure, the typedef is the only clue which allows us
+            to distinguish between the two options.  Stripping it
+            would prevent us from printing this field appropriately.  */
+          TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
           TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
           if (TYPE_FIELD_BITSIZE (type, f) > 0)
             fld_bit_len =
               TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
           else
-            fld_bit_len =
-              TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
+           {
+             struct type *field_type = TYPE_FIELD_TYPE (type, f);
+
+             /* We need to be careful of typedefs when computing
+                the length of our field.  If this is a typedef,
+                get the length of the target type, not the length
+                of the typedef.  */
+             if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
+               field_type = ada_typedef_target_type (field_type);
+
+              fld_bit_len =
+                TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
+           }
         }
       if (off + fld_bit_len > bit_len)
         bit_len = off + fld_bit_len;
@@ -7990,14 +8096,20 @@ ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
 
         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
           {
-            struct type *real_type =
-              type_from_tag (value_tag_from_contents_and_address
-                             (fixed_record_type,
-                              valaddr,
-                              address));
-
+           struct value *tag =
+             value_tag_from_contents_and_address
+             (fixed_record_type,
+              valaddr,
+              address);
+           struct type *real_type = type_from_tag (tag);
+           struct value *obj =
+             value_from_contents_and_address (fixed_record_type,
+                                              valaddr,
+                                              address);
             if (real_type != NULL)
-              return to_fixed_record_type (real_type, valaddr, address, NULL);
+              return to_fixed_record_type
+               (real_type, NULL,
+                value_address (ada_tag_value_at_base_address (obj)), NULL);
           }
 
         /* Check to see if there is a parallel ___XVZ variable.
@@ -8298,7 +8410,7 @@ pos_atr (struct value *arg)
 
       for (i = 0; i < TYPE_NFIELDS (type); i += 1)
         {
-          if (v == TYPE_FIELD_BITPOS (type, i))
+          if (v == TYPE_FIELD_ENUMVAL (type, i))
             return i;
         }
       error (_("enumeration value is invalid: can't find 'POS"));
@@ -8329,7 +8441,7 @@ value_val_atr (struct type *type, struct value *arg)
 
       if (pos < 0 || pos >= TYPE_NFIELDS (type))
         error (_("argument to 'VAL out of range"));
-      return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
+      return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
     }
   else
     return value_from_longest (type, value_as_long (arg));
@@ -8638,6 +8750,72 @@ cast_from_fixed (struct type *type, struct value *arg)
   return value_from_double (type, val);
 }
 
+/* Given two array types T1 and T2, return nonzero iff both arrays
+   contain the same number of elements.  */
+
+static int
+ada_same_array_size_p (struct type *t1, struct type *t2)
+{
+  LONGEST lo1, hi1, lo2, hi2;
+
+  /* Get the array bounds in order to verify that the size of
+     the two arrays match.  */
+  if (!get_array_bounds (t1, &lo1, &hi1)
+      || !get_array_bounds (t2, &lo2, &hi2))
+    error (_("unable to determine array bounds"));
+
+  /* To make things easier for size comparison, normalize a bit
+     the case of empty arrays by making sure that the difference
+     between upper bound and lower bound is always -1.  */
+  if (lo1 > hi1)
+    hi1 = lo1 - 1;
+  if (lo2 > hi2)
+    hi2 = lo2 - 1;
+
+  return (hi1 - lo1 == hi2 - lo2);
+}
+
+/* Assuming that VAL is an array of integrals, and TYPE represents
+   an array with the same number of elements, but with wider integral
+   elements, return an array "casted" to TYPE.  In practice, this
+   means that the returned array is built by casting each element
+   of the original array into TYPE's (wider) element type.  */
+
+static struct value *
+ada_promote_array_of_integrals (struct type *type, struct value *val)
+{
+  struct type *elt_type = TYPE_TARGET_TYPE (type);
+  LONGEST lo, hi;
+  struct value *res;
+  LONGEST i;
+
+  /* Verify that both val and type are arrays of scalars, and
+     that the size of val's elements is smaller than the size
+     of type's element.  */
+  gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
+  gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
+  gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
+  gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
+  gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
+             > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
+
+  if (!get_array_bounds (type, &lo, &hi))
+    error (_("unable to determine array bounds"));
+
+  res = allocate_value (type);
+
+  /* Promote each array element.  */
+  for (i = 0; i < hi - lo + 1; i++)
+    {
+      struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
+
+      memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
+             value_contents_all (elt), TYPE_LENGTH (elt_type));
+    }
+
+  return res;
+}
+
 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
    return the converted value.  */
 
@@ -8662,9 +8840,21 @@ coerce_for_assign (struct type *type, struct value *val)
   if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
       && TYPE_CODE (type) == TYPE_CODE_ARRAY)
     {
-      if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
-          || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
-          != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
+      if (!ada_same_array_size_p (type, type2))
+       error (_("cannot assign arrays of different length"));
+
+      if (is_integral_type (TYPE_TARGET_TYPE (type))
+         && is_integral_type (TYPE_TARGET_TYPE (type2))
+         && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
+              < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
+       {
+         /* Allow implicit promotion of the array elements to
+            a wider type.  */
+         return ada_promote_array_of_integrals (type, val);
+       }
+
+      if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
+          != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
         error (_("Incompatible types in assignment"));
       deprecated_set_value_type (val, type);
     }
@@ -9383,7 +9573,9 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
     default:
       *pos -= 1;
       arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
-      arg1 = unwrap_value (arg1);
+
+      if (noside == EVAL_NORMAL)
+       arg1 = unwrap_value (arg1);
 
       /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
          then we need to perform the conversion manually, because
@@ -9620,19 +9812,31 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
                a fixed type would result in the loss of that type name,
                thus preventing us from printing the name of the ancestor
                type in the type description.  */
-            struct type *actual_type;
-
             arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
-            actual_type = type_from_tag (ada_value_tag (arg1));
-            if (actual_type == NULL)
-              /* If, for some reason, we were unable to determine
-                 the actual type from the tag, then use the static
-                 approximation that we just computed as a fallback.
-                 This can happen if the debugging information is
-                 incomplete, for instance.  */
-              actual_type = type;
-
-            return value_zero (actual_type, not_lval);
+
+           if (TYPE_CODE (type) != TYPE_CODE_REF)
+             {
+               struct type *actual_type;
+
+               actual_type = type_from_tag (ada_value_tag (arg1));
+               if (actual_type == NULL)
+                 /* If, for some reason, we were unable to determine
+                    the actual type from the tag, then use the static
+                    approximation that we just computed as a fallback.
+                    This can happen if the debugging information is
+                    incomplete, for instance.  */
+                 actual_type = type;
+               return value_zero (actual_type, not_lval);
+             }
+           else
+             {
+               /* In the case of a ref, ada_coerce_ref takes care
+                  of determining the actual type.  But the evaluation
+                  should return a ref as it should be valid to ask
+                  for its address; so rebuild a ref after coerce.  */
+               arg1 = ada_coerce_ref (arg1);
+               return value_ref (arg1);
+             }
           }
 
           *pos += 4;
@@ -9717,8 +9921,25 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
         {
         case TYPE_CODE_FUNC:
           if (noside == EVAL_AVOID_SIDE_EFFECTS)
-            return allocate_value (TYPE_TARGET_TYPE (type));
+           {
+             struct type *rtype = TYPE_TARGET_TYPE (type);
+
+             if (TYPE_GNU_IFUNC (type))
+               return allocate_value (TYPE_TARGET_TYPE (rtype));
+             return allocate_value (rtype);
+           }
           return call_function_by_hand (argvec[0], nargs, argvec + 1);
+       case TYPE_CODE_INTERNAL_FUNCTION:
+         if (noside == EVAL_AVOID_SIDE_EFFECTS)
+           /* We don't know anything about what the internal
+              function might return, but we have to return
+              something.  */
+           return value_zero (builtin_type (exp->gdbarch)->builtin_int,
+                              not_lval);
+         else
+           return call_internal_function (exp->gdbarch, exp->language_defn,
+                                          argvec[0], nargs, argvec + 1);
+
         case TYPE_CODE_STRUCT:
           {
             int arity;
@@ -10804,7 +11025,6 @@ static void
 ada_exception_support_info_sniffer (void)
 {
   struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
-  struct symbol *sym;
 
   /* If the exception info is already known, then no need to recompute it.  */
   if (data->exception_info != NULL)
@@ -10863,6 +11083,7 @@ is_known_support_routine (struct frame_info *frame)
   const char *func_name;
   enum language func_lang;
   int i;
+  const char *fullname;
 
   /* If this code does not have any debugging information (no symtab),
      This cannot be any user code.  */
@@ -10877,7 +11098,8 @@ is_known_support_routine (struct frame_info *frame)
      for the user.  This should also take care of case such as VxWorks
      where the kernel has some debugging info provided for a few units.  */
 
-  if (symtab_to_fullname (sal.symtab) == NULL)
+  fullname = symtab_to_fullname (sal.symtab);
+  if (access (fullname, R_OK) != 0)
     return 1;
 
   /* Check the unit filename againt the Ada runtime file naming.
@@ -10888,7 +11110,7 @@ is_known_support_routine (struct frame_info *frame)
   for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
     {
       re_comp (known_runtime_file_name_patterns[i]);
-      if (re_exec (sal.symtab->filename))
+      if (re_exec (lbasename (sal.symtab->filename)))
         return 1;
       if (sal.symtab->objfile != NULL
           && re_exec (sal.symtab->objfile->name))
@@ -11144,7 +11366,8 @@ create_excep_cond_exprs (struct ada_catchpoint *c)
          s = cond_string;
          TRY_CATCH (e, RETURN_MASK_ERROR)
            {
-             exp = parse_exp_1 (&s, block_for_pc (bl->address), 0);
+             exp = parse_exp_1 (&s, bl->address,
+                                block_for_pc (bl->address), 0);
            }
          if (e.reason < 0)
            warning (_("failed to reevaluate internal exception condition "
@@ -11570,7 +11793,7 @@ allocate_location_catch_assert (struct breakpoint *self)
 static void
 re_set_catch_assert (struct breakpoint *b)
 {
-  return re_set_exception (ex_catch_assert, b);
+  re_set_exception (ex_catch_assert, b);
 }
 
 static void
@@ -12260,7 +12483,8 @@ ada_print_subexp (struct expression *exp, int *pos,
       if (exp->elts[*pos].opcode == OP_TYPE)
         {
           if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
-            LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
+            LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
+                          &type_print_raw_options);
           *pos += 3;
         }
       else
@@ -12290,7 +12514,8 @@ ada_print_subexp (struct expression *exp, int *pos,
       /* XXX: sprint_subexp */
       print_subexp (exp, pos, stream, PREC_SUFFIX);
       fputs_filtered (" in ", stream);
-      LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
+      LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
+                    &type_print_raw_options);
       return;
 
     case OP_DISCRETE_RANGE:
@@ -12502,7 +12727,6 @@ const struct language_defn ada_language_defn = {
   "ada",                        /* Language name */
   language_ada,
   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,
@@ -12661,5 +12885,5 @@ With an argument, catch only exceptions with the given name."),
   /* Setup per-inferior data.  */
   observer_attach_inferior_exit (ada_inferior_exit);
   ada_inferior_data
-    = register_inferior_data_with_cleanup (ada_inferior_data_cleanup);
+    = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
 }
This page took 0.036849 seconds and 4 git commands to generate.