Patchwork [Fortran] PR57035 - add constraint checks for type(*), dimension(..) and NO_ARG_CHECK

login
register
mail settings
Submitter Tobias Burnus
Date April 23, 2013, 7:58 a.m.
Message ID <51763F3A.4020905@net-b.de>
Download mbox | patch
Permalink /patch/238777/
State New
Headers show

Comments

Tobias Burnus - April 23, 2013, 7:58 a.m.
The constraint checks for assumed-type and assumed-rank with regards to 
intrinsics only worked very indirectly and, hence, was not strict 
enough. That's now fixed with the attached patch - also for 
NO_ARG_CHECK. For the latter, it also improves the wording a bit and 
allows PRESENT as second permitted intrinsic. (That's the same as for 
TYPE(*) minus the array intrinsics.)

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

Tobias
Mikael Morin - April 25, 2013, 10:13 p.m.
Hello,

Le 23/04/2013 09:58, Tobias Burnus a écrit :
> The constraint checks for assumed-type and assumed-rank with regards to
> intrinsics only worked very indirectly and, hence, was not strict
> enough. That's now fixed with the attached patch - also for
> NO_ARG_CHECK. For the latter, it also improves the wording a bit and
> allows PRESENT as second permitted intrinsic. (That's the same as for
> TYPE(*) minus the array intrinsics.)
> 
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?
> 

> diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
> index f4bcdef..78ac0f7 100644
> --- a/gcc/fortran/gfortran.texi
> +++ b/gcc/fortran/gfortran.texi
> @@ -2694,17 +2694,18 @@ with this attribute actual arguments of any type and kind (similar to
>  @code{TYPE(*)}), scalars and arrays of any rank (no equivalent
>  in Fortran standard) are accepted.  As with @code{TYPE(*)}, the argument
>  is unlimited polymorphic and no type information is available.
> -Additionally, the same restrictions apply, i.e. the argument may only be
> -passed to dummy arguments with the @code{NO_ARG_CHECK} attribute and as
> -argument to the @code{C_LOC} intrinsic function of the @code{ISO_C_BINDING}
> -module.
> +Additionally, the the argument may only be passed to dummy arguments
s/the the/the/

> +with the @code{NO_ARG_CHECK} attribute and as argument to the
> +@code{PRESENT} intrinsic function and to @code{C_LOC} of the
> +@code{ISO_C_BINDING} module.
>  
> diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
> index 688332f..cc62c6c 100644
> --- a/gcc/fortran/intrinsic.c
> +++ b/gcc/fortran/intrinsic.c
> @@ -182,10 +182,65 @@ static bool
[...]
> +      else if (a->expr->ts.type == BT_ASSUMED
> +	       && (a != arg
> +		   || (specific->id != GFC_ISYM_LBOUND
> +		       && specific->id != GFC_ISYM_PRESENT
> +		       && specific->id != GFC_ISYM_RANK
> +		       && specific->id != GFC_ISYM_SHAPE
> +		       && specific->id != GFC_ISYM_SIZE
> +		       && specific->id != GFC_ISYM_UBOUND
> +		       && specific->id != GFC_ISYM_C_LOC)))
I think that when both of the || conditions are true...

> +	{
> +	  if (a != arg)
> +	    gfc_error ("Assumed-type argument at %L is only permitted as "
> +		       "first actual argument to the intrinsic %s",
> +		       &a->expr->where, gfc_current_intrinsic);
> +	  else
> +	    gfc_error ("Assumed-type argument at %L is not permitted as actual"
> +		       " argument to the intrinsic %s", &a->expr->where,
> +		       gfc_current_intrinsic);
> +	  return false;
> +	}
... the second error should be preferred.
Testcase:

 subroutine thirteen(x, y)
   type(*) :: x
   integer, pointer :: y
   print *, associated(y, x)
   print *, associated(x)
 end subroutine thirteen


output:
test.f90:4.26:

   print *, associated(y, x)
                          1
