Commit 32157107 by Tobias Burnus Committed by Tobias Burnus

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
parent 3787b8ff
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 PR fortran/51378
* symbol.c (gfc_find_component): Fix access check of parent * symbol.c (gfc_find_component): Fix access check of parent
components. components.
......
...@@ -4695,8 +4695,10 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym) ...@@ -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 if the actual argument is (part of) an array, but only if the
dummy argument is an array. (See "Sequence association" in dummy argument is an array. (See "Sequence association" in
Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */ Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
if (fsym->attr.pointer || fsym->attr.allocatable if (fsym->ts.deferred)
|| (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE)) continue;
else if (fsym->attr.pointer || fsym->attr.allocatable
|| (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
{ {
comparison = NE_EXPR; comparison = NE_EXPR;
message = _("Actual string length does not match the declared one" message = _("Actual string length does not match the declared one"
......
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 PR fortran/51378
* gfortran.dg/private_type_14.f90: New. * gfortran.dg/private_type_14.f90: New.
......
! { 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
...@@ -1063,6 +1063,25 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f) ...@@ -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 /* This function is in the main loop for a formatted data transfer
statement. It would be natural to implement this as a coroutine statement. It would be natural to implement this as a coroutine
with the user program, but C makes that awkward. We loop, 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 ...@@ -1147,6 +1166,9 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
if (n == 0) if (n == 0)
goto need_read_data; goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU) 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)) && require_type (dtp, BT_INTEGER, type, f))
return; return;
read_radix (dtp, f, p, kind, 2); 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 ...@@ -1156,6 +1178,9 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
if (n == 0) if (n == 0)
goto need_read_data; goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU) 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)) && require_type (dtp, BT_INTEGER, type, f))
return; return;
read_radix (dtp, f, p, kind, 8); 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 ...@@ -1165,6 +1190,9 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
if (n == 0) if (n == 0)
goto need_read_data; goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU) 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)) && require_type (dtp, BT_INTEGER, type, f))
return; return;
read_radix (dtp, f, p, kind, 16); 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 ...@@ -1548,6 +1576,9 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
if (n == 0) if (n == 0)
goto need_data; goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU) 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)) && require_type (dtp, BT_INTEGER, type, f))
return; return;
write_b (dtp, f, p, kind); write_b (dtp, f, p, kind);
...@@ -1557,6 +1588,9 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin ...@@ -1557,6 +1588,9 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
if (n == 0) if (n == 0)
goto need_data; goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU) 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)) && require_type (dtp, BT_INTEGER, type, f))
return; return;
write_o (dtp, f, p, kind); write_o (dtp, f, p, kind);
...@@ -1566,6 +1600,9 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin ...@@ -1566,6 +1600,9 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
if (n == 0) if (n == 0)
goto need_data; goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU) 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)) && require_type (dtp, BT_INTEGER, type, f))
return; return;
write_z (dtp, f, p, kind); write_z (dtp, f, p, kind);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment