re PR fortran/62044 (ICE in USE statement with RENAME for extended derived type)

2015-01-27  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/62044
	* resolve.c (resolve_allocate_expr): If the default initializer
	is NULL, keep the original MOLD expression so that the correct
	typespec is available.

2015-01-27  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/62044
	* gfortran.dg/allocate_with_mold_1.f90: New test

From-SVN: r220191

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index cbeb606d2ea29c630f23490a43bb73f2b3a2c9d6..94b436c1081d29dfec35c8a962d0dac85d364a85 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2015-01-27  Paul Thomas  <pault@gcc.gnu.org>
+
+       Backport from mainline
+       PR fortran/62044
+       * resolve.c (resolve_allocate_expr): If the default initializer
+       is NULL, keep the original MOLD expression so that the correct
+       typespec is available.
+
 2015-01-27  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/64771

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a23f6d44cea81d8d6379d1d55a7f589759fc9430..54d71763e2c40a7b8d3fbdd868689f1f45c7341e 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1815,7 +1815,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
              && sym->ns->proc_name->attr.flavor != FL_MODULE)
            {
              if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is"
-                                  " used as actual argument at %L", 
+                                  " used as actual argument at %L",
                                   sym->name, &e->where))
                goto cleanup;
            }
@@ -2435,7 +2435,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
 
       if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
                                   reason, sizeof(reason), NULL, NULL))
-       {       
+       {
          gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ",
                    sym->name, &sym->declared_at, reason);
          goto done;
@@ -2449,7 +2449,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
       if (sym->attr.if_source != IFSRC_IFBODY)
        gfc_procedure_use (def_sym, actual, where);
     }
-    
+
 done:
   gfc_errors_to_warnings (0);
 
@@ -2551,7 +2551,7 @@ generic:
 
   if (intr)
     {
-      if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL, 
+      if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
                                                 NULL, false))
        return false;
       return resolve_structure_cons (expr, 0);
@@ -2853,7 +2853,7 @@ resolve_function (gfc_expr *expr)
   no_formal_args = sym && is_external_proc (sym)
                       && gfc_sym_get_dummy_args (sym) == NULL;
 
-  if (!resolve_actual_arglist (expr->value.function.actual, 
+  if (!resolve_actual_arglist (expr->value.function.actual,
                               p, no_formal_args))
     {
       inquiry_argument = false;
@@ -4122,7 +4122,7 @@ gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
     }
 
   if (index->ts.type == BT_REAL)
-    if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L", 
+    if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
                         &index->where))
       return false;
 
@@ -5782,7 +5782,7 @@ resolve_typebound_function (gfc_expr* e)
 
   /* Get the CLASS declared type.  */
   declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
-  
+
   if (!resolve_fl_derived (declared))
     return false;
 
@@ -5982,8 +5982,8 @@ resolve_ppc_call (gfc_code* c)
 
   c->ext.actual = c->expr1->value.compcall.actual;
 
-  if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc, 
-                              !(comp->ts.interface 
+  if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc,
+                              !(comp->ts.interface
                                 && comp->ts.interface->formal)))
     return false;
 
@@ -6017,8 +6017,8 @@ resolve_expr_ppc (gfc_expr* e)
   if (!resolve_ref (e))
     return false;
 
-  if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc, 
-                              !(comp->ts.interface 
+  if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
+                              !(comp->ts.interface
                                 && comp->ts.interface->formal)))
     return false;
 
@@ -6230,19 +6230,19 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
   if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
     return false;
 
-  if (!gfc_check_vardef_context (iter->var, false, false, own_scope, 
+  if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
                                 _("iterator variable")))
     return false;
 
