re PR fortran/45290 ([F08] pointer initialization)

2011-02-08  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45290
	* expr.c (gfc_check_assign_symbol): Reject pointers as pointer
	initialization target.


2011-02-08  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45290
	* gfortran.dg/pointer_init_6.f90: New.

From-SVN: r169948

gcc/fortran/ChangeLog

+2011-02-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45290
+	* expr.c (gfc_check_assign_symbol): Reject pointers as pointer
+	initialization target.
+
 2011-02-07  Janne Blomqvist  <jb@gcc.gnu.org>
 	    Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
 

gcc/fortran/expr.c

@@ -3608,7 +3608,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
 	             "must not be ALLOCATABLE ");
 	  return FAILURE;
 	}
-      if (!attr.target)
+      if (!attr.target || attr.pointer)
 	{
 	  gfc_error ("Pointer initialization target at %C "
 		     "must have the TARGET attribute");
@@ -3621,6 +3621,18 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
 	  return FAILURE;
 	}
     }
+    
+  if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL)
+    {
+      /* F08:C1220. Additional checks for procedure pointer initialization.  */
+      symbol_attribute attr = gfc_expr_attr (rvalue);
+      if (attr.proc_pointer)
+	{
+	  gfc_error ("Procedure pointer initialization target at %L "
+		     "may not be a procedure pointer", &rvalue->where);
+	  return FAILURE;
+	}
+    }
 
   return SUCCESS;
 }

gcc/testsuite/ChangeLog

+2011-02-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45290
+	* gfortran.dg/pointer_init_6.f90: New.
+
 2011-02-08  Jeff Law <law@redhat.com>
 
 	PR tree-optimization/42893

gcc/testsuite/gfortran.dg/pointer_init_6.f90

+! { dg-do compile }
+!
+! PR 45290: [F08] pointer initialization
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m1
+ implicit none
+ type :: t
+   integer, pointer :: p
+   integer :: i
+ end type
+ integer, target :: i
+ type(t), target :: x
+ integer, pointer :: p1 => i
+ integer, pointer :: p2 => p1   ! { dg-error "must have the TARGET attribute" }
+ integer, pointer :: p3 => x%p  ! { dg-error "must have the TARGET attribute" }
+ integer, pointer :: p4 => x%i
+end module m1
+
+
+module m2
+
+ type :: t
+   procedure(s), pointer, nopass :: ppc
+ end type
+ type(t) :: x
+ procedure(s), pointer :: pp1 => s
+ procedure(s), pointer :: pp2 => pp1    ! { dg-error "may not be a procedure pointer" }
+ procedure(s), pointer :: pp3 => t%ppc  ! { dg-error "Syntax error" }
+
+contains
+
+  subroutine s
+  end subroutine
+
+end module m2
+
+! { dg-final { cleanup-modules "m1 m2" } }