re PR fortran/55763 (Issues with some simpler CLASS(*) programs)

2013-01-07  Tobias Burnus  <burnus@net-b.de>

        PR fortran/55763
        * gfortran.h (gfc_check_assign_symbol): Update prototype.
        * decl.c (add_init_expr_to_sym, do_parm): Update call.
        * expr.c (gfc_check_assign_symbol): Handle BT_CLASS and
        improve error location; support components.
        (gfc_check_pointer_assign): Handle component assignments.
        * resolve.c (resolve_fl_derived0): Call gfc_check_assign_symbol.
        (resolve_values): Update call.
        (resolve_structure_cons): Avoid double diagnostic.

2013-01-07  Tobias Burnus  <burnus@net-b.de>

        PR fortran/55763
        * gfortran.dg/pointer_init_2.f90: Update dg-error.
        * gfortran.dg/pointer_init_7.f90: New.

From-SVN: r194990

8 files changed, 160 insertions, 37 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3444073..e245fcb 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,4 +1,16 @@
 2013-01-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55763
+	* gfortran.h (gfc_check_assign_symbol): Update prototype.
+	* decl.c (add_init_expr_to_sym, do_parm): Update call.
+	* expr.c (gfc_check_assign_symbol): Handle BT_CLASS and
+	improve error location; support components.
+	(gfc_check_pointer_assign): Handle component assignments.
+	* resolve.c (resolve_fl_derived0): Call gfc_check_assign_symbol.
+	(resolve_values): Update call.
+	(resolve_structure_cons): Avoid double diagnostic.
+
+2013-01-07  Tobias Burnus  <burnus@net-b.de>
 	    Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/55852
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 2e6e98a..3a36cad 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1353,14 +1353,14 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
       if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
 	  && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
 	  && !sym->attr.proc_pointer 
-	  && gfc_check_assign_symbol (sym, init) == FAILURE)
+	  && gfc_check_assign_symbol (sym, NULL, init) == FAILURE)
 	return FAILURE;
 
       if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
 	    && init->ts.type == BT_CHARACTER)
 	{
 	  /* Update symbol character length according initializer.  */
-	  if (gfc_check_assign_symbol (sym, init) == FAILURE)
+	  if (gfc_check_assign_symbol (sym, NULL, init) == FAILURE)
 	    return FAILURE;
 
 	  if (sym->ts.u.cl->length == NULL)
@@ -6955,7 +6955,7 @@ do_parm (void)
       goto cleanup;
     }
 
