Re: [Patch, Fortran, F08] PR45290: pointer initialization

Re: [Patch, Fortran, F08] PR45290: pointer initialization

[Tobias Burnus]

Janus Weil wrote at http://gcc.gnu.org/ml/fortran/2010-08/msg00222.html:
> > Yes, like most pointer-initialization problems, most cannot
> > be detected at compile time and some only with quite some
> > effort. [...]
> Ok. I'm certainly not very keen on implementing this right now

Well, I was not suggesting it to you to implement it ;-)

> Anyway, would it be ok if I commit the bulk changes needed for
> pointer init now (i.e. version #2 of the patch as posted
> yesterday), and take care of the remaining problems afterwards?

I assume, you mean: pr45290_v2.diff of
http://gcc.gnu.org/ml/fortran/2010-08/msg00203.html

That patch is OK.

> The remaining problems being:
>
> (2) Making global variables in a program SAVE_IMPLICIT.
> If I do that (analogously to module variables), then I get a couple of
> regressions, e.g.: [...]
> It seems that SAVE_IMPLICIT messes up automatic deallocation ...

You could insert code in resolve_symbol of the kind
  /* Despite implicit SAVE, free and finallize allocatables of
     the main program.  */
  if (sym->attr.save == SAVE_IMPLICIT && sym->attr.allocatable
      && sym->ns->proc_name->attr.is_main_program)
    sym->attr.save = SAVE_NONE


> (1) Initializing to a pointer:
>
> module m
>  implicit none
>  integer, target, save  :: t1
>  integer, pointer :: p1 => t
>  integer, pointer :: p2 => p1    ! ICE
> end module m

When you fix this, please check (in the test case) that "p2"
is indeed associated with "t" and not with "p1".

