Re: [PATCH] PR fortran/67805 -- Check for invalid charlength

[Steve Kargl <sgk at troutmask dot apl dot washington dot edu>]

On Fri, Oct 23, 2015 at 12:28:14PM -0700, Steve Kargl wrote:
> Built and regression tested on x86_64-*-freebsd.
> OK to commit?
> 

Now with the patch attached!

-- 
Steve

Index: gcc/fortran/array.c
===================================================================
--- gcc/fortran/array.c	(revision 229265)
+++ gcc/fortran/array.c	(working copy)
@@ -1080,7 +1080,8 @@ gfc_match_array_constructor (gfc_expr **
   /* Try to match an optional "type-spec ::"  */
   gfc_clear_ts (&ts);
   gfc_new_undo_checkpoint (changed_syms);
-  if (gfc_match_type_spec (&ts) == MATCH_YES)
+  m = gfc_match_type_spec (&ts);
+  if (m == MATCH_YES)
     {
       seen_ts = (gfc_match (" ::") == MATCH_YES);
 
@@ -1102,6 +1103,11 @@ gfc_match_array_constructor (gfc_expr **
 	    }
 	}
     }
+  else if (m == MATCH_ERROR)
+    {
+      gfc_restore_last_undo_checkpoint ();
+      goto cleanup;
+    }
 
   if (seen_ts)
     gfc_drop_last_undo_checkpoint ();
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 229265)
+++ gcc/fortran/decl.c	(working copy)
@@ -715,36 +715,59 @@ char_len_param_value (gfc_expr **expr, b
 
   if ((*expr)->expr_type == EXPR_FUNCTION)
     {
-      if ((*expr)->value.function.actual
-	  && (*expr)->value.function.actual->expr->symtree)
+      if ((*expr)->ts.type == BT_INTEGER
+	  || ((*expr)->ts.type == BT_UNKNOWN
+	      && strcmp((*expr)->symtree->name, "null") != 0))
+	return MATCH_YES;
+
+      goto syntax;
+    }
+  else if ((*expr)->expr_type == EXPR_CONSTANT)
+    {
+      /* F2008, 4.4.3.1:  The length is a type parameter; its kind is
+	 processor dependent and its value is greater than or equal to zero.
+	 F2008, 4.4.3.2:  If the character length parameter value evaluates
+	 to a negative value, the length of character entities declared
+	 is zero.  */
+
+      if ((*expr)->ts.type == BT_INTEGER)
 	{
-	  gfc_expr *e;
-	  e = (*expr)->value.function.actual->expr;
-	  if (e->symtree->n.sym->attr.flavor == FL_PROCEDURE
-	      && e->expr_type == EXPR_VARIABLE)
-	    {
-	      if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
-		goto syntax;
-	      if (e->symtree->n.sym->ts.type == BT_CHARACTER
-		  && e->symtree->n.sym->ts.u.cl
-		  && e->symtree->n.sym->ts.u.cl->length->ts.type == BT_UNKNOWN)
-	        goto syntax;
-	    }
+	  if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
+	    mpz_set_si ((*expr)->value.integer, 0);
 	}
+      else
+	goto syntax;
     }
+  else if ((*expr)->expr_type == EXPR_ARRAY)
+    goto syntax;
+  else if ((*expr)->expr_type == EXPR_VARIABLE)
+    {
+      gfc_expr *e;
+
+      e = gfc_copy_expr (*expr);
+
+      /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
+	 which causes an ICE if gfc_reduce_init_expr() is called.  */
+      if (e->ref && e->ref->u.ar.type == AR_UNKNOWN
+	  && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
+	goto syntax;
+
+      gfc_reduce_init_expr (e);
+
+      if ((e->ref && e->ref->u.ar.type != AR_ELEMENT) 
+	  || (!e->ref && e->expr_type == EXPR_ARRAY))
+	{
+	  gfc_free_expr (e);
+	  goto syntax;
+	}
 
-  /* F2008, 4.4.3.1:  The length is a type parameter; its kind is processor
-     dependent and its value is greater than or equal to zero.
-     F2008, 4.4.3.2:  If the character length parameter value evaluates to
-     a negative value, the length of character entities declared is zero.  */
-  if ((*expr)->expr_type == EXPR_CONSTANT
-      && mpz_cmp_si ((*expr)->value.integer, 0) < 0)
-    mpz_set_si ((*expr)->value.integer, 0);
+      gfc_free_expr (e);
+    }
 
   return m;
 
 syntax:
-  gfc_error ("Conflict in attributes of function argument at %C");
+  gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
   return MATCH_ERROR;
 }
 
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 229265)
+++ gcc/fortran/match.c	(working copy)
@@ -1939,6 +1939,11 @@ kind_selector:
   if (m == MATCH_NO)
     m = MATCH_YES;		/* No kind specifier found.  */
 
