re PR fortran/63553 ([OOP] Wrong code when assigning a CLASS to a TYPE)

2014-10-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/63553
	* resolve.c (resolve_ordinary_assign): Add data component to
	rvalue expression for class to type assignment.

2014-10-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/63553
	* gfortran.dg/class_to_type_3.f03 : New test

From-SVN: r216427

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f4b33d04393b480c034182c071b8bd5bec00fb60..1be334f1f65f65ae3a1cfa5fb0a6302979990246 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2014-10-18  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/63553
+       * resolve.c (resolve_ordinary_assign): Add data component to
+       rvalue expression for class to type assignment.
+
 2014-10-16  Andrew MacLeod  <amacleod@redhat.com>
 
        * f95-lang.c: Adjust include files.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 30ee175d2aced4e26b9eb4ce2e7cc895469df713..4acebd0a3b9cd74d169f2e7aba4d9adcfd283db5 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;
@@ -4124,7 +4124,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;
 
@@ -5830,7 +5830,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;
 
@@ -6030,8 +6030,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;
 
@@ -6065,8 +6065,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;
 
@@ -6274,19 +6274,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;
 
@@ -6544,10 +6544,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;
 
@@ -6897,10 +6897,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)
@@ -7099,7 +7099,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
@@ -8309,7 +8309,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;
 
@@ -8444,7 +8444,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;
 
@@ -8456,7 +8456,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;
 
@@ -8468,7 +8468,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;
 }
@@ -9174,7 +9174,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;
 
@@ -9341,6 +9341,11 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
 
   gfc_check_assign (lhs, rhs, 1);
 
+  /* Assign the 'data' of a class object to a derived type.  */
+  if (lhs->ts.type == BT_DERIVED
+      && rhs->ts.type == BT_CLASS)
+    gfc_add_data_component (rhs);
+
   /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
      Additionally, insert this code when the RHS is a CAF as we then use the
      GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
@@ -10023,7 +10028,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
              && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
            remove_caf_get_intrinsic (code->expr1);
 
-         if (!gfc_check_vardef_context (code->expr1, false, false, false, 
+         if (!gfc_check_vardef_context (code->expr1, false, false, false,
                                         _("assignment")))
            break;
 
@@ -10832,7 +10837,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;
        }
@@ -11163,8 +11168,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.  */
@@ -11186,8 +11191,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.  */
@@ -11298,7 +11303,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
@@ -12145,7 +12150,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;
     }
@@ -12597,7 +12602,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;
 
@@ -12671,8 +12676,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;
 
@@ -12721,13 +12726,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;
 
@@ -12782,13 +12787,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;
 
@@ -12797,7 +12802,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;
 
@@ -12817,7 +12822,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;
 
@@ -13387,10 +13392,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;
 
@@ -13533,15 +13538,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;
     }
@@ -14744,7 +14749,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 e91f7eb56a74de3bc955bfbe04fe65c9b94d7467..87ec5cb32ae1bb888aea63c20c12134264baa07e 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2014-10-18  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/63553
+       * gfortran.dg/class_to_type_3.f03 : New test
+
 2014-10-18  Oleg Endo  <olegendo@gcc.gnu.org>
 
        * gcc.target/sh/torture/pr58314.c: Fix excess failures caused by switch
@@ -757,7 +762,7 @@
        * gcc.dg/winline-6.c: Likewise.
        * gcc.dg/winline-7.c: Likewise.
        * gcc.dg/funcorder.c: Fix implicit declarations.  Fix defaulting to
-       int. 
+       int.
        * gcc.dg/inline-33.c: Likewise.
        * gcc.dg/pr27861-1.c: Likewise.
        * gcc.dg/pr28888.c: Likewise.
@@ -3476,7 +3481,7 @@
 
 2014-08-19  Janis Johnson  <janisjo@codesourcery.com>
 
-       * lib/target-supports.exp 
+       * lib/target-supports.exp
        (check_effective_target_arm_v8_neon_ok_nocache): Add
        "-march-armv8-a" to compile flags.
 

diff --git a/gcc/testsuite/gfortran.dg/class_to_type_3.f03 b/gcc/testsuite/gfortran.dg/class_to_type_3.f03
new file mode 100644 (file)
index 0000000..2d7a823
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_to_type_3.f03
@@ -0,0 +1,41 @@
+! { dg-do run }
+! Tests the fix for pr63553 in which the class container was being
+! assigned to derived types, rather than the data.
+!
+! Contributed by <patnel97269-gfortran@yahoo.fr>
+!
+program toto
+  implicit none
+  type mother
+    integer :: i
+  end type mother
+  type,extends(mother) :: child
+  end type child
+
+  call comment1
+  call comment2
+
+contains
+  subroutine comment1
+    type(mother) :: tm
+    class(mother),allocatable :: cm
+
+    allocate (cm)
+    cm%i = 77
+    tm = cm
+    if (tm%i .ne. cm%i) call abort
+  end subroutine
+
+  subroutine comment2
+    class(mother),allocatable :: cm,cm2
+
+    allocate(cm)
+    allocate(child::cm2)
+    cm%i=10
+    select type (cm2)
+       type is (child)
+         cm2%mother=cm
+    end select
+    if (cm2%i .ne. cm%i) call abort
+  end subroutine
+end program