This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[PATCH] PR fortran/82934,83318 -- Enforce F2008:C631


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  <kargl@gcc.gnu.org>

	PR fortran/82934
	PR fortran/83318
	* match.c (gfc_match_allocate): Enforce F2008:C631.

2017-12-08  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/82934
	PR fortran/83318
	* gfortran.dg/allocate_assumed_charlen_2.f90: new test.

-- 
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,16 +4010,11 @@ gfc_match_allocate (void)
 	    }
 
 	  if (ts.type == BT_CHARACTER)
-	    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)
 	    {
-	      gfc_error ("The type parameter spec list in the type-spec at "
-			 "%L cannot contain ASSUMED or DEFERRED parameters",
-			 &old_locus);
-	      goto cleanup;
+	      if (!ts.u.cl->length)
+		saw_assumed = true;
+	      else
+		ts.u.cl->length_from_typespec = true;
 	    }
 	}
       else
@@ -4054,6 +4052,17 @@ 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))
+	{
+	  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

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]