From 80b8720617d9cd0cf9dcc01a61314ab5d8952c08 Mon Sep 17 00:00:00 2001 From: burnus Date: Thu, 8 Dec 2011 19:00:55 +0000 Subject: [PATCH] 2011-12-08 Tobias Burnus PR fortran/50815 * trans-decl.c (add_argument_checking): Skip bound checking for deferred-length strings. 2011-12-08 Tobias Burnus 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 --- gcc/fortran/ChangeLog | 6 +++++ gcc/fortran/trans-decl.c | 6 +++-- gcc/testsuite/ChangeLog | 5 ++++ gcc/testsuite/gfortran.dg/bounds_check_16.f90 | 14 ++++++++++ libgfortran/io/transfer.c | 37 +++++++++++++++++++++++++++ 5 files changed, 66 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/bounds_check_16.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 986ee2d..abaa344 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,11 @@ 2011-12-08 Tobias Burnus + PR fortran/50815 + * trans-decl.c (add_argument_checking): Skip bound checking + for deferred-length strings. + +2011-12-08 Tobias Burnus + 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 --- 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 (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" diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 452fddd..30f1609 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,10 @@ 2011-12-08 Tobias Burnus + PR fortran/50815 + * gfortran.dg/bounds_check_16.f90: New. + +2011-12-08 Tobias Burnus + 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 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 --- 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, @@ -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); -- 2.7.4