+  /* gfortran may have matched REAL(a=1), which is the keyword form of the
+     intrinsic procedure.  */
+  if (ts->type == BT_REAL && m == MATCH_ERROR)
+    m = MATCH_NO;
+
   return m;
 }
 
Index: gcc/testsuite/gfortran.dg/array_constructor_26.f03
===================================================================
--- gcc/testsuite/gfortran.dg/array_constructor_26.f03	(revision 229265)
+++ gcc/testsuite/gfortran.dg/array_constructor_26.f03	(working copy)
@@ -11,7 +11,6 @@ MODULE WinData
   integer :: i
   TYPE TWindowData
     CHARACTER (MAX_FLD_HED, 1) :: DWFdHd(MAXFLD) = [(" ", i = 1, MAXFLD)]
-    ! { dg-error "no IMPLICIT type" "" { target *-*-* } 13 }
     ! { dg-error "specification expression" "" { target *-*-* } 13 }
   END TYPE TWindowData
 END MODULE WinData
Index: gcc/testsuite/gfortran.dg/array_constructor_27.f03
===================================================================
--- gcc/testsuite/gfortran.dg/array_constructor_27.f03	(revision 229265)
+++ gcc/testsuite/gfortran.dg/array_constructor_27.f03	(working copy)
@@ -9,7 +9,6 @@ implicit none
 
 type t
   character (a) :: arr (1) = [ "a" ]
-  ! { dg-error "no IMPLICIT type" "" { target *-*-* } 11 }
   ! { dg-error "specification expression" "" { target *-*-* } 11 }
 end type t
 
Index: gcc/testsuite/gfortran.dg/char_type_len_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/char_type_len_2.f90	(revision 229265)
+++ gcc/testsuite/gfortran.dg/char_type_len_2.f90	(working copy)
@@ -1,8 +1,11 @@
 ! { dg-do compile }
 ! PR31251 Non-integer character length leads to segfault
 ! Submitted by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
-  character(len=2.3) :: s ! { dg-error "must be of INTEGER type" }
-  character(kind=1,len=4.3) :: t ! { dg-error "must be of INTEGER type" }
+!
+! Updated to deal with the fix for PR fortran/67805.
+!
+  character(len=2.3) :: s ! { dg-error "INTEGER expression expected" }
+  character(kind=1,len=4.3) :: t ! { dg-error "INTEGER expression expected" }
   character(len=,,7.2,kind=1) :: u ! { dg-error "Syntax error in CHARACTER declaration" }
   character(len=7,kind=2) :: v ! ! { dg-error "Kind 2 is not supported for CHARACTER" }
   character(kind=2) :: w ! ! { dg-error "Kind 2 is not supported for CHARACTER" }
Index: gcc/testsuite/gfortran.dg/pr67802.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr67802.f90	(revision 229265)
+++ gcc/testsuite/gfortran.dg/pr67802.f90	(working copy)
@@ -2,8 +2,8 @@
 ! PR fortran/67802
 ! Original code contribute by gerhard.steinmetz.fortran at t-online.de
 program p