Additionally, I think one should reject it if the RHS is not
initialized or if it is NULL initialized as in both cases there
cannot be any target on the RHS. (Check also the case LHS == RHS
[invalid] and RHS being an array with non-vector array designator.

Maybe start with the doing the right checks in decl.c - maybe the
ICE disappears then automatically.

Tobias

Re: [Patch, Fortran, F08] PR45290: pointer initialization

[Janus Weil]

>> Anyway, would it be ok if I commit the bulk changes needed for
>> pointer init now (i.e. version #2 of the patch as posted
>> yesterday), and take care of the remaining problems afterwards?
>
> I assume, you mean: pr45290_v2.diff of
> http://gcc.gnu.org/ml/fortran/2010-08/msg00203.html
>
> That patch is OK.

Thanks. Committed as r163356.

I will take care of the remaining problems soon.

Cheers,
Janus

Re: [Patch, Fortran, F08] PR45290: pointer initialization

[Janus Weil]

>> > - ? ?integer(c_int), dimension(:), pointer :: int_ptr
>> > - ? ?my_c_ptr = c_loc(int_ptr(0))
>> >
>> > Well, as written is is invalid - but change it to
>> >
>> > - ? ?integer(c_int), dimension(:), pointer :: int_ptr
>> > ALLOCATE(int_ptr(0:10))
>> > - ? ?my_c_ptr = c_loc(int_ptr(0))
>> >
>> > Then it is valid.
>>
>> ... which means that a through check for validity is
>> very hard to do at compile time, since it depends on
>> the run-time value, right?
>
> Yes, like most pointer-initialization problems, most cannot
> be detected at compile time and some only with quite some
> effort. However, for compiling,
>  my_c_ptr = c_loc(int_ptr(0))
> it should be enough to decide whether (based on that line and
> the function/variable declarations) it could be valid - and
> if so, one accepts the code. In the example, one could track
> whether "int_ptr" is ever pointer associated or allocated
> before using it; I think NAG's f95 does some of these checks,

Ok. I'm certainly not very keen on implementing this right now, but
one can open an enhancement PR for it.


Anyway, would it be ok if I commit the bulk changes needed for pointer
init now (i.e. version #2 of the patch as posted yesterday), and take
care of the remaining problems afterwards?


The remaining problems being:

(1) Initializing to a pointer:

module m
 implicit none
 integer, target, save  :: t1
 integer, pointer :: p1 => t
 integer, pointer :: p2 => p1    ! ICE
end module m

For this one currently gets:

f951: internal compiler error: in record_reference, at cgraphbuild.c:60

but I have absolutely no idea how that comes about.



(2) Making global variables in a program SAVE_IMPLICIT.

If I do that (analogously to module variables), then I get a couple of
regressions, e.g.:

alloc_comp_basics_1.f90
alloc_comp_constructor_1.f90
...

It seems that SAVE_IMPLICIT messes up automatic deallocation ...


Cheers,
Janus

Re: [Patch, Fortran, F08] PR45290: pointer initialization

[Tobias Burnus]

Janus Weil wrote:
> Tobias Burnus wrote:
> > - ? ?integer(c_int), dimension(:), pointer :: int_ptr
> > - ? ?my_c_ptr = c_loc(int_ptr(0))
> >
> > Well, as written is is invalid - but change it to
> >
> > - ? ?integer(c_int), dimension(:), pointer :: int_ptr
> > ALLOCATE(int_ptr(0:10))
> > - ? ?my_c_ptr = c_loc(int_ptr(0))
> >
> > Then it is valid.
>
> ... which means that a through check for validity is
> very hard to do at compile time, since it depends on
> the run-time value, right?

Yes, like most pointer-initialization problems, most cannot
be detected at compile time and some only with quite some
effort. However, for compiling,
  my_c_ptr = c_loc(int_ptr(0))
it should be enough to decide whether (based on that line and
the function/variable declarations) it could be valid - and
if so, one accepts the code. In the example, one could track
whether "int_ptr" is ever pointer associated or allocated
before using it; I think NAG's f95 does some of these checks,
though I found a bug where v5.1 refuses to compile a perfectly
valid code because the check misses a valid method to make
the (in that case) allocatable allocated.


> Well, ok. I guess that is one way to look at it. However, if I apply
> the same logic to your earlier pointer-init example ...
>
> module m
>  integer, target, save  :: t1
>  integer, pointer :: p1 => t1
>  integer, pointer :: p3 => p1
> end module m
>
> ... then I'd say this is valid, too. p1 itself is a pointer, but the
> thing that it points to is a target (namely t1). Therefore "p3 => p1"
> is valid, since the object on the RHS has the TARGET attribute. Can we
> agree on that?

Over night I came to the same conclusion. But I think it is only valid if
the pointer on the RHS is pointer-associated (note: after "p => NULL()",
"p" is unassociated) - otherwise the status of the pointer is undefined
or unassociated and no TARGET exists.

But maybe one should ask for a second standard interpretation at j3 or
c.l.f to make sure we interprete it correctly. As this thread shows, it
is very easy to get on the wrong track.

Tobias

Re: [Patch, Fortran, F08] PR45290: pointer initialization

[Janus Weil]

> That looks perfectly valid, cf. below.
>
> -    integer(c_int), dimension(:), pointer :: int_ptr
> -    my_c_ptr = c_loc(int_ptr(0))
>
>
> Well, as written is is invalid - but change it to
>
> -    integer(c_int), dimension(:), pointer :: int_ptr
> ALLOCATE(int_ptr(0:10))
> -    my_c_ptr = c_loc(int_ptr(0))
>
>
> Then it is valid.


... which means that a through check for validity is very hard to do
at compile time, since it depends on the run-time value, right?



> Note: "int_ptr(0)" is not a pointer but "int_ptr(0)" is
> the first element of the array to which int_ptr points. That array is
> unnamed but has the TARGET attribute. If you want to have a named target,
> use:
>
> integer, target :: tg(0:10)
> -    integer(c_int), dimension(:), pointer :: int_ptr
> int_ptr =>  tg
> -    my_c_ptr = c_loc(int_ptr(0))
>
> In this case int_ptr(0) is the first element of "tg" and "tg" has the TARGET
> attribute.

Well, ok. I guess that is one way to look at it. However, if I apply
the same logic to your earlier pointer-init example ...


module m
 integer, target, save  :: t1
 integer, pointer :: p1 => t1
 integer, pointer :: p3 => p1
end module m

... then I'd say this is valid, too. p1 itself is a pointer, but the
thing that it points to is a target (namely t1). Therefore "p3 => p1"
is valid, since the object on the RHS has the TARGET attribute. Can we
agree on that?

Cheers,
Janus

Re: [Patch, Fortran, F08] PR45290: pointer initialization

[Tobias Burnus]

  Janus Weil wrote:
> FAIL: gfortran.fortran-torture/execute/ptr.f90 compilation,  -O0
> FAIL: gfortran.dg/c_loc_tests_14.f90  -O  (test for excess errors)
> FAIL: gfortran.dg/c_loc_tests_5.f03  -O  (test for excess errors)
> FAIL: gfortran.dg/pointer_assign_4.f90  -O0  (test for excess errors)
> FAIL: gfortran.dg/pr43984.f90  -O  (test for excess errors)
> FAIL: gfortran.dg/subref_array_pointer_1.f90  -O0  (test for excess errors)
>
> All of them, except the C_LOC ones, fail on pointer assignments. And I
> think all of them are actually invalid.

At least NAG f95 accepts them all.


+++ gcc/testsuite/gfortran.dg/pr43984.f90 (working copy)

-  real(kind=kind(1.0d0)), dimension(:), pointer :: Izz
-      Izz =>  Iz(:,z)


That looks perfectly valid, cf. below.

-    integer(c_int), dimension(:), pointer :: int_ptr
-    my_c_ptr = c_loc(int_ptr(0))


Well, as written is is invalid - but change it to

-    integer(c_int), dimension(:), pointer :: int_ptr
ALLOCATE(int_ptr(0:10))
-    my_c_ptr = c_loc(int_ptr(0))


Then it is valid. Note: "int_ptr(0)" is not a pointer but "int_ptr(0)" 
is the first element of the array to which int_ptr points. That array is 
unnamed but has the TARGET attribute. If you want to have a named 
target, use:

integer, target :: tg(0:10)
-    integer(c_int), dimension(:), pointer :: int_ptr
int_ptr =>  tg
-    my_c_ptr = c_loc(int_ptr(0))

In this case int_ptr(0) is the first element of "tg" and "tg" has the 
TARGET attribute.

Tobias

Re: [Patch, Fortran, F08] PR45290: pointer initialization

[Janus Weil]

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

> But adding this patchlet:
>
>
> Index: gcc/fortran/primary.c
> ===================================================================
> --- gcc/fortran/primary.c       (revision 163310)
> +++ gcc/fortran/primary.c       (working copy)
> @@ -2017,8 +2017,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
>     }
>
>   target = attr.target;
> -  if (pointer || attr.proc_pointer)
> -    target = 1;
>
>   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
>     *ts = sym->ts;
> @@ -2074,8 +2072,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
>            pointer = comp->attr.pointer;
>            allocatable = comp->attr.allocatable;
>          }
> -       if (pointer || attr.proc_pointer)
> -         target = 1;
>
>        break;
>
>
> gives me a couple of regressions:
>
>
> FAIL: gfortran.fortran-torture/execute/ptr.f90 compilation,  -O0
> FAIL: gfortran.dg/c_loc_tests_14.f90  -O  (test for excess errors)
> FAIL: gfortran.dg/c_loc_tests_5.f03  -O  (test for excess errors)
> FAIL: gfortran.dg/pointer_assign_4.f90  -O0  (test for excess errors)
> FAIL: gfortran.dg/pr43984.f90  -O  (test for excess errors)
> FAIL: gfortran.dg/subref_array_pointer_1.f90  -O0  (test for excess errors)
>
> All of them, except the C_LOC ones, fail on pointer assignments. And I
> think all of them are actually invalid.


