The attached patch fixed the issues raised in the
PR fortran/42546. Namely, ALLOCATED has two possible
keywords: ALLOCATE(ARRAY=...) or ALLOCATED(SCALAR=...)
In Tobias' original patch (attached to the PR), he
tried to make both ARRAY and SCALAR options, then
in gfc_check_allocated() appropriate checking was
added. I started down that road, but intrinsic.c(
sort_actual) got in the way. Fortunately, the
checking for ARRAY or SCALAR can be special-cased
in sort_actual. See the patch.
Regression tested on x86_64-*-freebsd. OK to commit?
2019-08-01 Steven G. Kargl <ka...@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 <ka...@gcc.gnu.org>
PR fortran/42546
* gfortran.dg/allocated_1.f90: New test.
* gfortran.dg/allocated_2.f90: Ditto.
--
Steve
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c (revision 273950)
+++ gcc/fortran/check.c (working copy)
@@ -1168,6 +1168,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)
{
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c (revision 273950)
+++ gcc/fortran/intrinsic.c (working copy)
@@ -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;
Index: gcc/testsuite/gfortran.dg/allocated_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocated_1.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/allocated_1.f90 (working copy)
@@ -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
Index: gcc/testsuite/gfortran.dg/allocated_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocated_2.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/allocated_2.f90 (working copy)
@@ -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
