diff mbox

[Fortran] PR 47569 - fix ICE (regression) and fix diagnostic

Message ID 4D57CEEF.5020301@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Feb. 13, 2011, 12:30 p.m. UTC 
Dear Mikael, dear all,

attached is an updated version of the patch, incorporating the 
suggestions of Mikael (thanks!). I think I have indeed misread part of 
the standard. (Twice!)

The new patch continues to accepts all default/C_CHAR kind characters. 
Other character kinds are still accepted, but now properly diagnosed. 
The pointer checking and the handling of (nested) components has been 
fixed - which was the original PR.

Build and regtested on x86-64-linux
OK for the trunk? To which of 4.3/4.4/4.5 do we want to backport it?

Tobias

Comments

Mikael Morin Feb. 13, 2011, 3:12 p.m. UTC | #1 
On Sunday 13 February 2011 13:30:39 Tobias Burnus wrote:
> Dear Mikael, dear all,
> 
> attached is an updated version of the patch, incorporating the
> suggestions of Mikael (thanks!). I think I have indeed misread part of
> the standard. (Twice!)
> 
> The new patch continues to accepts all default/C_CHAR kind characters.
> Other character kinds are still accepted, but now properly diagnosed.
> The pointer checking and the handling of (nested) components has been
> fixed - which was the original PR.
> 
> Build and regtested on x86-64-linux
> OK for the trunk? To which of 4.3/4.4/4.5 do we want to backport it?
> 
> Tobias
> 
> 
> arg-check-ice-v5.diff
>   2011-02-13  Tobias Burnus  <burnus@net-b.de>
> 
>         PR fortran/47569
>         * interface.c (compare_parameter): Avoid ICE with
>         character components.
> 
> 2011-02-13  Tobias Burnus  <burnus@net-b.de>
> 
>         * gfortran.dg/argument_checking_13.f90: Update dg-error.
>         * gfortran.dg/argument_checking_17.f90: New.
> 
> --- /dev/null   2011-02-12 08:11:41.879999996 +0100
> +++ gcc/gcc/testsuite/gfortran.dg/argument_checking_17.f90      2011-02-01 
15:02:42.000000000 +0100
> @@ -0,0 +1,26 @@
> +! { dg-do compile }
> +!
> +! PR fortran/47569
> +!
> +! Contributed by Jos de Kloe 
> +!
> +module teststr
> +  implicit none
> +  integer, parameter :: GRH_SIZE = 20, NMAX = 41624
> +  type strtype
> +    integer   :: size
> +    character :: mdr(NMAX)
> +  end type strtype
> +contains
> +  subroutine sub2(string,str_size)
> +    integer,intent(in)    :: str_size
> +    character,intent(out) :: string(str_size)
> +    string(:) = 'a'
> +  end subroutine sub2
> +  subroutine sub1(a)
> +    type(strtype),intent(inout) :: a
> +    call sub2(a%mdr(GRH_SIZE+1),a%size-GRH_SIZE)
> +  end subroutine sub1
> +end module teststr
> +
> +! { dg-final { cleanup-modules "teststr" } }
> diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
> index 1e5df61..120f0ce 100644
> --- a/gcc/fortran/interface.c
> +++ b/gcc/fortran/interface.c
> @@ -1461,7 +1461,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr 
*actual,
>                    int ranks_must_agree, int is_elemental, locus *where)
>  {
>    gfc_ref *ref;
> -  bool rank_check;
> +  bool rank_check, is_pointer;
>  
>    /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
>       procs c_f_pointer or c_f_procpointer, and we need to accept most
> @@ -1672,23 +1672,56 @@ compare_parameter (gfc_symbol *formal, gfc_expr 
*actual,
>      return 1;
>  
>    /* At this point, we are considering a scalar passed to an array.   This
> -     is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
> +     is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
>       - if the actual argument is (a substring of) an element of a
> -       non-assumed-shape/non-pointer array;
> -     - (F2003) if the actual argument is of type character.  */
> +       non-assumed-shape/non-pointer/non-polymorphic array;
> +     - (F2003) if the actual argument is of type character of 
default/c_char
> +       kind.  */
One could emphasize here that it is a or, i.e. only one condition has to be 
met. 
Maybe it is the reason why you misread the standard?

Anyway, the patch is OK; about the backport:
4.5: yes, 4.3: no need to bother (unless you feel like bothering...)
4.4: as you wish; the bug reporter would probably appreciate to have it in 
4.4.

Thanks
Mikael
diff mbox

Patch

2011-02-13  Tobias Burnus  <burnus@net-b.de>

	PR fortran/47569
	* interface.c (compare_parameter): Avoid ICE with
	character components.

2011-02-13  Tobias Burnus  <burnus@net-b.de>

	* gfortran.dg/argument_checking_13.f90: Update dg-error.
	* gfortran.dg/argument_checking_17.f90: New.

--- /dev/null	2011-02-12 08:11:41.879999996 +0100
+++ gcc/gcc/testsuite/gfortran.dg/argument_checking_17.f90	2011-02-01 15:02:42.000000000 +0100
@@ -0,0 +1,26 @@ 
+! { dg-do compile }
+!
+! PR fortran/47569
+!
+! Contributed by Jos de Kloe 
+!
+module teststr
+  implicit none
+  integer, parameter :: GRH_SIZE = 20, NMAX = 41624
+  type strtype
+    integer   :: size
+    character :: mdr(NMAX)
+  end type strtype
+contains
+  subroutine sub2(string,str_size)
+    integer,intent(in)    :: str_size
+    character,intent(out) :: string(str_size)
+    string(:) = 'a'
+  end subroutine sub2
+  subroutine sub1(a)
+    type(strtype),intent(inout) :: a
+    call sub2(a%mdr(GRH_SIZE+1),a%size-GRH_SIZE)
+  end subroutine sub1
+end module teststr
+
+! { dg-final { cleanup-modules "teststr" } }
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 1e5df61..120f0ce 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1461,7 +1461,7 @@  compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 		   int ranks_must_agree, int is_elemental, locus *where)
 {
   gfc_ref *ref;
-  bool rank_check;
+  bool rank_check, is_pointer;
 
   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
      procs c_f_pointer or c_f_procpointer, and we need to accept most
@@ -1672,23 +1672,56 @@  compare_parameter (gfc_symbol *formal, gfc_expr *actual,
     return 1;
 
   /* At this point, we are considering a scalar passed to an array.   This
-     is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
+     is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
      - if the actual argument is (a substring of) an element of a
-       non-assumed-shape/non-pointer array;
-     - (F2003) if the actual argument is of type character.  */
+       non-assumed-shape/non-pointer/non-polymorphic array;
+     - (F2003) if the actual argument is of type character of default/c_char
+       kind.  */
+
+  is_pointer = actual->expr_type == EXPR_VARIABLE
+	       ? actual->symtree->n.sym->attr.pointer : false;
 
   for (ref = actual->ref; ref; ref = ref->next)
-    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
-	&& ref->u.ar.dimen > 0)
-      break;
+    {
+      if (ref->type == REF_COMPONENT)
+	is_pointer = ref->u.c.component->attr.pointer;
+      else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+	       && ref->u.ar.dimen > 0
+	       && (!ref->next 
+		   || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
+        break;
+    }
+
+  if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
+    {
+      if (where)
+	gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
+		   "at %L", formal->name, &actual->where);
+      return 0;
+    }
 
-  /* Not an array element.  */
-  if (formal->ts.type == BT_CHARACTER
-      && (ref == NULL
-          || (actual->expr_type == EXPR_VARIABLE
-	      && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
-		  || actual->symtree->n.sym->attr.pointer))))
+  if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
+      && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
     {
+      if (where)
+	gfc_error ("Element of assumed-shaped or pointer "
+		   "array passed to array dummy argument '%s' at %L",
+		   formal->name, &actual->where);
+      return 0;
+    }
+
+  if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
+      && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
+    {
+      if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
+	{
+	  if (where)
+	    gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
+		       "CHARACTER actual argument with array dummy argument "
+		       "'%s' at %L", formal->name, &actual->where);
+	  return 0;
+	}
+
       if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
 	{
 	  gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
@@ -1701,7 +1734,8 @@  compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       else
 	return 1;
     }
-  else if (ref == NULL && actual->expr_type != EXPR_NULL)
+
+  if (ref == NULL && actual->expr_type != EXPR_NULL)
     {
       if (where)
 	argument_rank_mismatch (formal->name, &actual->where,
@@ -1709,17 +1743,6 @@  compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       return 0;
     }
 
-  if (actual->expr_type == EXPR_VARIABLE
-      && actual->symtree->n.sym->as
-      && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
-	  || actual->symtree->n.sym->attr.pointer))
-    {
-      if (where)
-	gfc_error ("Element of assumed-shaped array passed to dummy "
-		   "argument '%s' at %L", formal->name, &actual->where);
-      return 0;
-    }
-
   return 1;
 }
 
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_13.f90 b/gcc/testsuite/gfortran.dg/argument_checking_13.f90
index ae3fd22..b94bbc7 100644
--- a/gcc/testsuite/gfortran.dg/argument_checking_13.f90
+++ b/gcc/testsuite/gfortran.dg/argument_checking_13.f90
@@ -26,9 +26,9 @@  real, pointer :: pointer_dummy(:,:,:)
 real, allocatable :: deferred(:,:,:)
 real, pointer     :: ptr(:,:,:)
 call rlv1(deferred(1,1,1))         ! valid since contiguous
-call rlv1(ptr(1,1,1))              ! { dg-error "Element of assumed-shaped array" }
-call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped array" }
-call rlv1(pointer_dummy(1,1,1))    ! { dg-error "Element of assumed-shaped array" }
+call rlv1(ptr(1,1,1))              ! { dg-error "Element of assumed-shaped or pointer array" }
+call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" }
+call rlv1(pointer_dummy(1,1,1))    ! { dg-error "Element of assumed-shaped or pointer array" }
 end
 
 subroutine test2(assumed_sh_dummy, pointer_dummy)