Here is an updated patch, which fixes the invalid test cases. It
should be free of regressions.

Ok so far?

I will re-check for regressions and take care of implicit SAVE in
PROGRAMS tomorrow.

Cheers,
Janus

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

Index: gcc/testsuite/gfortran.fortran-torture/execute/ptr.f90
===================================================================
--- gcc/testsuite/gfortran.fortran-torture/execute/ptr.f90	(revision 163310)
+++ gcc/testsuite/gfortran.fortran-torture/execute/ptr.f90	(working copy)
@@ -1,12 +1,10 @@
 program ptr
    implicit none
-   integer, pointer, dimension(:) :: a, b
+   integer, dimension(1:6), target :: a = (/ 1, 2, 3, 4, 5, 6 /)
+   integer, pointer, dimension(:) :: b
    integer, pointer :: p
    integer, target :: i
-
-   allocate (a(1:6))
   
-   a = (/ 1, 2, 3, 4, 5, 6 /)
    b => a
    if (any (b .ne. (/ 1, 2, 3, 4, 5, 6 /))) call abort
    b => a(1:6:2)
Index: gcc/testsuite/gfortran.dg/pr43984.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr43984.f90	(revision 163310)
+++ gcc/testsuite/gfortran.dg/pr43984.f90	(working copy)
@@ -15,7 +15,6 @@ subroutine make_esss(self,esss)
   type(shell1quartet_type) :: self
   intent(in) :: self
   real(kind=kind(1.0d0)), dimension(:), intent(out) :: esss