-  if (!gfc_resolve_iterator_expr (iter->start, real_ok, 
+  if (!gfc_resolve_iterator_expr (iter->start, real_ok,
                                  "Start expression in DO loop"))
     return false;
 
-  if (!gfc_resolve_iterator_expr (iter->end, real_ok, 
+  if (!gfc_resolve_iterator_expr (iter->end, real_ok,
                                  "End expression in DO loop"))
     return false;
 
-  if (!gfc_resolve_iterator_expr (iter->step, real_ok, 
+  if (!gfc_resolve_iterator_expr (iter->step, real_ok,
                                  "Step expression in DO loop"))
     return false;
 
@@ -6500,10 +6500,10 @@ resolve_deallocate_expr (gfc_expr *e)
     }
 
   if (pointer
-      && !gfc_check_vardef_context (e, true, true, false, 
+      && !gfc_check_vardef_context (e, true, true, false,
                                    _("DEALLOCATE object")))
     return false;
-  if (!gfc_check_vardef_context (e, false, true, false, 
+  if (!gfc_check_vardef_context (e, false, true, false,
                                 _("DEALLOCATE object")))
     return false;
 
@@ -6853,10 +6853,10 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
   e2 = remove_last_array_ref (e);
   t = true;
   if (t && pointer)
-    t = gfc_check_vardef_context (e2, true, true, false, 
+    t = gfc_check_vardef_context (e2, true, true, false,
                                  _("ALLOCATE object"));
   if (t)
-    t = gfc_check_vardef_context (e2, false, true, false, 
+    t = gfc_check_vardef_context (e2, false, true, false,
                                  _("ALLOCATE object"));
   gfc_free_expr (e2);
   if (!t)
@@ -6899,9 +6899,12 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
     {
       /* Default initialization via MOLD (non-polymorphic).  */
       gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
-      gfc_resolve_expr (rhs);
-      gfc_free_expr (code->expr3);
-      code->expr3 = rhs;
+      if (rhs != NULL)
+       {
+         gfc_resolve_expr (rhs);
+         gfc_free_expr (code->expr3);
+         code->expr3 = rhs;
+       }
     }
 
   if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
@@ -7055,7 +7058,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
   /* Check the stat variable.  */
   if (stat)
     {
-      gfc_check_vardef_context (stat, false, false, false, 
+      gfc_check_vardef_context (stat, false, false, false,
                                _("STAT variable"));
 
       if ((stat->ts.type != BT_INTEGER
@@ -8268,7 +8271,7 @@ resolve_transfer (gfc_code *code)
      code->ext.dt may be NULL if the TRANSFER is related to
      an INQUIRE statement -- but in this case, we are not reading, either.  */
   if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
-      && !gfc_check_vardef_context (exp, false, false, false, 
+      && !gfc_check_vardef_context (exp, false, false, false,
                                    _("item in READ")))
     return;
 
@@ -8398,7 +8401,7 @@ resolve_lock_unlock (gfc_code *code)
               &code->expr2->where);
 
   if (code->expr2
-      && !gfc_check_vardef_context (code->expr2, false, false, false, 
+      && !gfc_check_vardef_context (code->expr2, false, false, false,
                                    _("STAT variable")))
     return;
 
@@ -8410,7 +8413,7 @@ resolve_lock_unlock (gfc_code *code)
               &code->expr3->where);
 
   if (code->expr3
-      && !gfc_check_vardef_context (code->expr3, false, false, false, 
+      && !gfc_check_vardef_context (code->expr3, false, false, false,
                                    _("ERRMSG variable")))
     return;
 
@@ -8422,7 +8425,7 @@ resolve_lock_unlock (gfc_code *code)
               "variable", &code->expr4->where);
 
   if (code->expr4
-      && !gfc_check_vardef_context (code->expr4, false, false, false, 
+      && !gfc_check_vardef_context (code->expr4, false, false, false,
                                    _("ACQUIRED_LOCK variable")))
     return;
 }
@@ -9081,7 +9084,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
 
   if (rhs->is_boz
       && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
-                         "a DATA statement and outside INT/REAL/DBLE/CMPLX", 
+                         "a DATA statement and outside INT/REAL/DBLE/CMPLX",
                          &code->loc))
     return false;
 
@@ -9882,7 +9885,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
          if (!t)
            break;
 
-         if (!gfc_check_vardef_context (code->expr1, false, false, false, 
+         if (!gfc_check_vardef_context (code->expr1, false, false, false,
                                         _("assignment")))
            break;
 
@@ -10690,7 +10693,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
              return false;
            }
          else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
-                                   "'%s' at %L may not be ALLOCATABLE", 
+                                   "'%s' at %L may not be ALLOCATABLE",
                                    sym->name, &sym->declared_at))
            return false;
        }
@@ -11021,8 +11024,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
              && !gfc_check_symbol_access (arg->sym->ts.u.derived)
              && !gfc_notify_std (GFC_STD_F2003, "'%s' is of a PRIVATE type "
                                  "and cannot be a dummy argument"
-                                 " of '%s', which is PUBLIC at %L", 
-                                 arg->sym->name, sym->name, 
+                                 " of '%s', which is PUBLIC at %L",
+                                 arg->sym->name, sym->name,
                                  &sym->declared_at))
            {
              /* Stop this message from recurring.  */
@@ -11044,8 +11047,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
                  && !gfc_notify_std (GFC_STD_F2003, "Procedure '%s' in "
                                      "PUBLIC interface '%s' at %L "
                                      "takes dummy arguments of '%s' which "
-                                     "is PRIVATE", iface->sym->name, 
-                                     sym->name, &iface->sym->declared_at, 
+                                     "is PRIVATE", iface->sym->name,
+                                     sym->name, &iface->sym->declared_at,
                                      gfc_typename(&arg->sym->ts)))
                {
                  /* Stop this message from recurring.  */
@@ -11068,8 +11071,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
                  && !gfc_notify_std (GFC_STD_F2003, "Procedure '%s' in "
                                      "PUBLIC interface '%s' at %L takes "
                                      "dummy arguments of '%s' which is "
-                                     "PRIVATE", iface->sym->name, 
-                                     sym->name, &iface->sym->declared_at, 
+                                     "PRIVATE", iface->sym->name,
+                                     sym->name, &iface->sym->declared_at,
                                      gfc_typename(&arg->sym->ts)))
                {
                  /* Stop this message from recurring.  */
@@ -11180,7 +11183,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
       gfc_formal_arglist *curr_arg;
       int has_non_interop_arg = 0;
 
-      if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, 
+      if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
                              sym->common_block))
         {
           /* Clear these to prevent looking at them again if there was an
@@ -12023,7 +12026,7 @@ resolve_typebound_procedures (gfc_symbol* derived)
   for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
     {
       gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
-      if (p && !resolve_typebound_intrinsic_op (derived, 
+      if (p && !resolve_typebound_intrinsic_op (derived,
                                                (gfc_intrinsic_op)op, p))
        resolve_bindings_result = false;
     }
@@ -12475,7 +12478,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
          && !gfc_check_symbol_access (c->ts.u.derived)
          && !gfc_notify_std (GFC_STD_F2003, "the component '%s' is a "
                              "PRIVATE type and cannot be a component of "
-                             "'%s', which is PUBLIC at %L", c->name, 
+                             "'%s', which is PUBLIC at %L", c->name,
                              sym->name, &sym->declared_at))
        return false;
 
@@ -12549,8 +12552,8 @@ resolve_fl_derived0 (gfc_symbol *sym)
            && sym != c->ts.u.derived)
        add_dt_to_dt_list (c->ts.u.derived);
 
-      if (!gfc_resolve_array_spec (c->as, 
-                                  !(c->attr.pointer || c->attr.proc_pointer 
+      if (!gfc_resolve_array_spec (c->as,
+                                  !(c->attr.pointer || c->attr.proc_pointer
                                     || c->attr.allocatable)))
        return false;
 
@@ -12599,13 +12602,13 @@ resolve_fl_derived (gfc_symbol *sym)
          || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
       && !gfc_notify_std (GFC_STD_F2003, "Generic name '%s' of function "
                          "'%s' at %L being the same name as derived "
-                         "type at %L", sym->name, 
-                         gen_dt->generic->sym == sym 
-                         ? gen_dt->generic->next->sym->name 
-                         : gen_dt->generic->sym->name, 
-                         gen_dt->generic->sym == sym 
-                         ? &gen_dt->generic->next->sym->declared_at 
-                         : &gen_dt->generic->sym->declared_at, 
+                         "type at %L", sym->name,
+                         gen_dt->generic->sym == sym
+                         ? gen_dt->generic->next->sym->name
+                         : gen_dt->generic->sym->name,
+                         gen_dt->generic->sym == sym
+                         ? &gen_dt->generic->next->sym->declared_at
+                         : &gen_dt->generic->sym->declared_at,
                          &sym->declared_at))
     return false;
 
@@ -12660,13 +12663,13 @@ resolve_fl_namelist (gfc_symbol *sym)
 
       if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
          && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
-                             "with assumed shape in namelist '%s' at %L", 
+                             "with assumed shape in namelist '%s' at %L",
                              nl->sym->name, sym->name, &sym->declared_at))
        return false;
 
       if (is_non_constant_shape_array (nl->sym)
          && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
-                             "with nonconstant shape in namelist '%s' at %L", 
+                             "with nonconstant shape in namelist '%s' at %L",
                              nl->sym->name, sym->name, &sym->declared_at))
        return false;
 
@@ -12675,7 +12678,7 @@ resolve_fl_namelist (gfc_symbol *sym)
              || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
          && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object '%s' with "
                              "nonconstant character length in "
-                             "namelist '%s' at %L", nl->sym->name, 
+                             "namelist '%s' at %L", nl->sym->name,
                              sym->name, &sym->declared_at))
        return false;
 
@@ -12695,7 +12698,7 @@ resolve_fl_namelist (gfc_symbol *sym)
        {
          if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object '%s' in "
                               "namelist '%s' at %L with ALLOCATABLE "
-                              "or POINTER components", nl->sym->name, 
+                              "or POINTER components", nl->sym->name,
                               sym->name, &sym->declared_at))
            return false;
 
@@ -13265,10 +13268,10 @@ resolve_symbol (gfc_symbol *sym)
       && gfc_check_symbol_access (sym)
       && !gfc_check_symbol_access (sym->ts.u.derived)
       && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s '%s' at %L of PRIVATE "
-                         "derived type '%s'", 
-                         (sym->attr.flavor == FL_PARAMETER) 
-                         ? "parameter" : "variable", 
-                         sym->name, &sym->declared_at, 
+                         "derived type '%s'",
+                         (sym->attr.flavor == FL_PARAMETER)
+                         ? "parameter" : "variable",
+                         sym->name, &sym->declared_at,
                          sym->ts.u.derived->name))
     return;
 
@@ -13411,15 +13414,15 @@ resolve_symbol (gfc_symbol *sym)
       if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
          && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument '%s' at "
                              "%L with non-C_Bool kind in BIND(C) procedure "
-                             "'%s'", sym->name, &sym->declared_at, 
+                             "'%s'", sym->name, &sym->declared_at,
                              sym->ns->proc_name->name))
        return;
       else if (!gfc_logical_kinds[i].c_bool
               && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
                                   "'%s' at %L with non-C_Bool kind in "
-                                  "BIND(C) procedure '%s'", sym->name, 
-                                  &sym->declared_at, 
-                                  sym->attr.function ? sym->name 
+                                  "BIND(C) procedure '%s'", sym->name,
+                                  &sym->declared_at,
+                                  sym->attr.function ? sym->name
                                   : sym->ns->proc_name->name))
        return;
     }
@@ -14622,7 +14625,7 @@ resolve_types (gfc_namespace *ns)
       unsigned letter;
       for (letter = 0; letter != GFC_LETTERS; ++letter)
        if (ns->set_flag[letter]
-           && !resolve_typespec_used (&ns->default_type[letter], 
+           && !resolve_typespec_used (&ns->default_type[letter],
                                       &ns->implicit_loc[letter], NULL))
          return;
     }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ae59017e04e72e3b02149eabb37a9ef00acfc997..90d8fa65b6d9cc5059672dbc90d1e3f20edf34ac 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2015-01-27  Paul Thomas  <pault@gcc.gnu.org>
+
+       Backport from mainline
+       PR fortran/62044
+       * gfortran.dg/allocate_with_mold_1.f90: New test
+
 2015-01-27  Janus Weil  <janus@gcc.gnu.org>
 
        Backport from mainline
@@ -60,7 +66,7 @@
        * g++.dg/tsan/atomic_free.C: Likewise.
        * g++.dg/tsan/atomic_free2.C: Likewise.
        * g++.dg/tsan/cond_race.C: Likewise.
-       * g++.dg/tsan/tsan_barrier.h: Copied from c-c++-common/tsan. 
+       * g++.dg/tsan/tsan_barrier.h: Copied from c-c++-common/tsan.
 
 2015-01-15  Eric Botcazou  <ebotcazou@adacore.com>
 

diff --git a/gcc/testsuite/gfortran.dg/allocate_with_mold_1.f90 b/gcc/testsuite/gfortran.dg/allocate_with_mold_1.f90
new file mode 100644 (file)
index 0000000..2ea6d22
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_mold_1.f90
@@ -0,0 +1,47 @@
+! { dg-do run }
+!
+! Fixes a bug that emerged from the fix of PR62044 - see the PR. When
+! there was no default initializer, code-expr3 was set null and so the
+! vpointer was set to the vtable of the declared type, rather than that
+! of the MOLD expression.
+!
+! Contributed by but based on the original PR62044 testcase by
+! Paul Thomas  <pault@gcc.gnu.org>
+!
+module GridImageSilo_Template
+  implicit none
+  type, public, abstract :: GridImageSiloTemplate
+  end type GridImageSiloTemplate
+end module GridImageSilo_Template
+
+module UnstructuredGridImageSilo_Form
+  use GridImageSilo_Template
+  implicit none
+  type, public, extends ( GridImageSiloTemplate ) :: &
+    UnstructuredGridImageSiloForm
+  end type UnstructuredGridImageSiloForm
+end module UnstructuredGridImageSilo_Form
+
+module UnstructuredGridImages
+  use UnstructuredGridImageSilo_Form
+! 5.0 branch contains    UnstructuredGridImageForm => UnstructuredGridImageSiloForm
+contains
+  subroutine foo
+    class (GridImageSiloTemplate), allocatable :: a
+    type (UnstructuredGridImageSiloForm) :: b
+    integer :: i = 0
+    allocate (a, mold = b)
+    select type (a)
+      type is (UnstructuredGridImageSiloForm)
+        i = 1
+      class default
+        i = 2
+    end select
+    if (i .ne. 1) call abort
+  end subroutine
+end module UnstructuredGridImages
+
+  use UnstructuredGridImages
+  call foo
+end
+