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

2010-08-19  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45290
	* gfortran.h (gfc_add_save): Modified prototype.
	* decl.c (add_init_expr_to_sym): Defer checking of proc pointer init.
	(match_pointer_init): New function to match F08 pointer initialization.
	(variable_decl,match_procedure_decl,match_ppc_decl): Use
	'match_pointer_init'.
	(match_attr_spec): Module variables are implicitly SAVE.
	(gfc_match_save): Modified call to 'gfc_add_save'.
	* expr.c (gfc_check_assign_symbol): Extra checks for pointer
	initialization.
	* primary.c (gfc_variable_attr): Handle SAVE attribute.
	* resolve.c (resolve_structure_cons): Add new argument and do pointer
	initialization checks.
	(gfc_resolve_expr): Modified call to 'resolve_structure_cons'.
	(resolve_values): Call 'resolve_structure_cons' directly with init arg.
	(resolve_fl_variable): Handle SAVE_IMPLICIT.
	* symbol.c (gfc_add_save,gfc_copy_attr,save_symbol): Handle
	SAVE_IMPLICIT.
	* trans-decl.c (gfc_create_module_variable): Module variables with
	TARGET can already exist.
	* trans-expr.c (gfc_conv_variable): Check for 'current_function_decl'.
	(gfc_conv_initializer): Implement non-NULL pointer
	initialization.


2010-08-19  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45290
	* gfortran.dg/proc_ptr_comp_3.f90: Modified.
	* gfortran.dg/pointer_init_2.f90: New.
	* gfortran.dg/pointer_init_3.f90: New.
	* gfortran.dg/pointer_init_4.f90: New.

From-SVN: r163356

gcc/fortran/ChangeLog

+2010-08-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45290
+	* gfortran.h (gfc_add_save): Modified prototype.
+	* decl.c (add_init_expr_to_sym): Defer checking of proc pointer init.
+	(match_pointer_init): New function to match F08 pointer initialization.
+	(variable_decl,match_procedure_decl,match_ppc_decl): Use
+	'match_pointer_init'.
+	(match_attr_spec): Module variables are implicitly SAVE.
+	(gfc_match_save): Modified call to 'gfc_add_save'.
+	* expr.c (gfc_check_assign_symbol): Extra checks for pointer
+	initialization.
+	* primary.c (gfc_variable_attr): Handle SAVE attribute.
+	* resolve.c (resolve_structure_cons): Add new argument and do pointer
+	initialization checks.
+	(gfc_resolve_expr): Modified call to 'resolve_structure_cons'.
+	(resolve_values): Call 'resolve_structure_cons' directly with init arg.
+	(resolve_fl_variable): Handle SAVE_IMPLICIT.
+	* symbol.c (gfc_add_save,gfc_copy_attr,save_symbol): Handle
+	SAVE_IMPLICIT.
+	* trans-decl.c (gfc_create_module_variable): Module variables with
+	TARGET can already exist.
+	* trans-expr.c (gfc_conv_variable): Check for 'current_function_decl'.
+	(gfc_conv_initializer): Implement non-NULL pointer
+	initialization.
+
 2010-08-18  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/45295

gcc/fortran/decl.c

@@ -1312,9 +1312,10 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
 	}
 
       /* Check if the assignment can happen. This has to be put off
-	 until later for a derived type variable.  */
+	 until later for derived type variables and procedure pointers.  */
       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)
 	return FAILURE;
 
@@ -1652,6 +1653,48 @@ gfc_match_null (gfc_expr **result)
 }
 
 
