re PR fortran/50815 (ICE on allocation of deferred length character scalar dummy…

re PR fortran/50815 (ICE on allocation of deferred length character scalar dummy argument when -fbounds-check)

2011-12-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/50815
        * trans-decl.c (add_argument_checking): Skip bound checking
        for deferred-length strings.

2011-12-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/50815
        * gfortran.dg/bounds_check_16.f90: New.

From-SVN: r182134

gcc/fortran/ChangeLog

 2011-12-08  Tobias Burnus  <burnus@net-b.de>
 
+	PR fortran/50815
+	* trans-decl.c (add_argument_checking): Skip bound checking
+	for deferred-length strings.
+
+2011-12-08  Tobias Burnus  <burnus@net-b.de>
+
 	PR fortran/51378
 	* symbol.c (gfc_find_component): Fix access check of parent
 	components.

gcc/fortran/trans-decl.c

@@ -4695,8 +4695,10 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
 	   if the actual argument is (part of) an array, but only if the
 	   dummy argument is an array. (See "Sequence association" in
 	   Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.)  */
-	if (fsym->attr.pointer || fsym->attr.allocatable
-	    || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
+	if (fsym->ts.deferred)
+	  continue;
+	else if (fsym->attr.pointer || fsym->attr.allocatable
+		 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
 	  {
 	    comparison = NE_EXPR;
 	    message = _("Actual string length does not match the declared one"

gcc/testsuite/ChangeLog

 2011-12-08  Tobias Burnus  <burnus@net-b.de>
 
+	PR fortran/50815
+	* gfortran.dg/bounds_check_16.f90: New.
+
+2011-12-08  Tobias Burnus  <burnus@net-b.de>
+
 	PR fortran/51378
 	* gfortran.dg/private_type_14.f90: New.
 

gcc/testsuite/gfortran.dg/bounds_check_16.f90

+! { dg-do compile }
+! { dg-options "-fcheck=bounds" }
+!
+! PR fortran/50815
+!
+! Don't check the bounds of deferred-length strings.
+! gfortran had an ICE before because it did.
+!
+SUBROUTINE TEST(VALUE)
+    IMPLICIT NONE
+    CHARACTER(LEN=:),    ALLOCATABLE    ::    VALUE
+    CHARACTER(LEN=128)    ::    VAL
+    VALUE = VAL
+END SUBROUTINE TEST

libgfortran/io/transfer.c

@@ -1063,6 +1063,25 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
 }
 
 
+static int
+require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f)
+{
+#define BUFLEN 100
+  char buffer[BUFLEN];
+
+  if (actual == BT_INTEGER || actual == BT_REAL || actual == BT_COMPLEX)
+    return 0;
+
+  /* Adjust item_count before emitting error message.  */
+  snprintf (buffer, BUFLEN, 
+	    "Expected numeric type for item %d in formatted transfer, got %s",
+	    dtp->u.p.item_count - 1, type_name (actual));
+
+  format_error (dtp, f, buffer);
+  return 1;
+}
+
+
 /* This function is in the main loop for a formatted data transfer
    statement.  It would be natural to implement this as a coroutine
    with the user program, but C makes that awkward.  We loop,
@@ -1147,6 +1166,9 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
 	  if (n == 0)
 	    goto need_read_data;
 	  if (!(compile_options.allow_std & GFC_STD_GNU)
+	      && require_numeric_type (dtp, type, f))
+	    return;
+	  if (!(compile_options.allow_std & GFC_STD_F2008)
               && require_type (dtp, BT_INTEGER, type, f))
 	    return;
 	  read_radix (dtp, f, p, kind, 2);
@@ -1156,6 +1178,9 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
 	  if (n == 0)
 	    goto need_read_data; 
 	  if (!(compile_options.allow_std & GFC_STD_GNU)
+	      && require_numeric_type (dtp, type, f))
+	    return;
+	  if (!(compile_options.allow_std & GFC_STD_F2008)
               && require_type (dtp, BT_INTEGER, type, f))
 	    return;
 	  read_radix (dtp, f, p, kind, 8);
@@ -1165,6 +1190,9 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
 	  if (n == 0)
 	    goto need_read_data;
 	  if (!(compile_options.allow_std & GFC_STD_GNU)
+	      && require_numeric_type (dtp, type, f))
+	    return;
+	  if (!(compile_options.allow_std & GFC_STD_F2008)
               && require_type (dtp, BT_INTEGER, type, f))
 	    return;
 	  read_radix (dtp, f, p, kind, 16);
@@ -1548,6 +1576,9 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	  if (n == 0)
 	    goto need_data;
 	  if (!(compile_options.allow_std & GFC_STD_GNU)
+	      && require_numeric_type (dtp, type, f))
+	    return;
+	  if (!(compile_options.allow_std & GFC_STD_F2008)
               && require_type (dtp, BT_INTEGER, type, f))
 	    return;
 	  write_b (dtp, f, p, kind);
@@ -1557,6 +1588,9 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	  if (n == 0)
 	    goto need_data; 
 	  if (!(compile_options.allow_std & GFC_STD_GNU)
+	      && require_numeric_type (dtp, type, f))
+	    return;
+	  if (!(compile_options.allow_std & GFC_STD_F2008)
               && require_type (dtp, BT_INTEGER, type, f))
 	    return;
 	  write_o (dtp, f, p, kind);
@@ -1566,6 +1600,9 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	  if (n == 0)
 	    goto need_data;
 	  if (!(compile_options.allow_std & GFC_STD_GNU)
+	      && require_numeric_type (dtp, type, f))
+	    return;
+	  if (!(compile_options.allow_std & GFC_STD_F2008)
               && require_type (dtp, BT_INTEGER, type, f))
 	    return;
 	  write_z (dtp, f, p, kind);