Patchwork [Fortran] PR55763 - improve init-data checks for pointers

login
register
mail settings
Submitter Tobias Burnus
Date Jan. 4, 2013, 12:51 p.m.
Message ID <50E6D03A.3020001@net-b.de>
Download mbox | patch
Permalink /patch/209451/
State New
Headers show

Comments

Tobias Burnus - Jan. 4, 2013, 12:51 p.m.
Fortran 2008 allows:
    integer :: pointer => init_data
and
   type t
      integer :: pointer => init_data
   end type t

The current check in gfc_check_assign_symbol was only called for former 
and for constructors, but not for the type definition. Additionally, 
BT_CLASS wasn't handled. I also improved the error location.



The patch has a downside: One gets some messages twice or trice: Once 
for resolving the type declaration ("type t") and then for resolving the 
default initialization via
    gfc_traverse_ns (ns, resolve_values);

Currently, that's unavoidable as one cannot trivially distinguish 
between a user-supplied "sym->value" and the default constructor. If you 
think that this is a problem, one can change it, e.g. by setting a 
sym->attr.value_is_default_init.


Build and regtested on x86-64-gnu-linux.
OK for the trunk?

Tobias

PS: For CLASS pointers, there will be an ICE if one tries to associate a 
variable to them; that's unchanged by this patch.
Tobias Burnus - Jan. 6, 2013, 2:40 p.m.
Early * ping*
http://gcc.gnu.org/ml/fortran/2013-01/msg00025.html


On January 4, 2013, Tobias Burnus wrote:
> Fortran 2008 allows:
>    integer :: pointer => init_data
> and
>   type t
>      integer :: pointer => init_data
>   end type t
>
> The current check in gfc_check_assign_symbol was only called for 
> former and for constructors, but not for the type definition. 
> Additionally, BT_CLASS wasn't handled. I also improved the error 
> location.
>
>
>
> The patch has a downside: One gets some messages twice or trice: Once 
> for resolving the type declaration ("type t") and then for resolving 
> the default initialization via
>    gfc_traverse_ns (ns, resolve_values);
>
> Currently, that's unavoidable as one cannot trivially distinguish 
> between a user-supplied "sym->value" and the default constructor. If 
> you think that this is a problem, one can change it, e.g. by setting a 
> sym->attr.value_is_default_init.
>
>
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?
>
> Tobias
>
> PS: For CLASS pointers, there will be an ICE if one tries to associate 
> a variable to them; that's unchanged by this patch.
Mikael Morin - Jan. 7, 2013, 5:36 p.m.
Hello,

Le 04/01/2013 13:51, Tobias Burnus a écrit :
> diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
> index 2610784..146154e 100644
> --- a/gcc/fortran/expr.c
> +++ b/gcc/fortran/expr.c
> @@ -3291,22 +3291,21 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
>  gfc_try
>  gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
>  {
> -  symbol_attribute attr;
> +  symbol_attribute attr, lhs_attr;
>    gfc_ref *ref;
>    bool is_pure, is_implicit_pure, rank_remap;
>    int proc_pointer;
>
> -  if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
> -      && !lvalue->symtree->n.sym->attr.proc_pointer)
> +  lhs_attr = gfc_expr_attr (lvalue);
> +  if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer)
>      {
>        gfc_error ("Pointer assignment target is not a POINTER at %L",
>  		 &lvalue->where);
>        return FAILURE;
>      }
>
> -  if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
> -      && lvalue->symtree->n.sym->attr.use_assoc
> -      && !lvalue->symtree->n.sym->attr.proc_pointer)
> +  if (lhs_attr.flavor == FL_PROCEDURE && lvalue->symtree->n.sym->attr.use_assoc
Should it be lhs_attr.use_assoc (for consistency)?


> The patch has a downside: One gets some messages twice or trice: Once
> for resolving the type declaration ("type t") and then for resolving the
> default initialization via
> gfc_traverse_ns (ns, resolve_values);
That's a bit annoying, but better have diagnostics twice than not at all.

>
> Currently, that's unavoidable as one cannot trivially distinguish
> between a user-supplied "sym->value" and the default constructor. If you
> think that this is a problem, one can change it, e.g. by setting a
> sym->attr.value_is_default_init.
Or we can keep sym->value cleared until translation stage where the 
(default) initialization is picked directly from the type.
Anyway....

>
>
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?
....OK (even in its current state).

Mikael

Patch

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

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

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

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

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index fc86efb..5952b70 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1353,14 +1353,14 @@  add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
       if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
 	  && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
 	  && !sym->attr.proc_pointer 
-	  && gfc_check_assign_symbol (sym, init) == FAILURE)
+	  && gfc_check_assign_symbol (sym, NULL, init) == FAILURE)
 	return FAILURE;
 
       if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
 	    && init->ts.type == BT_CHARACTER)
 	{
 	  /* Update symbol character length according initializer.  */
-	  if (gfc_check_assign_symbol (sym, init) == FAILURE)
+	  if (gfc_check_assign_symbol (sym, NULL, init) == FAILURE)
 	    return FAILURE;
 
 	  if (sym->ts.u.cl->length == NULL)
@@ -6955,7 +6955,7 @@  do_parm (void)
       goto cleanup;
     }
 