+/* Match the initialization expr for a data pointer or procedure pointer.  */
+
+static match
+match_pointer_init (gfc_expr **init, int procptr)
+{
+  match m;
+
+  if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
+    {
+      gfc_error ("Initialization of pointer at %C is not allowed in "
+		 "a PURE procedure");
+      return MATCH_ERROR;
+    }
+
+  /* Match NULL() initilization.  */
+  m = gfc_match_null (init);
+  if (m != MATCH_NO)
+    return m;
+
+  /* Match non-NULL initialization.  */
+  gfc_matching_procptr_assignment = procptr;
+  m = gfc_match_rvalue (init);
+  gfc_matching_procptr_assignment = 0;
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+  else if (m == MATCH_NO)
+    {
+      gfc_error ("Error in pointer initialization at %C");
+      return MATCH_ERROR;
+    }
+
+  if (!procptr)
+    gfc_resolve_expr (*init);
+  
+  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer "
+		      "initialization at %C") == FAILURE)
+    return MATCH_ERROR;
+
+  return MATCH_YES;
+}
+
+
 /* Match a variable name with an optional initializer.  When this
    subroutine is called, a variable is expected to be parsed next.
    Depending on what is happening at the moment, updates either the
@@ -1899,23 +1942,9 @@ variable_decl (int elem)
 	      goto cleanup;
 	    }
 
-	  m = gfc_match_null (&initializer);
-	  if (m == MATCH_NO)
-	    {
-	      gfc_error ("Pointer initialization requires a NULL() at %C");
-	      m = MATCH_ERROR;
-	    }
-
-	  if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
-	    {
-	      gfc_error ("Initialization of pointer at %C is not allowed in "
-			 "a PURE procedure");
-	      m = MATCH_ERROR;
-	    }
-
+	  m = match_pointer_init (&initializer, 0);
 	  if (m != MATCH_YES)
 	    goto cleanup;
-
 	}
       else if (gfc_match_char ('=') == MATCH_YES)
 	{
@@ -3511,7 +3540,7 @@ match_attr_spec (void)
 	  break;
 
 	case DECL_SAVE:
-	  t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
+	  t = gfc_add_save (&current_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
 	  break;
 
 	case DECL_TARGET:
@@ -3551,6 +3580,10 @@ match_attr_spec (void)
 	}
     }
 
+  /* Module variables implicitly have the SAVE attribute.  */
+  if (gfc_current_state () == COMP_MODULE && !current_attr.save)
+    current_attr.save = SAVE_IMPLICIT;
+
   colon_seen = 1;
   return MATCH_YES;
 
@@ -4675,20 +4708,7 @@ match_procedure_decl (void)
 	      goto cleanup;
 	    }
 
-	  m = gfc_match_null (&initializer);
-	  if (m == MATCH_NO)
-	    {
-	      gfc_error ("Pointer initialization requires a NULL() at %C");
-	      m = MATCH_ERROR;
-	    }
-
-	  if (gfc_pure (NULL))
-	    {
-	      gfc_error ("Initialization of pointer at %C is not allowed in "
-			 "a PURE procedure");
-	      m = MATCH_ERROR;
-	    }
-
+	  m = match_pointer_init (&initializer, 1);
 	  if (m != MATCH_YES)
 	    goto cleanup;
 
@@ -4815,18 +4835,7 @@ match_ppc_decl (void)
 
       if (gfc_match (" =>") == MATCH_YES)
 	{
-	  m = gfc_match_null (&initializer);
-	  if (m == MATCH_NO)
-	    {
-	      gfc_error ("Pointer initialization requires a NULL() at %C");
-	      m = MATCH_ERROR;
-	    }
-	  if (gfc_pure (NULL))
-	    {
-	      gfc_error ("Initialization of pointer at %C is not allowed in "
-			 "a PURE procedure");
-	      m = MATCH_ERROR;
-	    }
+	  m = match_pointer_init (&initializer, 1);
 	  if (m != MATCH_YES)
 	    {
 	      gfc_free_expr (initializer);
@@ -6720,8 +6729,8 @@ gfc_match_save (void)
       switch (m)
 	{
 	case MATCH_YES:
-	  if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
-	      == FAILURE)
+	  if (gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
+			    &gfc_current_locus) == FAILURE)
 	    return MATCH_ERROR;
 	  goto next_item;
 

gcc/fortran/expr.c

@@ -3552,7 +3552,35 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
 
   gfc_free (lvalue.symtree);
 
-  return r;
+  if (r == FAILURE)
+    return r;
+  
+  if (sym->attr.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 ");
+	  return FAILURE;
+	}
+      if (!attr.target)
+	{
+	  gfc_error ("Pointer initialization target at %C "
+		     "must have the TARGET attribute");
+	  return FAILURE;
+	}
+      if (!attr.save)
+	{
+	  gfc_error ("Pointer initialization target at %C "
+		     "must have the SAVE attribute");
+	  return FAILURE;
+	}
+    }
+
+  return SUCCESS;
 }
 
 