-  real(kind=kind(1.0d0)), dimension(:), pointer :: Izz
   real(kind=kind(1.0d0)), dimension(:,:), pointer :: Ix,Iy,Iz,Iyz
   integer(kind=kind(1)), dimension(:), pointer  :: e_x,ii_ivec
   integer(kind=kind(1)) :: dim, dim1, nroots, ii,z,y
@@ -38,10 +37,9 @@ subroutine make_esss(self,esss)
     esss = ZERO
     ii = 0
     do z=1,dim
-      Izz => Iz(:,z)
       do y=1,dim1-z
         ii = ii + 1
-        Iyz(:,ii) = Izz * Iy(:,y)
+        Iyz(:,ii) = Iz(:,z) * Iy(:,y)
       end do
     end do
     esss = esss + sum(Ix(:,e_x) * Iyz(:,ii_ivec),1)
Index: gcc/testsuite/gfortran.dg/c_loc_tests_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_loc_tests_5.f03	(revision 163310)
+++ gcc/testsuite/gfortran.dg/c_loc_tests_5.f03	(working copy)
@@ -6,13 +6,11 @@ contains
   subroutine sub0() bind(c)
     type(c_ptr) :: f_ptr, my_c_ptr
     character(kind=c_char, len=20), target :: format
-    integer(c_int), dimension(:), pointer :: int_ptr
     integer(c_int), dimension(10), target :: int_array
 
     f_ptr = c_loc(format(1:1))
 
-    int_ptr => int_array
-    my_c_ptr = c_loc(int_ptr(0))
+    my_c_ptr = c_loc(int_array(1))
 
   end subroutine sub0
 end module c_loc_tests_5
Index: gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90	(revision 163310)
+++ gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90	(working copy)
@@ -25,7 +25,7 @@ contains
     TYPE foo_array
       TYPE(foo), DIMENSION(:), POINTER :: array
     END TYPE