Error: Assumed-type argument at (1) is only permitted as first actual
argument to the intrinsic associated
test.f90:5.23:

   print *, associated(x)
                       1
Error: Assumed-type argument at (1) is not permitted as actual argument
to the intrinsic associated



Otherwise looks good.
Mikael

Patch

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

	PR fortran/57035
	* intrinsic.c (do_check): Add contraint check for
	NO_ARG_CHECK, assumed rank and assumed type.
	* gfortran.texi (NO_ARG_CHECK): Minor wording change,
	allow PRESENT intrinsic.

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

	PR fortran/57035
	* gfortran.dg/assumed_type_5.f90: New.
	* gfortran.dg/assumed_rank_1.f90: Comment invalid statement.
	* gfortran.dg/assumed_rank_2.f90: Ditto.
	* gfortran.dg/assumed_type_3.f90: Update dg-error.
	* gfortran.dg/no_arg_check_3.f90: Ditto.

diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index f4bcdef..78ac0f7 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -2694,17 +2694,18 @@  with this attribute actual arguments of any type and kind (similar to
 @code{TYPE(*)}), scalars and arrays of any rank (no equivalent
 in Fortran standard) are accepted.  As with @code{TYPE(*)}, the argument
 is unlimited polymorphic and no type information is available.
-Additionally, the same restrictions apply, i.e. the argument may only be
-passed to dummy arguments with the @code{NO_ARG_CHECK} attribute and as
-argument to the @code{C_LOC} intrinsic function of the @code{ISO_C_BINDING}
-module.
+Additionally, the the argument may only be passed to dummy arguments
+with the @code{NO_ARG_CHECK} attribute and as argument to the
+@code{PRESENT} intrinsic function and to @code{C_LOC} of the
+@code{ISO_C_BINDING} module.
 
 Variables with @code{NO_ARG_CHECK} attribute shall be of assumed-type
