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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@182134 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 986ee2d..abaa344 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,11 @@
 2011-12-08  Tobias Burnus  <burnus@net-b.de>
 
 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.
        PR fortran/51378
        * symbol.c (gfc_find_component): Fix access check of parent
        components.

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 67bd3e2..50b6474 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/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 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"
          {
            comparison = NE_EXPR;
            message = _("Actual string length does not match the declared one"

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 452fddd..30f1609 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 2011-12-08  Tobias Burnus  <burnus@net-b.de>
 
 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.
 
        PR fortran/51378
        * gfortran.dg/private_type_14.f90: New.
 

diff --git a/gcc/testsuite/gfortran.dg/bounds_check_16.f90 b/gcc/testsuite/gfortran.dg/bounds_check_16.f90
new file mode 100644 (file)
index 0000000..38a8630
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bounds_check_16.f90
@@ -0,0 +1,14 @@
+! { 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

diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 976102f..f71e96f 100644 (file)
--- a/libgfortran/io/transfer.c
+++ b/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,
 /* 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)
          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);
               && 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)
          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);
               && 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)
          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);
               && 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)
          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);
               && 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)
          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);
               && 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)
          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);
               && require_type (dtp, BT_INTEGER, type, f))
            return;
          write_z (dtp, f, p, kind);