gcc/fortran/gfortran.h

@@ -2466,7 +2466,7 @@ gfc_try gfc_add_cray_pointee (symbol_attribute *, locus *);
 match gfc_mod_pointee_as (gfc_array_spec *);
 gfc_try gfc_add_protected (symbol_attribute *, const char *, locus *);
 gfc_try gfc_add_result (symbol_attribute *, const char *, locus *);
-gfc_try gfc_add_save (symbol_attribute *, const char *, locus *);
+gfc_try gfc_add_save (symbol_attribute *, save_state, const char *, locus *);
 gfc_try gfc_add_threadprivate (symbol_attribute *, const char *, locus *);
 gfc_try gfc_add_saved_common (symbol_attribute *, locus *);
 gfc_try gfc_add_target (symbol_attribute *, locus *);

gcc/fortran/primary.c

@@ -2088,6 +2088,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   attr.pointer = pointer;
   attr.allocatable = allocatable;
   attr.target = target;
+  attr.save = sym->attr.save;
 
   return attr;
 }

gcc/fortran/resolve.c

@@ -833,10 +833,11 @@ resolve_contained_functions (gfc_namespace *ns)
 
 
 /* Resolve all of the elements of a structure constructor and make sure that
-   the types are correct.  */
+   the types are correct. The 'init' flag indicates that the given
+   constructor is an initializer.  */
 
 static gfc_try
-resolve_structure_cons (gfc_expr *expr)
+resolve_structure_cons (gfc_expr *expr, int init)
 {
   gfc_constructor *cons;
   gfc_component *comp;
@@ -896,7 +897,8 @@ resolve_structure_cons (gfc_expr *expr)
 
       /* If we don't have the right type, try to convert it.  */
 
-      if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
+      if (!comp->attr.proc_pointer &&
+	  !gfc_compare_types (&cons->expr->ts, &comp->ts))
 	{
 	  t = FAILURE;
 	  if (strcmp (comp->name, "$extends") == 0)
@@ -1005,6 +1007,23 @@ resolve_structure_cons (gfc_expr *expr)
 		     "a TARGET", &cons->expr->where, comp->name);
 	}
 
+      if (init)
+	{
+	  /* F08:C461. Additional checks for pointer initialization.  */
+	  if (a.allocatable)
+	    {
+	      t = FAILURE;
+	      gfc_error ("Pointer initialization target at %L "
+			 "must not be ALLOCATABLE ", &cons->expr->where);
+	    }
+	  if (!a.save)
+	    {
+	      t = FAILURE;
+	      gfc_error ("Pointer initialization target at %L "
+			 "must have the SAVE attribute", &cons->expr->where);
+	    }
+	}
+
       /* F2003, C1272 (3).  */
       if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
 	  && (gfc_impure_variable (cons->expr->symtree->n.sym)
@@ -1015,6 +1034,7 @@ resolve_structure_cons (gfc_expr *expr)
 		     "pointer component '%s' at %L in PURE procedure",
 		     comp->name, &cons->expr->where);
 	}
+
     }
 
   return t;
@@ -5977,7 +5997,7 @@ gfc_resolve_expr (gfc_expr *e)
       if (t == FAILURE)
 	break;
 
-      t = resolve_structure_cons (e);
+      t = resolve_structure_cons (e, 0);
       if (t == FAILURE)
 	break;
 
