On Fri, Dec 08, 2017 at 05:13:28PM -0800, Steve Kargl wrote:
> The attached patch enforces F2008:C631, which of course is
>
> /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
> asterisk if and only if each allocate-object is a dummy argument
> for which the corresponding type parameter is assumed. */
>
> Regression tested on x86_64-*-freebsd.
>
> 2017-12-08 Steven G. Kargl <ka...@gcc.gnu.org>
>
> PR fortran/82934
> PR fortran/83318
> * match.c (gfc_match_allocate): Enforce F2008:C631.
>
> 2017-12-08 Steven G. Kargl <ka...@gcc.gnu.org>
>
> PR fortran/82934
> PR fortran/83318
> * gfortran.dg/allocate_assumed_charlen_2.f90: new test.
>
The final version of the patch that I committed is attached.
--
Steve
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 255517)
+++ gcc/fortran/match.c (working copy)
@@ -3960,9 +3960,9 @@ gfc_match_allocate (void)
gfc_typespec ts;
gfc_symbol *sym;
match m;
- locus old_locus, deferred_locus;
+ locus old_locus, deferred_locus, assumed_locus;
bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
- bool saw_unlimited = false;
+ bool saw_unlimited = false, saw_assumed = false;
head = tail = NULL;
stat = errmsg = source = mold = tmp = NULL;
@@ -3993,6 +3993,9 @@ gfc_match_allocate (void)
}
else
{
+ /* Needed for the F2008:C631 check below. */
+ assumed_locus = gfc_current_locus;
+
if (gfc_match (" :: ") == MATCH_YES)
{
if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
@@ -4007,15 +4010,19 @@ gfc_match_allocate (void)
}
if (ts.type == BT_CHARACTER)
- ts.u.cl->length_from_typespec = true;
+ {
+ if (!ts.u.cl->length)
+ saw_assumed = true;
+ else
+ ts.u.cl->length_from_typespec = true;
+ }
- /* TODO understand why this error does not appear but, instead,
- the derived type is caught as a variable in primary.c. */
- if (gfc_spec_list_type (type_param_spec_list, NULL) != SPEC_EXPLICIT)
+ if (type_param_spec_list
+ && gfc_spec_list_type (type_param_spec_list, NULL)
+ == SPEC_DEFERRED)
{
gfc_error ("The type parameter spec list in the type-spec at "
- "%L cannot contain ASSUMED or DEFERRED parameters",
- &old_locus);
+ "%L cannot contain DEFERRED parameters", &old_locus);
goto cleanup;
}
}
@@ -4054,6 +4061,19 @@ gfc_match_allocate (void)
if (impure)
gfc_unset_implicit_pure (NULL);
+
+ /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
+ asterisk if and only if each allocate-object is a dummy argument
+ for which the corresponding type parameter is assumed. */
+ if (saw_assumed
+ && (tail->expr->ts.deferred
+ || tail->expr->ts.u.cl->length
+ || tail->expr->symtree->n.sym->attr.dummy == 0))
+ {
+ gfc_error ("Incompatible allocate-object at %C for CHARACTER "
+ "type-spec at %L", &assumed_locus);
+ goto cleanup;
+ }
if (tail->expr->ts.deferred)
{
Index: gcc/testsuite/gfortran.dg/allocate_assumed_charlen_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_assumed_charlen_2.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/allocate_assumed_charlen_2.f90 (working copy)
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! PR fortran/82934
+! PR fortran/83318
+program a
+ character(len=42), allocatable :: f
+ character(len=22), allocatable :: ff
+ call alloc(f, ff)
+ if (len(f) .ne. 42) call abort
+ if (len(ff) .ne. 22) call abort
+contains
+ subroutine alloc( a, b )
+ character(len=*), allocatable :: a
+ character(len=22), allocatable :: b
+ character(len=:), allocatable :: c
+ character, allocatable :: d
+ allocate(character(len=*)::a,b) ! { dg-error "Incompatible allocate-object" }
+ allocate(character(len=*)::c) ! { dg-error "Incompatible allocate-object" }
+ allocate(character(len=*)::d) ! { dg-error "Incompatible allocate-object" }
+ end subroutine
+end program a