-  if (gfc_check_assign_symbol (sym, init) == FAILURE
+  if (gfc_check_assign_symbol (sym, NULL, init) == FAILURE
       || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
     {
       m = MATCH_ERROR;
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 74a17eb..68079a8 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3291,22 +3291,21 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
 gfc_try
 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 {
-  symbol_attribute attr;
+  symbol_attribute attr, lhs_attr;
   gfc_ref *ref;
   bool is_pure, is_implicit_pure, rank_remap;
   int proc_pointer;
 
-  if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
-      && !lvalue->symtree->n.sym->attr.proc_pointer)
+  lhs_attr = gfc_expr_attr (lvalue);
+  if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer)
     {
       gfc_error ("Pointer assignment target is not a POINTER at %L",
 		 &lvalue->where);
       return FAILURE;
     }
 
-  if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
-      && lvalue->symtree->n.sym->attr.use_assoc
-      && !lvalue->symtree->n.sym->attr.proc_pointer)
+  if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc
+      && !lhs_attr.proc_pointer)
     {
       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
 		 "l-value since it is a procedure",
@@ -3735,10 +3734,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
    symbol.  Used for initialization assignments.  */
 
 gfc_try
-gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
+gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
 {
   gfc_expr lvalue;
   gfc_try r;
+  bool pointer, proc_pointer;
 
   memset (&lvalue, '\0', sizeof (gfc_expr));
 
@@ -3750,9 +3750,27 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
   lvalue.symtree->n.sym = sym;
   lvalue.where = sym->declared_at;
 
-  if (sym->attr.pointer || sym->attr.proc_pointer
-      || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer
-	  && rvalue->expr_type == EXPR_NULL))
+  if (comp)
+    {
+      lvalue.ref = gfc_get_ref ();
+      lvalue.ref->type = REF_COMPONENT;
+      lvalue.ref->u.c.component = comp;
+      lvalue.ref->u.c.sym = sym;
+      lvalue.ts = comp->ts;
+      lvalue.rank = comp->as ? comp->as->rank : 0;
+      lvalue.where = comp->loc;
+      pointer = comp->ts.type == BT_CLASS &&  CLASS_DATA (comp)
+		? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer;
+      proc_pointer = comp->attr.proc_pointer;
+    }
+  else
+    {
+      pointer = sym->ts.type == BT_CLASS &&  CLASS_DATA (sym)
+		? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
+      proc_pointer = sym->attr.proc_pointer;
+    }
+
+  if (pointer || proc_pointer)
     r = gfc_check_pointer_assign (&lvalue, rvalue);
   else
     r = gfc_check_assign (&lvalue, rvalue, 1);
@@ -3762,32 +3780,41 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
   if (r == FAILURE)
     return r;
 
-  if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
+  if (pointer && rvalue->expr_type != EXPR_NULL)
     {
       /* F08:C461. Additional checks for pointer initialization.  */
       symbol_attribute attr;
       attr = gfc_expr_attr (rvalue);
       if (attr.allocatable)
 	{
-	  gfc_error ("Pointer initialization target at %C "
-	             "must not be ALLOCATABLE ");
+	  gfc_error ("Pointer initialization target at %L "
+	             "must not be ALLOCATABLE", &rvalue->where);
 	  return FAILURE;
 	}
       if (!attr.target || attr.pointer)
 	{
-	  gfc_error ("Pointer initialization target at %C "
-		     "must have the TARGET attribute");
+	  gfc_error ("Pointer initialization target at %L "
+		     "must have the TARGET attribute", &rvalue->where);
 	  return FAILURE;
 	}
+
+      if (!attr.save && rvalue->expr_type == EXPR_VARIABLE
+	  && rvalue->symtree->n.sym->ns->proc_name
+	  && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program)
+	{
+	  rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT;
+	  attr.save = SAVE_IMPLICIT;
+	}
+
       if (!attr.save)
 	{
-	  gfc_error ("Pointer initialization target at %C "
-		     "must have the SAVE attribute");
+	  gfc_error ("Pointer initialization target at %L "
+		     "must have the SAVE attribute", &rvalue->where);
 	  return FAILURE;
 	}
     }
 
-  if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL)
+  if (proc_pointer && rvalue->expr_type != EXPR_NULL)
     {
       /* F08:C1220. Additional checks for procedure pointer initialization.  */
       symbol_attribute attr = gfc_expr_attr (rvalue);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5a68873..99eeeec 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2770,7 +2770,7 @@ int gfc_kind_max (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3;
 gfc_try gfc_check_assign (gfc_expr *, gfc_expr *, int);
 gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
-gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
+gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_component *, gfc_expr *);
 
 bool gfc_has_default_initializer (gfc_symbol *);
 gfc_expr *gfc_default_initializer (gfc_typespec *);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 70bfae6..99c1996 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1105,23 +1105,28 @@ resolve_structure_cons (gfc_expr *expr, int init)
       if (!comp->attr.proc_pointer &&
 	  !gfc_compare_types (&cons->expr->ts, &comp->ts))
 	{
-	  t = FAILURE;
 	  if (strcmp (comp->name, "_extends") == 0)
 	    {
 	      /* Can afford to be brutal with the _extends initializer.
 		 The derived type can get lost because it is PRIVATE
 		 but it is not usage constrained by the standard.  */
 	      cons->expr->ts = comp->ts;
-	      t = SUCCESS;
 	    }
 	  else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
-	    gfc_error ("The element in the structure constructor at %L, "
-		       "for pointer component '%s', is %s but should be %s",
-		       &cons->expr->where, comp->name,
-		       gfc_basic_typename (cons->expr->ts.type),
-		       gfc_basic_typename (comp->ts.type));
+	    {
+	      gfc_error ("The element in the structure constructor at %L, "
+			 "for pointer component '%s', is %s but should be %s",
+			 &cons->expr->where, comp->name,
+			 gfc_basic_typename (cons->expr->ts.type),
+			 gfc_basic_typename (comp->ts.type));
+	      t = FAILURE;
+	    }
 	  else
-	    t = gfc_convert_type (cons->expr, &comp->ts, 1);
+	    {
+	      gfc_try t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
+	      if (t != FAILURE)
+		t = t2;
+	    }
 	}
 
       /* For strings, the length of the constructor should be the same as
@@ -10450,7 +10455,7 @@ resolve_values (gfc_symbol *sym)
   if (t == FAILURE)
     return;
 
-  gfc_check_assign_symbol (sym, sym->value);
+  gfc_check_assign_symbol (sym, NULL, sym->value);
 }
 
 
@@ -12874,6 +12879,10 @@ resolve_fl_derived0 (gfc_symbol *sym)
 					   || c->attr.proc_pointer
 					   || c->attr.allocatable)) == FAILURE)
 	return FAILURE;
+
+      if (c->initializer && !sym->attr.vtype
+	  && gfc_check_assign_symbol (sym, c, c->initializer) == FAILURE)
+	return FAILURE;
     }
 
   check_defined_assignments (sym);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e0cc608..7335c73 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2013-01-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55763
+	* gfortran.dg/pointer_init_2.f90: Update dg-error.
+	* gfortran.dg/pointer_init_7.f90: New.
+
 2013-01-07  Richard Biener  <rguenther@suse.de>
 
 	* gcc.dg/lto/pr55525_0.c (s): Size like char *.
diff --git a/gcc/testsuite/gfortran.dg/pointer_init_2.f90 b/gcc/testsuite/gfortran.dg/pointer_init_2.f90
index 8f72663..a280a3e 100644
--- a/gcc/testsuite/gfortran.dg/pointer_init_2.f90
+++ b/gcc/testsuite/gfortran.dg/pointer_init_2.f90
@@ -24,13 +24,26 @@ subroutine sub
 
   type :: t
     integer, pointer :: dpc0 => 13  ! { dg-error "Error in pointer initialization" }
-    integer, pointer :: dpc1 => r   ! { dg-error "is REAL but should be INTEGER" }
-    integer, pointer :: dpc2 => v   ! { dg-error "rank of the element.*does not match" }
-    integer, pointer :: dpc3 => i   ! { dg-error "should be a POINTER or a TARGET" }
+  end type t
+
+  type t2
+    integer, pointer :: dpc1 => r   ! { dg-error "attempted assignment of REAL.4. to INTEGER.4." }
+  end type t2
+
+  type t3
+    integer, pointer :: dpc2 => v   ! { dg-error "Different ranks in pointer assignment" }
+  end type t3
+
+  type t4
+    integer, pointer :: dpc3 => i   ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" }
+  end type t4
+
+  type t5
     integer, pointer :: dpc4 => j   ! { dg-error "must have the SAVE attribute" }
-    integer, pointer :: dpc5 => a   ! { dg-error "must not be ALLOCATABLE" }
-  end type
+  end type t5
 
-  type(t) ::u
+  type t6
+    integer, pointer :: dpc5 => a   ! { dg-error "must not be ALLOCATABLE" }
+  end type t6
 
 end subroutine
diff --git a/gcc/testsuite/gfortran.dg/pointer_init_7.f90 b/gcc/testsuite/gfortran.dg/pointer_init_7.f90
new file mode 100644
index 0000000..dfde615
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_init_7.f90
@@ -0,0 +1,56 @@
+! { dg-do compile }
+!
+! PR fortran/55763
+!
+
+subroutine sub()
+  type t
+    integer :: i
+  end type t
+
+  type(t), target :: tgt
+  type(t), target, save :: tgt2(2)
+
+  type t2a
+    type(t),  pointer :: cmp1 => tgt   ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  end type t2a
+
+  type t2b
+    class(t), pointer :: cmp2 => tgt   ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  end type t2b
+
+  type t2c
+    class(t), pointer :: cmp3 => tgt   ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  end type t2c
+
+  type t2d
+    integer,  pointer :: cmp4 => tgt%i ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  end type t2d
+
+  type(t),  pointer :: w => tgt   ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  class(t), pointer :: x => tgt   ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  class(*), pointer :: y => tgt   ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  integer,  pointer :: z => tgt%i ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+end subroutine
+
+program main
+  type t3
+    integer :: j
+  end type t3
+
+  type(t3), target :: tgt
+
+  type t4
+    type(t3),  pointer :: cmp1 => tgt   ! OK
+    class(t3), pointer :: cmp2 => tgt   ! OK
+    class(t3), pointer :: cmp3 => tgt   ! OK
+    integer,   pointer :: cmp4 => tgt%j ! OK
+  end type t4
+
+  type(t3), target :: mytarget
+
+  type(t3),  pointer :: a => mytarget   ! OK
+  class(t3), pointer :: b => mytarget   ! OK
+  class(*),  pointer :: c => mytarget   ! OK
+  integer,   pointer :: d => mytarget%j ! OK
+end program main