-  if (gfc_check_assign_symbol (sym, init) == FAILURE
+  if (gfc_check_assign_symbol (sym, NULL, init) == FAILURE
       || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
     {
       m = MATCH_ERROR;
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 2610784..146154e 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3291,22 +3291,21 @@  gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
 gfc_try
 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 {
-  symbol_attribute attr;
+  symbol_attribute attr, lhs_attr;
   gfc_ref *ref;
   bool is_pure, is_implicit_pure, rank_remap;
   int proc_pointer;
 
-  if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
-      && !lvalue->symtree->n.sym->attr.proc_pointer)
+  lhs_attr = gfc_expr_attr (lvalue);
+  if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer)
     {
       gfc_error ("Pointer assignment target is not a POINTER at %L",
 		 &lvalue->where);
       return FAILURE;
     }
 
-  if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
-      && lvalue->symtree->n.sym->attr.use_assoc
-      && !lvalue->symtree->n.sym->attr.proc_pointer)
+  if (lhs_attr.flavor == FL_PROCEDURE && lvalue->symtree->n.sym->attr.use_assoc
+      && !lhs_attr.proc_pointer)
     {
       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
 		 "l-value since it is a procedure",
@@ -3735,10 +3734,11 @@  gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
    symbol.  Used for initialization assignments.  */
 
 gfc_try
-gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
+gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
 {
   gfc_expr lvalue;
   gfc_try r;
+  bool pointer, proc_pointer;
 
   memset (&lvalue, '\0', sizeof (gfc_expr));
 
@@ -3750,9 +3750,27 @@  gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
   lvalue.symtree->n.sym = sym;
   lvalue.where = sym->declared_at;
 
-  if (sym->attr.pointer || sym->attr.proc_pointer
-      || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer
-	  && rvalue->expr_type == EXPR_NULL))
+  if (comp)
+    {
+      lvalue.ref = gfc_get_ref ();
+      lvalue.ref->type = REF_COMPONENT;
+      lvalue.ref->u.c.component = comp;
+      lvalue.ref->u.c.sym = sym;
+      lvalue.ts = comp->ts;
+      lvalue.rank = comp->as ? comp->as->rank : 0;
+      lvalue.where = comp->loc;
+      pointer = comp->ts.type == BT_CLASS &&  CLASS_DATA (comp)
+		? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer;
+      proc_pointer = comp->attr.proc_pointer;
+    }
+  else
+    {
+      pointer = sym->ts.type == BT_CLASS &&  CLASS_DATA (sym)
+		? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
+      proc_pointer = sym->attr.proc_pointer;
+    }
+
+  if (pointer || proc_pointer)
     r = gfc_check_pointer_assign (&lvalue, rvalue);
   else
     r = gfc_check_assign (&lvalue, rvalue, 1);
@@ -3762,32 +3780,41 @@  gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
   if (r == FAILURE)
     return r;
 
-  if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
+  if (pointer && rvalue->expr_type != EXPR_NULL)
     {
       /* F08:C461. Additional checks for pointer initialization.  */
       symbol_attribute attr;
       attr = gfc_expr_attr (rvalue);
       if (attr.allocatable)
 	{
-	  gfc_error ("Pointer initialization target at %C "
-	             "must not be ALLOCATABLE ");
+	  gfc_error ("Pointer initialization target at %L "
+	             "must not be ALLOCATABLE", &rvalue->where);
 	  return FAILURE;
 	}
       if (!attr.target || attr.pointer)
 	{
-	  gfc_error ("Pointer initialization target at %C "
-		     "must have the TARGET attribute");
+	  gfc_error ("Pointer initialization target at %L "
+		     "must have the TARGET attribute", &rvalue->where);
 	  return FAILURE;
 	}
+
+      if (!attr.save && rvalue->expr_type == EXPR_VARIABLE
+	  && rvalue->symtree->n.sym->ns->proc_name
+	  && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program)
+	{
+	  rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT;
+	  attr.save = SAVE_IMPLICIT;
+	}
+
       if (!attr.save)
 	{
-	  gfc_error ("Pointer initialization target at %C "
-		     "must have the SAVE attribute");
+	  gfc_error ("Pointer initialization target at %L "
+		     "must have the SAVE attribute", &rvalue->where);
 	  return FAILURE;
 	}
     }
 
-  if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL)
+  if (proc_pointer && rvalue->expr_type != EXPR_NULL)
     {
       /* F08:C1220. Additional checks for procedure pointer initialization.  */
       symbol_attribute attr = gfc_expr_attr (rvalue);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a419af3..4e6e455 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2769,7 +2769,7 @@  int gfc_kind_max (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3;
 gfc_try gfc_check_assign (gfc_expr *, gfc_expr *, int);
 gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
-gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
+gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_component *, gfc_expr *);
 
 bool gfc_has_default_initializer (gfc_symbol *);
 gfc_expr *gfc_default_initializer (gfc_typespec *);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 873400a..fcd9f63 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1105,23 +1105,28 @@  resolve_structure_cons (gfc_expr *expr, int init)
       if (!comp->attr.proc_pointer &&
 	  !gfc_compare_types (&cons->expr->ts, &comp->ts))
 	{
-	  t = FAILURE;
 	  if (strcmp (comp->name, "_extends") == 0)
 	    {
 	      /* Can afford to be brutal with the _extends initializer.
 		 The derived type can get lost because it is PRIVATE
 		 but it is not usage constrained by the standard.  */
 	      cons->expr->ts = comp->ts;
-	      t = SUCCESS;
 	    }
 	  else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
-	    gfc_error ("The element in the structure constructor at %L, "
-		       "for pointer component '%s', is %s but should be %s",
-		       &cons->expr->where, comp->name,
-		       gfc_basic_typename (cons->expr->ts.type),
-		       gfc_basic_typename (comp->ts.type));
+	    {
+	      gfc_error ("The element in the structure constructor at %L, "
+			 "for pointer component '%s', is %s but should be %s",
+			 &cons->expr->where, comp->name,
+			 gfc_basic_typename (cons->expr->ts.type),
+			 gfc_basic_typename (comp->ts.type));
+	      t = FAILURE;
+	    }
 	  else
-	    t = gfc_convert_type (cons->expr, &comp->ts, 1);
+	    {
+	      gfc_try t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
+	      if (t != FAILURE)
+		t = t2;
+	    }
 	}
 
       /* For strings, the length of the constructor should be the same as
@@ -10428,7 +10433,7 @@  resolve_values (gfc_symbol *sym)
   if (t == FAILURE)
     return;
 
-  gfc_check_assign_symbol (sym, sym->value);
+  gfc_check_assign_symbol (sym, NULL, sym->value);
 }
 
 
@@ -12852,6 +12857,10 @@  resolve_fl_derived0 (gfc_symbol *sym)
 					   || c->attr.proc_pointer
 					   || c->attr.allocatable)) == FAILURE)
 	return FAILURE;
+
+      if (c->initializer && !sym->attr.vtype
+	  && gfc_check_assign_symbol (sym, c, c->initializer) == FAILURE)
+	return FAILURE;
     }
 
   check_defined_assignments (sym);
diff --git a/gcc/testsuite/gfortran.dg/pointer_init_2.f90 b/gcc/testsuite/gfortran.dg/pointer_init_2.f90
index 8f72663..a280a3e 100644
--- a/gcc/testsuite/gfortran.dg/pointer_init_2.f90
+++ b/gcc/testsuite/gfortran.dg/pointer_init_2.f90
@@ -24,13 +24,26 @@  subroutine sub
 
   type :: t
     integer, pointer :: dpc0 => 13  ! { dg-error "Error in pointer initialization" }
-    integer, pointer :: dpc1 => r   ! { dg-error "is REAL but should be INTEGER" }
-    integer, pointer :: dpc2 => v   ! { dg-error "rank of the element.*does not match" }
-    integer, pointer :: dpc3 => i   ! { dg-error "should be a POINTER or a TARGET" }
+  end type t
+
+  type t2
+    integer, pointer :: dpc1 => r   ! { dg-error "attempted assignment of REAL.4. to INTEGER.4." }
+  end type t2
+
+  type t3
+    integer, pointer :: dpc2 => v   ! { dg-error "Different ranks in pointer assignment" }
+  end type t3
+
+  type t4
+    integer, pointer :: dpc3 => i   ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" }
+  end type t4
+
+  type t5
     integer, pointer :: dpc4 => j   ! { dg-error "must have the SAVE attribute" }
-    integer, pointer :: dpc5 => a   ! { dg-error "must not be ALLOCATABLE" }
-  end type
+  end type t5
 
-  type(t) ::u
+  type t6
+    integer, pointer :: dpc5 => a   ! { dg-error "must not be ALLOCATABLE" }
+  end type t6
 
 end subroutine
diff --git a/gcc/testsuite/gfortran.dg/pointer_init_7.f90 b/gcc/testsuite/gfortran.dg/pointer_init_7.f90
new file mode 100644
index 0000000..dfde615
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_init_7.f90
@@ -0,0 +1,56 @@ 
+! { dg-do compile }
+!
+! PR fortran/55763
+!
+
+subroutine sub()
+  type t
+    integer :: i
+  end type t
+
+  type(t), target :: tgt
+  type(t), target, save :: tgt2(2)
+
+  type t2a
+    type(t),  pointer :: cmp1 => tgt   ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  end type t2a
+
+  type t2b
+    class(t), pointer :: cmp2 => tgt   ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  end type t2b
+
+  type t2c
+    class(t), pointer :: cmp3 => tgt   ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  end type t2c
+
+  type t2d
+    integer,  pointer :: cmp4 => tgt%i ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  end type t2d
+
+  type(t),  pointer :: w => tgt   ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  class(t), pointer :: x => tgt   ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  class(*), pointer :: y => tgt   ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+  integer,  pointer :: z => tgt%i ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" }
+end subroutine
+
+program main
+  type t3
+    integer :: j
+  end type t3
+
+  type(t3), target :: tgt
+
+  type t4
+    type(t3),  pointer :: cmp1 => tgt   ! OK
+    class(t3), pointer :: cmp2 => tgt   ! OK
+    class(t3), pointer :: cmp3 => tgt   ! OK
+    integer,   pointer :: cmp4 => tgt%j ! OK
+  end type t4
+
+  type(t3), target :: mytarget
+
+  type(t3),  pointer :: a => mytarget   ! OK
+  class(t3), pointer :: b => mytarget   ! OK
+  class(*),  pointer :: c => mytarget   ! OK
+  integer,   pointer :: d => mytarget%j ! OK
+end program main