-    TYPE(foo_array)                :: array_holder
+    TYPE(foo_array),TARGET         :: array_holder
     INTEGER, DIMENSION(:), POINTER :: array_ptr
     ALLOCATE( array_holder%array(3) )
     array_holder%array = (/ foo(1), foo(2), foo(3) /)
Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90	(revision 163310)
+++ 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/testsuite/gfortran.dg/c_loc_tests_14.f90
===================================================================
--- gcc/testsuite/gfortran.dg/c_loc_tests_14.f90	(revision 163310)
+++ gcc/testsuite/gfortran.dg/c_loc_tests_14.f90	(working copy)
@@ -18,7 +18,7 @@
           TYPE(test2), DIMENSION(2) :: c
   END TYPE test
 
-  TYPE(test) :: chrScalar
+  TYPE(test), TARGET :: chrScalar
   TYPE(C_PTR) :: f_ptr
   TYPE(test3), TARGET :: d(3)
 
Index: gcc/testsuite/gfortran.dg/pointer_assign_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_assign_4.f90	(revision 163310)
+++ gcc/testsuite/gfortran.dg/pointer_assign_4.f90	(working copy)
@@ -28,9 +28,6 @@ program prog
     call abort()
   if((lbound(p2,dim=1) /= 1) .or. (ubound(p2,dim=1) /= 21)) &
     call abort()
-  p2 => p(:)
-  if((lbound(p2,dim=1) /= 1) .or. (ubound(p2,dim=1) /= 21)) &
-    call abort()
   call multdim()
 contains
   subroutine multdim()
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 163310)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -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_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/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 163310)
+++ gcc/fortran/symbol.c	(working copy)
@@ -1095,13 +1095,14 @@ gfc_add_result (symbol_attribute *attr, const char
 
 
 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_try
       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_try
 	  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_attr
     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);
 }
 
 
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 163310)
+++ 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)
 	{
@@ -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;
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 163310)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2466,7 +2466,7 @@ gfc_try gfc_add_cray_pointee (symbol_attribute *,
 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 *);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 163310)
+++ gcc/fortran/expr.c	(working copy)
@@ -3552,7 +3552,35 @@ 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.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;
 }
 
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 163310)
+++ 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;
 
@@ -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;
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 163310)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -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);
 
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 163310)
+++ gcc/fortran/primary.c	(working copy)
@@ -2016,10 +2016,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
       allocatable = attr.allocatable;
     }
 
-  target = attr.target;
-  if (pointer || attr.proc_pointer)
-    target = 1;
-
   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
     *ts = sym->ts;
 
@@ -2074,8 +2070,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
 	    pointer = comp->attr.pointer;
 	    allocatable = comp->attr.allocatable;
 	  }
-	if (pointer || attr.proc_pointer)
-	  target = 1;
 
 	break;
 
@@ -2087,7 +2081,8 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
   attr.dimension = dimension;
   attr.pointer = pointer;
   attr.allocatable = allocatable;
-  attr.target = target;
+  attr.target = sym->attr.target;
+  attr.save = sym->attr.save;
 
   return attr;
 }

Re: [Patch, Fortran, F08] PR45290: pointer initialization

[Janus Weil]

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

>>> And the following is invalid and gives an ICE:
>>>
>>> module m
>>>  integer, target, save  :: t1
>>>  integer, pointer :: p1 =>  t1
>>>  integer, pointer, save :: p2 =>  p2 ! invalid&  ICE
>>>  integer, pointer :: p3 =>  p1 ! ICE&  invalid as "p1" is not a TARGET
>>> end module m
>>
>> About this one I'm still not sure. F08 explicitly says:
>>
>> C556 An entity with the TARGET attribute shall not have the POINTER
>> attribute.
>>
>> But still gfc_variable_attr seems to set the TARGET attribute for
>> things that actually are POINTERS. Can someone explain this?
>
> Well, it gains the attribute after the declaration part when it appears as
> expression: in primary.c's gfc_variable_attr. If one looks at svn blame, one
> sees that the following line exists from the beginning of GCC 4.0.0:
>  if (pointer || attr.proc_pointer)
>    target = 1;
>
> I assume the idea was to allow for checks such as:
>  if (RHS->attr.target)
>    return Pointer_association_is_allowed
> instead of needing to use
>  if (RHS->attr.target || RHS->attr.pointer)
>    return Pointer_association_is_allowed
>
> But in my opinion, that's highly misleading and currently requires to write
> code such as
>  (attr.target && !attr.pointer)


