[Patch, Fortran, F08] PR45290: pointer initialization

[Janus Weil <janus@gcc.gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 2152 bytes --]

Hi all,

here is a patch which implements the new pointer initialization
capabilities of F08. While in F03 all pointers had to be initialized
to NULL(), F08 allows non-NULL initialization values for data pointers
as well as procedure pointers. The patch contains some parsing bits in
decl.c, a couple of diagnostic checks in resolve.c and check.c and a
small hunk in trans-expr.c which handles the translation to the middle
end.

I hope everything should work as advertised. Regtesting was successful
on x86_64-unknown-linux-gnu (except for the continuing failure of
array_memcpy_3.f90, cf. PR45266).

Ok for trunk?

Btw: While the most obvious benefit of this patch of course is the
availability of pointer initialization as a useful feature in itself
(and another YES in the F08 compatibility table), my actual motivation
for implementing this was the fact that it will enable me to improve
the OOP implementation by making the vtabs statically initialized,
instead of having to initialize all the PPCs dynamically at run time
(and making sure this happens before the vtab is used). This is what I
will work on next, after the pointer init patch has landed ...

Cheers,
Janus



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

	PR fortran/45290
	* 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'.
	* 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.
	* trans-expr.c (gfc_conv_initializer): Implement non-NULL pointer
	initialization.


2010-08-16  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.

[-- Attachment #2: pr45290.diff --]
[-- Type: application/octet-stream, Size: 8924 bytes --]

Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90	(revision 163281)
+++ gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90	(working copy)
@@ -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" }
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 163281)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -3982,7 +3982,17 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespe
 	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)
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 163281)
+++ gcc/fortran/decl.c	(working copy)
@@ -1312,9 +1312,10 @@ add_init_expr_to_sym (const char *name, gfc_expr *
 	}
 
       /* 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)
 	{
@@ -4675,20 +4704,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 +4831,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);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 163281)
+++ gcc/fortran/expr.c	(working copy)
@@ -3552,7 +3552,28 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr
 
   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.save)
+	{
+	  gfc_error ("Pointer initialization target at %C must be SAVE");
+	  return FAILURE;
+	}
+    }
+
+  return SUCCESS;
 }
 
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 163281)
+++ gcc/fortran/resolve.c	(working copy)
@@ -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 @@ static gfc_try
 
       /* 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 @@ static gfc_try
 		     "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 be SAVE",
+			&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 @@ static gfc_try
 		     "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;
 
@@ -8956,10 +8976,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);
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 163281)
+++ gcc/fortran/primary.c	(working copy)
@@ -2088,6 +2088,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
   attr.pointer = pointer;
   attr.allocatable = allocatable;
   attr.target = target;
+  attr.save = sym->attr.save;
 
   return attr;
 }

[-- Attachment #3: pointer_init_2.f90 --]
[-- Type: application/octet-stream, Size: 1253 bytes --]

! { dg-do compile }
!
! PR 45290: [F08] pointer initialization
!
! Contributed by Janus Weil <janus@gcc.gnu.org>


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 be SAVE" }
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 "must have the TARGET attribute" }
  integer, pointer :: dpc4 => j   ! { dg-error "must be SAVE" }
  integer, pointer :: dpc5 => a   ! { dg-error "must not be ALLOCATABLE" }
end type

type(t) ::u

end

[-- Attachment #4: pointer_init_3.f90 --]
[-- Type: application/octet-stream, Size: 530 bytes --]

! { dg-do run }
!
! PR 45290: [F08] pointer initialization
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

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 

[-- Attachment #5: pointer_init_4.f90 --]
[-- Type: application/octet-stream, Size: 525 bytes --]

! { 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" } }