re PR fortran/42546 (ALLOCATED statement typo in the docs and for scalar variables)

2019-08-01  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/42546
	* check.c(gfc_check_allocated): Add comment pointing to ...
	* intrinsic.c(sort_actual): ... the checking done here.

2019-08-01  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/42546
	* gfortran.dg/allocated_1.f90: New test.
	* gfortran.dg/allocated_2.f90: Ditto.

From-SVN: r274147

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9835cbb6bc41aa1571c481b102ee95bd9a5e2af3..b88437aa96d0980c3efc040f55b663d800581c81 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2019-08-06  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+       PR fortran/42546
+       * check.c(gfc_check_allocated): Add comment pointing to ...
+       * intrinsic.c(sort_actual): ... the checking done here.
+ 
 2019-08-05  Steven g. Kargl  <kargl@gcc.gnu.org>
 
        PR fortran/91372

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 0204961a4d7b5c9e9ea8166cab36ccaf45e44c7c..370a3c819f9bf38201daa3ff08b9dc8425567fa6 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1340,6 +1340,10 @@ gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
 }
 
 
+/* Limited checking for ALLOCATED intrinsic.  Additional checking
+   is performed in intrinsic.c(sort_actual), because ALLOCATED
+   has two mutually exclusive non-optional arguments.  */
+
 bool
 gfc_check_allocated (gfc_expr *array)
 {

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index c21fbddd5fb4216a302ba8429b7020223a113cc0..d0f7c10a4380a9dbc6729a7806713c3447d6f52b 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -4180,6 +4180,40 @@ sort_actual (const char *name, gfc_actual_arglist **ap,
   if (f == NULL && a == NULL)  /* No arguments */
     return true;
 
+  /* ALLOCATED has two mutually exclusive keywords, but only one
+     can be present at time and neither is optional. */
+  if (strcmp (name, "allocated") == 0 && a->name)
+    {
+      if (strcmp (a->name, "scalar") == 0)
+       {
+          if (a->next)
+           goto whoops;
+         if (a->expr->rank != 0)
+           {
+             gfc_error ("Scalar entity required at %L", &a->expr->where);
+             return false;
+           }
+          return true;
+       }
+      else if (strcmp (a->name, "array") == 0)
+       {
+          if (a->next)
+           goto whoops;
+         if (a->expr->rank == 0)
+           {
+             gfc_error ("Array entity required at %L", &a->expr->where);
+             return false;
+           }
+          return true;
+       }
+      else
+       {
+         gfc_error ("Invalid keyword %qs in %qs intrinsic function at %L",
+                    a->name, name, &a->expr->where);
+         return false;
+       }
+    }
+
   for (;;)
     {          /* Put the nonkeyword arguments in a 1:1 correspondence */
       if (f == NULL)
@@ -4199,6 +4233,7 @@ sort_actual (const char *name, gfc_actual_arglist **ap,
   if (a == NULL)
     goto do_sort;
 
+whoops:
   gfc_error ("Too many arguments in call to %qs at %L", name, where);
   return false;
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4b40a316f669f737cfe8452501319deab963ed24..af5349ab252d15141aff820cec341ec308236c5b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2019-08-06  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+       PR fortran/42546
+       * gfortran.dg/allocated_1.f90: New test.
+       * gfortran.dg/allocated_2.f90: Ditto.
+
 2019-08-06  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
 
        * gcc.target/i386/avx512vp2intersect-2intersect-1b.c (AVX512F):

diff --git a/gcc/testsuite/gfortran.dg/allocated_1.f90 b/gcc/testsuite/gfortran.dg/allocated_1.f90
new file mode 100644 (file)
index 0000000..43260c2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocated_1.f90
@@ -0,0 +1,24 @@
+! { dg-do run }
+program foo
+
+   implicit none
+
+   integer, allocatable :: x
+   integer, allocatable :: a(:)
+
+   logical a1, a2
+
+   a1 = allocated(scalar=x)
+   if (a1 .neqv. .false.) stop 1
+   a2 = allocated(array=a)
+   if (a2 .neqv. .false.) stop 2
+
+   allocate(x)
+   allocate(a(2))
+
+   a1 = allocated(scalar=x)
+   if (a1 .neqv. .true.) stop 3
+   a2 = allocated(array=a)
+   if (a2 .neqv. .true.) stop 4
+
+end program foo

diff --git a/gcc/testsuite/gfortran.dg/allocated_2.f90 b/gcc/testsuite/gfortran.dg/allocated_2.f90
new file mode 100644 (file)
index 0000000..0ea186a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocated_2.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+program foo
+
+   implicit none
+
+   integer, allocatable :: x
+   integer, allocatable :: a(:)
+
+   logical a1, a2
+
+   a1 = allocated(scalar=a)   ! { dg-error "Scalar entity required" }
+   a2 = allocated(array=x)    ! { dg-error "Array entity required" }
+   a1 = allocated(scalar=x, array=a)   ! { dg-error "Too many arguments" }
+   a1 = allocated(array=a, scalar=x)   ! { dg-error "Too many arguments" }
+
+end program foo