Moreover it's plain wrong. But adding this patchlet:


Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 163310)
+++ gcc/fortran/primary.c	(working copy)
@@ -2017,8 +2017,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
     }

   target = attr.target;
-  if (pointer || attr.proc_pointer)
-    target = 1;

   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
     *ts = sym->ts;
@@ -2074,8 +2072,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
 	    pointer = comp->attr.pointer;
 	    allocatable = comp->attr.allocatable;
 	  }
-	if (pointer || attr.proc_pointer)
-	  target = 1;

 	break;


gives me a couple of regressions:


FAIL: gfortran.fortran-torture/execute/ptr.f90 compilation,  -O0
FAIL: gfortran.dg/c_loc_tests_14.f90  -O  (test for excess errors)
FAIL: gfortran.dg/c_loc_tests_5.f03  -O  (test for excess errors)
FAIL: gfortran.dg/pointer_assign_4.f90  -O0  (test for excess errors)
FAIL: gfortran.dg/pr43984.f90  -O  (test for excess errors)
FAIL: gfortran.dg/subref_array_pointer_1.f90  -O0  (test for excess errors)

All of them, except the C_LOC ones, fail on pointer assignments. And I
think all of them are actually invalid.



Some applicable quotes from F08:


Chapter 5.3.14:
 * C546 An entity with the POINTER attribute shall not have the
ALLOCATABLE, INTRINSIC, or TARGET attribute, and shall not be a
coarray.

Chapter 5.3.17:
 * C556 An entity with the TARGET attribute shall not have the POINTER
attribute.
 * If an object has the TARGET attribute, then all of its nonpointer
subobjects also have the TARGET attribute.

Chapter 6.4.2:
 * A structure component is a pointer only if the rightmost part name
is defined to have the POINTER attribute.

Chapter 6.5.3:
 * NOTE 6.10: Unless otherwise specified, an array element or array
section does not have an attribute of the whole array. In particular,
an array element or an array section does not have the POINTER or
ALLOCATABLE attribute.


Cheers,
Janus

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

Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90	(revision 163310)
+++ 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 163310)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -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_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/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 163310)
+++ gcc/fortran/symbol.c	(working copy)
@@ -1095,13 +1095,14 @@ gfc_add_result (symbol_attribute *attr, const char
 
 
 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_try
       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_try
 	  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_attr
     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);
 }
 
 
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 163310)
+++ 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)
 	{
@@ -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;
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 163310)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2466,7 +2466,7 @@ gfc_try gfc_add_cray_pointee (symbol_attribute *,
 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 *);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 163310)
+++ gcc/fortran/expr.c	(working copy)
@@ -3552,7 +3552,35 @@ 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.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;
 }
 
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 163310)
+++ 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;
 
@@ -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;
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 163310)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -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);
 
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 163310)
+++ gcc/fortran/primary.c	(working copy)
@@ -2017,8 +2017,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
     }
 
   target = attr.target;
-  if (pointer || attr.proc_pointer)
-    target = 1;
 
   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
     *ts = sym->ts;
@@ -2074,8 +2072,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
 	    pointer = comp->attr.pointer;
 	    allocatable = comp->attr.allocatable;
 	  }
-	if (pointer || attr.proc_pointer)
-	  target = 1;
 
 	break;
 
@@ -2088,6 +2084,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;
 }

Re: [Patch, Fortran, F08] PR45290: pointer initialization