-   character(1.) :: c1 = ' '      ! { dg-error "must be of INTEGER" }
-   character(1d1) :: c2 = ' '     ! { dg-error "must be of INTEGER" }
-   character((0.,1.)) :: c3 = ' ' ! { dg-error "must be of INTEGER" }
-   character(.true.) :: c4 = ' '  ! { dg-error "must be of INTEGER" }
+   character(1.) :: c1 = ' '      ! { dg-error "INTEGER expression expected" }
+   character(1d1) :: c2 = ' '     ! { dg-error "INTEGER expression expected" }
+   character((0.,1.)) :: c3 = ' ' ! { dg-error "INTEGER expression expected" }
+   character(.true.) :: c4 = ' '  ! { dg-error "INTEGER expression expected" }
 end program p
Index: gcc/testsuite/gfortran.dg/pr67805.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr67805.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/pr67805.f90	(working copy)
@@ -0,0 +1,37 @@
+! { dg-do compile }
+! PR fortran/67805
+! Original code contributed by Gerhard Steinmetz
+! gerhard dot steinmetz dot fortran at t-online dot de
+!
+subroutine p
+   integer, parameter :: n = 1
+   integer, parameter :: m(3) = [1, 2, 3]
+   character(len=1) s(2)
+   s = [character((m(1))) :: 'x', 'y']    ! OK.
+   s = [character(m(1)) :: 'x', 'y']      ! OK.
+   s = [character(m) :: 'x', 'y']         ! { dg-error "INTEGER expression expected" }
+   
+   ! The next line should case an error, but causes an ICE. 
+   s = [character(m(2:3)) :: 'x', 'y']    ! { dg-error "INTEGER expression expected" }
+   
+   call foo(s)
+   s = [character('') :: 'x', 'y']        ! { dg-error "INTEGER expression expected" }
+   s = [character(['']) :: 'x', 'y']      ! { dg-error "INTEGER expression expected" }
+   s = [character([.true.]) :: 'x', 'y']  ! { dg-error "INTEGER expression expected" }
+   s = [character([.false.]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" }
+   s = [character([1.]) :: 'x', 'y']      ! { dg-error "INTEGER expression expected" }
+   s = [character([1d1]) :: 'x', 'y']     ! { dg-error "INTEGER expression expected" }
+   s = [character([(0.,1.)]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" }
+   s = [character([null()]) :: 'x', 'y']  ! { dg-error "INTEGER expression expected" }
+   s =  [character(null()) :: 'x', 'y']   ! { dg-error "INTEGER expression expected" }
+   call foo(s)
+end subroutine p
+
+subroutine q
+   print *, '1: ', [character(.true.) :: 'x', 'y']  ! { dg-error "INTEGER expression expected" }
+   print *, '2: ', [character(.false.) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" }
+   print *, '3: ', [character(1.) :: 'x', 'y']      ! { dg-error "INTEGER expression expected" }
+   print *, '4: ', [character(1d1) :: 'x', 'y']     ! { dg-error "INTEGER expression expected" }
+   print *, '5: ', [character((0.,1.)) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" }
+   print *, '6: ', [character(null()) :: 'x', 'y']  ! { dg-error "INTEGER expression expected" }.
+end subroutine q
Index: gcc/testsuite/gfortran.dg/used_before_typed_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/used_before_typed_3.f90	(revision 229265)
+++ gcc/testsuite/gfortran.dg/used_before_typed_3.f90	(working copy)
@@ -17,14 +17,14 @@ CONTAINS
     test1 = "foobar"
   END FUNCTION test1
 
-  CHARACTER(len=x) FUNCTION test2 (x) ! { dg-bogus "used before|of INTEGER" }
+  CHARACTER(len=x) FUNCTION test2 (x) ! { dg-error "of INTEGER" }
     IMPLICIT INTEGER(a-z)
     test2 = "foobar"
   END FUNCTION test2
 
 END MODULE testmod
   
-CHARACTER(len=i) FUNCTION test3 (i) ! { dg-bogus "used before|of INTEGER" }
+CHARACTER(len=i) FUNCTION test3 (i)
   ! i is IMPLICIT INTEGER by default
   test3 = "foobar"
 END FUNCTION test3