@@ -8924,10 +8944,17 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 static void
 resolve_values (gfc_symbol *sym)
 {
+  gfc_try t;
+
   if (sym->value == NULL)
     return;
 
-  if (gfc_resolve_expr (sym->value) == FAILURE)
+  if (sym->value->expr_type == EXPR_STRUCTURE)
+    t= resolve_structure_cons (sym->value, 1);
+  else 
+    t = gfc_resolve_expr (sym->value);
+
+  if (t == FAILURE)
     return;
 
   gfc_check_assign_symbol (sym, sym->value);
@@ -9636,7 +9663,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
 	  return FAILURE;
 	}
 
-      if (e && sym->attr.save && !gfc_is_constant_expr (e))
+      if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
 	{
 	  gfc_error (auto_save_msg, sym->name, &sym->declared_at);
 	  return FAILURE;

gcc/fortran/symbol.c

@@ -1095,13 +1095,14 @@ gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
 
 
 gfc_try
-gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
+gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
+	      locus *where)
 {
 
   if (check_used (attr, name, where))
     return FAILURE;
 
-  if (gfc_pure (NULL))
+  if (s == SAVE_EXPLICIT && gfc_pure (NULL))
     {
       gfc_error
 	("SAVE attribute at %L cannot be specified in a PURE procedure",
@@ -1109,7 +1110,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
       return FAILURE;
     }
 
-  if (attr->save == SAVE_EXPLICIT && !attr->vtab)
+  if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
     {
 	if (gfc_notify_std (GFC_STD_LEGACY, 
 			    "Duplicate SAVE attribute specified at %L",
@@ -1118,7 +1119,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
 	  return FAILURE;
     }
 
-  attr->save = SAVE_EXPLICIT;
+  attr->save = s;
   return check_conflict (attr, name, where);
 }
 
@@ -1740,7 +1741,7 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
     goto fail;
   if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
     goto fail;
-  if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
+  if (src->save && gfc_add_save (dest, src->save, NULL, where) == FAILURE)
     goto fail;
   if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
     goto fail;
@@ -3430,7 +3431,7 @@ save_symbol (gfc_symbol *sym)
   /* Automatic objects are not saved.  */
   if (gfc_is_var_automatic (sym))
     return;
-  gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
+  gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
 }
 
 

gcc/fortran/trans-decl.c

@@ -3587,7 +3587,7 @@ gfc_create_module_variable (gfc_symbol * sym)
       && (sym->equiv_built || sym->attr.in_equivalence))
     return;
 
-  if (sym->backend_decl && !sym->attr.vtab)
+  if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
     internal_error ("backend decl for module variable %s already exists",
 		    sym->name);
 

gcc/fortran/trans-expr.c

@@ -556,7 +556,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 {
   gfc_ref *ref;
   gfc_symbol *sym;
-  tree parent_decl;
+  tree parent_decl = NULL_TREE;
   int parent_flag;
   bool return_value;
   bool alternate_entry;
@@ -590,7 +590,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
       entry_master = sym->attr.result
 		     && sym->ns->proc_name->attr.entry_master
 		     && !gfc_return_by_reference (sym->ns->proc_name);
-      parent_decl = DECL_CONTEXT (current_function_decl);
+      if (current_function_decl)
+	parent_decl = DECL_CONTEXT (current_function_decl);
 
       if ((se->expr == parent_decl && return_value)
 	   || (sym->ns && sym->ns->proc_name
@@ -3983,7 +3984,17 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
 	return gfc_conv_array_initializer (type, expr);
     }
   else if (pointer)
-    return fold_convert (type, null_pointer_node);
+    {
+      if (!expr || expr->expr_type == EXPR_NULL)
+	return fold_convert (type, null_pointer_node);
+      else
+	{
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, expr);
+	  return se.expr;
+	}
+    }
   else
     {
       switch (ts->type)

gcc/testsuite/ChangeLog

+2010-08-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45290
+	* gfortran.dg/proc_ptr_comp_3.f90: Modified.
+	* gfortran.dg/pointer_init_2.f90: New.
+	* gfortran.dg/pointer_init_3.f90: New.
+	* gfortran.dg/pointer_init_4.f90: New.
+
 2010-08-18  Nathan Froyd  <froydnj@codesourcery.com>
 
 	PR c++/45049

gcc/testsuite/gfortran.dg/pointer_init_2.f90

+! { dg-do compile }
+!
+! PR 45290: [F08] pointer initialization
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+subroutine sub
+  implicit none
+
+  real, target, save :: r
+  integer, target, save, dimension(1:3) :: v
+
+  integer, save :: i
+  integer, target :: j
+  integer, target, save, allocatable :: a
+
+
+  integer, pointer :: dp0 => 13  ! { dg-error "Error in pointer initialization" }
+  integer, pointer :: dp1 => r   ! { dg-error "Different types in pointer assignment" }
+  integer, pointer :: dp2 => v   ! { dg-error "Different ranks in pointer assignment" }
+  integer, pointer :: dp3 => i   ! { dg-error "is neither TARGET nor POINTER" }
+  integer, pointer :: dp4 => j   ! { dg-error "must have the SAVE attribute" }
+  integer, pointer :: dp5 => a   ! { dg-error "must not be ALLOCATABLE" }
+
+  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" }
+    integer, pointer :: dpc4 => j   ! { dg-error "must have the SAVE attribute" }
+    integer, pointer :: dpc5 => a   ! { dg-error "must not be ALLOCATABLE" }
+  end type
+
+  type(t) ::u
+
+end subroutine

gcc/testsuite/gfortran.dg/pointer_init_3.f90

+! { dg-do run }
+!
+! PR 45290: [F08] pointer initialization
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+ integer, target  :: t1          ! SAVE is implicit
+ integer, pointer :: p1 => t1
+end module m
+
+
+use m
+implicit none
+
+integer,target :: i0 = 2
+integer,target,dimension(1:3) :: vec = 1
+
+type :: t
+  integer, pointer :: dpc => i0
+  integer :: i = 0
+end type
+
+type (t), save, target :: u
+
+integer, pointer :: dp => i0
+integer, pointer :: dp2 => vec(2)
+integer, pointer :: dp3 => u%i
+
+dp = 5
+if (i0/=5) call abort()
+
+u%dpc = 6
+if (i0/=6) call abort()
+
+dp2 = 3
+if (vec(2)/=3) call abort()
+
+dp3 = 4
+if (u%i/=4) call abort()
+
+end 
+
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/pointer_init_4.f90

+! { dg-do run }
+!
+! PR 45290: [F08] pointer initialization
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+
+implicit none
+
+contains
+
+  integer function f1()
+    f1 = 42
+  end function
+
+  integer function f2()
+    f2 = 43
+  end function
+
+end module
+
+
+program test_ptr_init
+
+use m
+implicit none
+
+procedure(f1), pointer :: pp => f1
+
+type :: t
+  procedure(f2), pointer, nopass :: ppc => f2
+end type
+
+type (t) :: u
+
+if (pp()/=42) call abort()
+if (u%ppc()/=43) call abort()
+
+end
+
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90

@@ -22,7 +22,6 @@ type :: t
   procedure(), pointer, nopass ptr4              ! { dg-error "Expected '::'" }
   procedure(), pointer, nopass, pointer :: ptr5  ! { dg-error "Duplicate" }
   procedure, pointer, nopass :: ptr6             ! { dg-error "Syntax error" }
-  procedure(), pointer, nopass :: ptr7 => ptr2   ! { dg-error "requires a NULL" }
   procedure(), nopass :: ptr8                    ! { dg-error "POINTER attribute is required" }
   procedure(pp), pointer, nopass :: ptr9         ! { dg-error "declared in a later PROCEDURE statement" }
   procedure(aaargh), pointer, nopass :: ptr10    ! { dg-error "must be explicit" }