[Tobias Burnus]

  Hi Janus,

Janus Weil wrote:
>> And the following is invalid and gives an ICE:
>>
>> module m
>>   integer, target, save  :: t1
>>   integer, pointer :: p1 =>  t1
>>   integer, pointer, save :: p2 =>  p2 ! invalid&  ICE
>>   integer, pointer :: p3 =>  p1 ! ICE&  invalid as "p1" is not a TARGET
>> end module m
> About this one I'm still not sure. F08 explicitly says:
>
> C556 An entity with the TARGET attribute shall not have the POINTER attribute.
>
> But still gfc_variable_attr seems to set the TARGET attribute for
> things that actually are POINTERS. Can someone explain this?

Well, it gains the attribute after the declaration part when it appears 
as expression: in primary.c's gfc_variable_attr. If one looks at svn 
blame, one sees that the following line exists from the beginning of GCC 
4.0.0:
   if (pointer || attr.proc_pointer)
     target = 1;

I assume the idea was to allow for checks such as:
   if (RHS->attr.target)
     return Pointer_association_is_allowed
instead of needing to use
   if (RHS->attr.target || RHS->attr.pointer)
     return Pointer_association_is_allowed

But in my opinion, that's highly misleading and currently requires to 
write code such as
   (attr.target && !attr.pointer)

I think the cleanest would be to remove the line and update the uses to 
include a "|| attr.pointer" or "|| attr.proc_pointer" where needed. -- 
And at the same time to remove the no longer needed && !attr.target). 
However, it might be a bit more lengthy task as one has to check several 
files.

Regarding the pointer initialization: In Fortran, a POINTER points to a 
named or anonymous target; thus, a pointer can never point to another 
pointer and "ptr2 => ptr1" associates the target of ptr1 with ptr2.  
Thus, "ptr2 => ptr1" does not make sense as initialization expression. 
Thus, also from this point of view it should be invalid.


Regarding your patch:

a) You do not set the implicit SAVE for the main program ("declared in 
the scoping unit of a main program, module, or submodule implicitly has 
the SAVE attribute") thus:

program main
   integer, target  :: t2
   integer, pointer :: p3 => t2
end program main

fails with:

Error: Pointer initialization target at (1) must have the SAVE attribute


b) The following gives still an ICE, but I probably should not be 
surprised because of the attr.target issue discussed above:

module m
   integer, target  :: t1
   integer, pointer :: p1 => t1
   integer, pointer, save :: p2 => p2 ! invalid & ICE
   integer, pointer :: p3 => p1 ! ICE & invalid as "p1" is not a TARGET
end module m

Otherwise, the patch looks OK to me.

Tobias

Re: [Patch, Fortran, F08] PR45290: pointer initialization

[Janus Weil]

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

Hi Tobias,

thanks for your feedback.

>> 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?
>
> For pointer initialization there is a case where the changed SAVE behaviour
> in Fortran 2008 matters. So far I had the impression that there is no such
> case, but seemingly we have now one. (Actually, that's not quite true: it
> also occurs for coarrays where I seem to handle it explicitly.)
>
> "A variable, common block, or procedure pointer declared in the scoping unit
> of a main program, module, or submodule implicitly has the SAVE attribute,
> which may be con rmed by explicit speci cation" (Fortran 2008, 5.3.16 SAVE
> attribute)
>
> Thus, I believe the following program is valid and should not be rejected.
> We have now two possibilities: (a) setting SAVE_IMPLICIT or (b) adding
> explicit check for pointer initialization.
>
>
> module m
>  integer, target  :: t1
>  integer, pointer :: p1 => t1 ! valid, "t1" is implicitly SAVE
> end module m

Ok, I have picked your option (a) and set SAVE_IMPLICIT in decl.c
(match_attr_spec). I also had to modify gfc_add_save to handle
SAVE_IMPLICIT (important e.g. when copying attributes).