-(@code{TYPE(*)}; recommended) or of an intrinsic numeric type; they
-shall not have the @code{ALLOCATE}, @code{CODIMENSION}, @code{INTENT(OUT)},
-@code{POINTER} or @code{VALUE} attribute; furthermore, they shall be
-either scalar or of assumed-size (@code{dimension(*)}). As @code{TYPE(*)},
-the @code{NO_ARG_CHECK} attribute requires an explicit interface.
+(@code{TYPE(*)}; recommended) or of type @code{INTEGER}, @code{LOGICAL},
+@code{REAL} or @code{COMPLEX}. They shall not have the @code{ALLOCATE},
+@code{CODIMENSION}, @code{INTENT(OUT)}, @code{POINTER} or @code{VALUE}
+attribute; furthermore, they shall be either scalar or of assumed-size
+(@code{dimension(*)}). As @code{TYPE(*)}, the @code{NO_ARG_CHECK} attribute
+requires an explicit interface.
 
 @itemize
 @item @code{NO_ARG_CHECK} -- disable the type, kind and rank checking
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 688332f..cc62c6c 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -182,10 +182,65 @@  static bool
 do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
 {
   gfc_expr *a1, *a2, *a3, *a4, *a5;
+  gfc_actual_arglist *a;
 
   if (arg == NULL)
     return (*specific->check.f0) ();
 
+  /* Check TS29113, C407b for assumed type and C535b for assumed-rank,
+     and a likewise check for NO_ARG_CHECK.  */
+  for (a = arg; a; a = a->next)
+    {
+      if (!a->expr)
+	continue;
+
+      if (a->expr->expr_type == EXPR_VARIABLE
+	  && (a->expr->symtree->n.sym->attr.ext_attr
+	      & (1 << EXT_ATTR_NO_ARG_CHECK))
+	  && specific->id != GFC_ISYM_C_LOC
+	  && specific->id != GFC_ISYM_PRESENT)
+	{
+	  gfc_error ("Variable with NO_ARG_CHECK attribute at %L is only "
+		     "permitted as argument to the intrinsic functions "
+		     "C_LOC and PRESENT", &a->expr->where);
+	  return false;
+	}
+      else if (a->expr->ts.type == BT_ASSUMED
+	       && (a != arg
+		   || (specific->id != GFC_ISYM_LBOUND
+		       && specific->id != GFC_ISYM_PRESENT
+		       && specific->id != GFC_ISYM_RANK
+		       && specific->id != GFC_ISYM_SHAPE
+		       && specific->id != GFC_ISYM_SIZE
+		       && specific->id != GFC_ISYM_UBOUND
+		       && specific->id != GFC_ISYM_C_LOC)))
+	{
+	  if (a != arg)
+	    gfc_error ("Assumed-type argument at %L is only permitted as "
+		       "first actual argument to the intrinsic %s",
+		       &a->expr->where, gfc_current_intrinsic);
+	  else
+	    gfc_error ("Assumed-type argument at %L is not permitted as actual"
+		       " argument to the intrinsic %s", &a->expr->where,
+		       gfc_current_intrinsic);
+	  return false;
+	}
+      if (a->expr->rank == -1 && !specific->inquiry)
+	{
+	  gfc_error ("Assumed-rank argument at %L is only permitted as actual "
+		     "argument to intrinsic inquiry functions",
+		     &a->expr->where);
+	  return false;
+	}
+      if (a->expr->rank == -1 && arg != a)
+	{
+	  gfc_error ("Assumed-rank argument at %L is only permitted as first "
+		     "actual argument to the intrinsic inquiry function %s",
+		     &a->expr->where, gfc_current_intrinsic);
+	  return false;
+	}
+    }
+
   a1 = arg->expr;
   arg = arg->next;
   if (arg == NULL)
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_1.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_1.f90
index 44e278c..afddc83 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_1.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_1.f90
@@ -52,11 +52,11 @@  contains
   subroutine bar(a,b, prsnt)
     integer, pointer, optional, intent(in) :: a(..),b(..)
     logical, value :: prsnt
-    ! The following is not valid, but it goes past the constraint check
-    ! Technically, it could be allowed and might be in Fortran 2015:
     if (.not. associated(a)) call abort()
     if (present(b)) then
-      if (.not. associated(a,b)) call abort()
+       ! The following is not valid.
+       ! Technically, it could be allowed and might be in Fortran 2015:
+       ! if (.not. associated(a,b)) call abort()
     else
       if (.not. associated(a)) call abort()
     end if
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_2.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_2.f90
index 344278e..8a1ea05 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_2.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_2.f90
@@ -45,11 +45,11 @@  contains
   subroutine bar(a,b, prsnt)
     integer, pointer, optional, intent(in) :: a(..),b(..)
     logical, value :: prsnt
-    ! The following is not valid, but it goes past the constraint check
-    ! Technically, it could be allowed and might be in Fortran 2015:
     if (.not. associated(a)) call abort()
     if (present(b)) then
-      if (.not. associated(a,b)) call abort()
+      ! The following is not valid
+      ! Technically, it could be allowed and might be in Fortran 2015:
+      ! if (.not. associated(a,b)) call abort()
     else
       if (.not. associated(a)) call abort()
     end if
diff --git a/gcc/testsuite/gfortran.dg/assumed_type_3.f90 b/gcc/testsuite/gfortran.dg/assumed_type_3.f90
index 8d2be25..e5bff50 100644
--- a/gcc/testsuite/gfortran.dg/assumed_type_3.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_type_3.f90
@@ -110,7 +110,7 @@  end subroutine twelf
 subroutine thirteen(x, y)
   type(*) :: x
   integer :: y(:)
-  print *, ubound(y, dim=x) ! { dg-error "must be INTEGER" }
+  print *, ubound(y, dim=x) ! { dg-error "Assumed-type argument at .1. is only permitted as first actual argument to the intrinsic ubound" }
 end subroutine thirteen
 
 subroutine fourteen(x)
diff --git a/gcc/testsuite/gfortran.dg/no_arg_check_3.f90 b/gcc/testsuite/gfortran.dg/no_arg_check_3.f90
index c3a8089..ff176fe 100644
--- a/gcc/testsuite/gfortran.dg/no_arg_check_3.f90
+++ b/gcc/testsuite/gfortran.dg/no_arg_check_3.f90
@@ -114,7 +114,7 @@  subroutine thirteen(x, y)
 !GCC$ attributes NO_ARG_CHECK :: x
   integer :: x
   integer :: y(:)
-  print *, ubound(y, dim=x) ! { dg-error "must be INTEGER" }
+  print *, ubound(y, dim=x) ! { dg-error "Variable with NO_ARG_CHECK attribute at .1. is only permitted as argument to the intrinsic functions C_LOC and PRESENT" }
 end subroutine thirteen
 
 subroutine fourteen(x)
diff --git a/gcc/testsuite/gfortran.dg/sizeof_2.f90 b/gcc/testsuite/gfortran.dg/sizeof_2.f90
index 5f2169b..5f19288 100644
--- a/gcc/testsuite/gfortran.dg/sizeof_2.f90
+++ b/gcc/testsuite/gfortran.dg/sizeof_2.f90
@@ -10,9 +10,9 @@  subroutine foo(x, y)
   integer(8) :: ii
   procedure() :: proc
 
-  ii = sizeof (x) ! { dg-error "shall not be TYPE\(.\)" }
-  ii = c_sizeof (x) ! { dg-error "shall not be TYPE\(.\)" }
-  ii = storage_size (x) ! { dg-error "shall not be TYPE\(.\)" }
+  ii = sizeof (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic sizeof" }
+  ii = c_sizeof (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic c_sizeof" }
+  ii = storage_size (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic storage_size" }
 
   ii = sizeof (y) ! { dg-error "shall not be an assumed-size array" }
   ii = c_sizeof (y) ! { dg-error "shall not be an assumed-size array" }
--- /dev/null	2013-04-23 08:42:13.376111435 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_type_5.f90	2013-04-23 09:23:21.988533409 +0200
@@ -0,0 +1,36 @@ 
+! { dg-do compile }
+!
+! PR fortran/57035
+!
+!
+
+subroutine assumed_rank (a)
+  use iso_c_binding
+  integer, intent(in), target :: a(..)
+  integer :: c(1:4)
+  type(c_ptr) :: xx
+  c = ubound(c,a) ! { dg-error "Assumed-rank argument at .1. is only permitted as first actual argument to the intrinsic inquiry function ubound" }
+  c = transfer(a,1) ! { dg-error "Assumed-rank argument at .1. is only permitted as actual argument to intrinsic inquiry functions" }
+  xx = c_loc(a)
+end subroutine
+
+subroutine assumed_type (a)
+  use iso_c_binding
+  type(*), intent(in), target :: a
+  integer :: c(1:4)
+  type(c_ptr) :: xx
+  c = ubound(c,a) ! { dg-error "Assumed-type argument at .1. is only permitted as first actual argument to the intrinsic ubound" }
+  c = transfer(a,1) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic transfer" }
+  xx = c_loc(a)
+end subroutine
+
+subroutine no_arg_check (a)
+  use iso_c_binding
+  integer, intent(in), target :: a
+  !gcc$ attributes no_arg_check :: a
+  integer :: c(1:4)
+  type(c_ptr) :: xx
+  c = ubound(c,a) ! { dg-error "Variable with NO_ARG_CHECK attribute at .1. is only permitted as argument to the intrinsic functions C_LOC and PRESENT" }
+  c = transfer(a,1) ! { dg-error "Variable with NO_ARG_CHECK attribute at .1. is only permitted as argument to the intrinsic functions C_LOC and PRESENT" }
+  xx = c_loc(a)
+end subroutine