From: Tobias Schlüter Date: Thu, 20 Sep 2007 18:07:04 +0000 (+0200) Subject: io.c (resolve_tag_format): New function using code split out and simplified from ... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=f25bf34f06bd8a1ada0928e402acbe984a199dbb;p=gcc.git io.c (resolve_tag_format): New function using code split out and simplified from ... fortran/ * io.c (resolve_tag_format): New function using code split out and simplified from ... (resolve_tag): ... this function. Simplify logic. Unify IOSTAT, IOLENGTH and SIZE handling. testsuite/ * gfortran.dg/g77/19981216-0.f: Remove dg-warning annotation. * gfortran.dg/io_constraints_1.f90: Make a -std=f95 test. Add warning annotation. * gfortran.dg/iostat_3.f90: Make a -std=f95 test. From-SVN: r128623 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 29d8dd2debc..9e7ca3a389e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2007-09-20 Tobias Schlüter + + * io.c (resolve_tag_format): New function using code split out + and simplified from ... + (resolve_tag): ... this function. Simplify logic. Unify + IOSTAT, IOLENGTH and SIZE handling. + 2007-09-20 Christopher D. Rickett PR fortran/33497 diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 1ecea88eb18..901af922b95 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -1091,141 +1091,125 @@ match_ltag (const io_tag *tag, gfc_st_label ** label) } -/* Do expression resolution and type-checking on an expression tag. */ +/* Resolution of the FORMAT tag, to be called from resolve_tag. */ static try -resolve_tag (const io_tag *tag, gfc_expr *e) +resolve_tag_format (const gfc_expr *e) { - if (e == NULL) - return SUCCESS; - - if (gfc_resolve_expr (e) == FAILURE) - return FAILURE; - - if (e->ts.type != tag->type && tag != &tag_format) + if (e->expr_type == EXPR_CONSTANT + && (e->ts.type != BT_CHARACTER + || e->ts.kind != gfc_default_character_kind)) { - gfc_error ("%s tag at %L must be of type %s", tag->name, - &e->where, gfc_basic_typename (tag->type)); + gfc_error ("Constant expression in FORMAT tag at %L must be " + "of type default CHARACTER", &e->where); return FAILURE; } - if (tag == &tag_format) + /* If e's rank is zero and e is not an element of an array, it should be + of integer or character type. The integer variable should be + ASSIGNED. */ + if (e->symtree == NULL || e->symtree->n.sym->as == NULL + || e->symtree->n.sym->as->rank == 0) { - if (e->expr_type == EXPR_CONSTANT - && (e->ts.type != BT_CHARACTER - || e->ts.kind != gfc_default_character_kind)) + if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER) { - gfc_error ("Constant expression in FORMAT tag at %L must be " - "of type default CHARACTER", &e->where); + gfc_error ("FORMAT tag at %L must be of type CHARACTER or INTEGER", + &e->where); return FAILURE; } - - /* If e's rank is zero and e is not an element of an array, it should be - of integer or character type. The integer variable should be - ASSIGNED. */ - if (e->symtree == NULL || e->symtree->n.sym->as == NULL - || e->symtree->n.sym->as->rank == 0) + else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE) { - if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER) - { - gfc_error ("%s tag at %L must be of type %s or %s", tag->name, - &e->where, gfc_basic_typename (BT_CHARACTER), - gfc_basic_typename (BT_INTEGER)); - return FAILURE; - } - else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE) - { - if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED " - "variable in FORMAT tag at %L", &e->where) - == FAILURE) - return FAILURE; - if (e->symtree->n.sym->attr.assign != 1) - { - gfc_error ("Variable '%s' at %L has not been assigned a " - "format label", e->symtree->n.sym->name, - &e->where); - return FAILURE; - } - } - else if (e->ts.type == BT_INTEGER) + if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED " + "variable in FORMAT tag at %L", &e->where) + == FAILURE) + return FAILURE; + if (e->symtree->n.sym->attr.assign != 1) { - gfc_error ("scalar '%s' FORMAT tag at %L is not an ASSIGNED " - "variable", gfc_basic_typename (e->ts.type), - &e->where); + gfc_error ("Variable '%s' at %L has not been assigned a " + "format label", e->symtree->n.sym->name, &e->where); return FAILURE; } - - return SUCCESS; } - else + else if (e->ts.type == BT_INTEGER) { - /* if rank is nonzero, we allow the type to be character under - GFC_STD_GNU and other type under GFC_STD_LEGACY. It may be - assigned an Hollerith constant. */ - if (e->ts.type == BT_CHARACTER) - { - if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array " - "in FORMAT tag at %L", &e->where) - == FAILURE) - return FAILURE; - } - else - { - if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character " - "in FORMAT tag at %L", &e->where) - == FAILURE) - return FAILURE; - } - return SUCCESS; + gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED " + "variable", gfc_basic_typename (e->ts.type), &e->where); + return FAILURE; } + + return SUCCESS; + } + + /* If rank is nonzero, we allow the type to be character under GFC_STD_GNU + and other type under GFC_STD_LEGACY. It may be assigned an Hollerith + constant. */ + if (e->ts.type == BT_CHARACTER) + { + if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array " + "in FORMAT tag at %L", &e->where) == FAILURE) + return FAILURE; } else { - if (e->rank != 0) - { - gfc_error ("%s tag at %L must be scalar", tag->name, &e->where); - return FAILURE; - } + if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character " + "in FORMAT tag at %L", &e->where) == FAILURE) + return FAILURE; + } - if (tag == &tag_iomsg) - { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L", - &e->where) == FAILURE) - return FAILURE; - } + return SUCCESS; +} - if (tag == &tag_iostat && e->ts.kind != gfc_default_integer_kind) - { - if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default " - "INTEGER in IOSTAT tag at %L", &e->where) - == FAILURE) - return FAILURE; - } - if (tag == &tag_size && e->ts.kind != gfc_default_integer_kind) - { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default " - "INTEGER in SIZE tag at %L", &e->where) - == FAILURE) - return FAILURE; - } +/* Do expression resolution and type-checking on an expression tag. */ - if (tag == &tag_convert) - { - if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L", - &e->where) == FAILURE) - return FAILURE; - } - - if (tag == &tag_iolength && e->ts.kind != gfc_default_integer_kind) - { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default " - "INTEGER in IOLENGTH tag at %L", &e->where) - == FAILURE) - return FAILURE; - } +static try +resolve_tag (const io_tag *tag, gfc_expr *e) +{ + if (e == NULL) + return SUCCESS; + + if (gfc_resolve_expr (e) == FAILURE) + return FAILURE; + + if (tag == &tag_format) + return resolve_tag_format (e); + + if (e->ts.type != tag->type) + { + gfc_error ("%s tag at %L must be of type %s", tag->name, + &e->where, gfc_basic_typename (tag->type)); + return FAILURE; } + if (e->rank != 0) + { + gfc_error ("%s tag at %L must be scalar", tag->name, &e->where); + return FAILURE; + } + + if (tag == &tag_iomsg) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L", + &e->where) == FAILURE) + return FAILURE; + } + + if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength) + && e->ts.kind != gfc_default_integer_kind) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default " + "INTEGER in %s tag at %L", tag->name, &e->where) + == FAILURE) + return FAILURE; + } + + if (tag == &tag_convert) + { + if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L", + &e->where) == FAILURE) + return FAILURE; + } + return SUCCESS; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 52e2cdf778a..4521fe5adaa 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2007-09-20 Tobias Schlüter + + * gfortran.dg/g77/19981216-0.f: Remove dg-warning annotation. + * gfortran.dg/io_constraints_1.f90: Make a -std=f95 test. Add + warning annotation. + * gfortran.dg/iostat_3.f90: Make a -std=f95 test. + 2007-09-20 Christopher D. Rickett PR fortran/33497 diff --git a/gcc/testsuite/gfortran.dg/g77/19981216-0.f b/gcc/testsuite/gfortran.dg/g77/19981216-0.f index 5920ddf6434..1e5db3c3b5c 100644 --- a/gcc/testsuite/gfortran.dg/g77/19981216-0.f +++ b/gcc/testsuite/gfortran.dg/g77/19981216-0.f @@ -29,7 +29,7 @@ c { dg-do compile } name = 'blah' open(unit=8,status='unknown',file=name,form='formatted', - F iostat=ios) ! { dg-warning "INTEGER in IOSTAT" } + F iostat=ios) END * ------------------------------------------- diff --git a/gcc/testsuite/gfortran.dg/io_constraints_1.f90 b/gcc/testsuite/gfortran.dg/io_constraints_1.f90 index 00306a0a7b4..05f52faae76 100644 --- a/gcc/testsuite/gfortran.dg/io_constraints_1.f90 +++ b/gcc/testsuite/gfortran.dg/io_constraints_1.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-options "-std=f95" } ! Part I of the test of the IO constraints patch, which fixes PRs: ! PRs 25053, 25063, 25064, 25066, 25067, 25068, 25069, 25307 and 20862. ! @@ -20,7 +21,7 @@ contains subroutine foo (i) integer :: i write (*, 100) i - 100 format (1h , "i=", i6) ! This is OK. + 100 format (1h , "i=", i6) ! { dg-warning "The H format specifier at ... is a Fortran 95 deleted feature" } end subroutine foo end module global diff --git a/gcc/testsuite/gfortran.dg/iostat_3.f90 b/gcc/testsuite/gfortran.dg/iostat_3.f90 index 1dc72d149c4..0f6aacaf004 100644 --- a/gcc/testsuite/gfortran.dg/iostat_3.f90 +++ b/gcc/testsuite/gfortran.dg/iostat_3.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-options "-std=f95" } ! Testcase for PR libfortran/25068 real :: u integer(kind=8) :: i