> The following program ICEs (segfault) via
>    by 0x573B54: gfc_create_module_variable (trans-decl.c:3597)
> in
>    at 0x57E731: gfc_conv_variable (trans-expr.c:593)
>
>
> module m
>  integer, target, save  :: t1
>  integer, pointer :: p1 => t1
> end module m
>
> program main
>  use m
> end program main

Oops. To get rid of this I had to add the following hunk in trans-expr.c:

@@ -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

and then then another one:

Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 163296)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -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);



> And the following is invalid and gives an ICE:
>
> module m
>  integer, target, save  :: t1
>  integer, pointer :: p1 => t1
>  integer, pointer, save :: p2 => p2 ! invalid & ICE
>  integer, pointer :: p3 => p1 ! ICE & invalid as "p1" is not a TARGET
> end module m

About this one I'm still not sure. F08 explicitly says:

C556 An entity with the TARGET attribute shall not have the POINTER attribute.

But still gfc_variable_attr seems to set the TARGET attribute for
things that actually are POINTERS. Can someone explain this?


New patch attached.

Cheers,
Janus

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

Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90	(revision 163296)
+++ 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 163296)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -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_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/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 163296)
+++ gcc/fortran/symbol.c	(working copy)
@@ -1095,13 +1095,14 @@ gfc_add_result (symbol_attribute *attr, const char
 
 
 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_try
       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_try
 	  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_attr
     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);
 }
 
 
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 163296)
+++ 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)
 	{
@@ -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;
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 163296)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2466,7 +2466,7 @@ gfc_try gfc_add_cray_pointee (symbol_attribute *,
 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 *);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 163296)
+++ gcc/fortran/expr.c	(working copy)
@@ -3552,7 +3552,35 @@ 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.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;
 }
 
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 163296)
+++ 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;
 
@@ -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;
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 163296)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -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);
 
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 163296)
+++ 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;
 }

Re: [Patch, Fortran, F08] PR45290: pointer initialization

[Tobias Burnus]

  On 08/16/2010 11:40 PM, Janus Weil wrote:
> 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?

For pointer initialization there is a case where the changed SAVE 
behaviour in Fortran 2008 matters. So far I had the impression that 
there is no such case, but seemingly we have now one. (Actually, that's 
not quite true: it also occurs for coarrays where I seem to handle it 
explicitly.)

"A variable, common block, or procedure pointer declared in the scoping 
unit of a main program, module, or submodule implicitly has the SAVE 
attribute, which may be con\frmed by explicit speci\fcation" (Fortran 
2008, 5.3.16 SAVE attribute)

Thus, I believe the following program is valid and should not be 
rejected. We have now two possibilities: (a) setting SAVE_IMPLICIT or 
(b) adding explicit check for pointer initialization.


module m
   integer, target  :: t1
   integer, pointer :: p1 => t1 ! valid, "t1" is implicitly SAVE
end module m


The following program ICEs (segfault) via
     by 0x573B54: gfc_create_module_variable (trans-decl.c:3597)
in
     at 0x57E731: gfc_conv_variable (trans-expr.c:593)


module m
   integer, target, save  :: t1
   integer, pointer :: p1 => t1
end module m

program main
   use m
end program main

And the following is invalid and gives an ICE:

module m
   integer, target, save  :: t1
   integer, pointer :: p1 => t1
   integer, pointer, save :: p2 => p2 ! invalid & ICE
   integer, pointer :: p3 => p1 ! ICE & invalid as "p1" is not a TARGET
end module m

Tobias

Re: [Patch, Fortran, F08] PR45290: pointer initialization

[Jerry DeLisle]

On 08/16/2010 02:40 PM, Janus Weil wrote:
> 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?
>
Looks OK, thanks!

Jerry

[Patch, Fortran, F08] PR45290: pointer initialization

[Janus Weil]

[-- 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" } }