From 3e1cf50075be169656ce3ce2b9ef33fdcaeb0bb1 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 19 Feb 2006 15:24:26 +0000 Subject: [PATCH] re PR fortran/25054 (nonconstant bounds array cannot appear in a namelist) 2005-02-19 Paul Thomas PR fortran/25054 * resolve.c (is_non_constant_shape_array): New function. (resolve_fl_variable): Remove code for the new function and call it. (resolve_fl_namelist): New function. Add test for namelist array with non-constant shape, using is_non_constant_shape_array. (resolve_symbol): Remove code for resolve_fl_namelist and call it. PR fortran/25089 * match.c (match_namelist): Increment the refs field of an accepted namelist object symbol. * resolve.c (resolve_fl_namelist): Test namelist objects for a conflict with contained or module procedures. 2005-02-19 Paul Thomas PR fortran/25054 * gfortran.dg/namelist_5.f90: New test. PR fortran/25089 * gfortran.dg/namelist_4.f90: New test. From-SVN: r111268 --- gcc/fortran/ChangeLog | 15 +++ gcc/fortran/match.c | 1 + gcc/fortran/resolve.c | 142 +++++++++++++++-------- gcc/testsuite/ChangeLog | 8 ++ gcc/testsuite/gfortran.dg/namelist_4.f90 | 39 +++++++ gcc/testsuite/gfortran.dg/namelist_5.f90 | 13 +++ 6 files changed, 169 insertions(+), 49 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/namelist_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/namelist_5.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 83a9059b8a3..5486c8eb78a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2005-02-19 Paul Thomas + + PR fortran/25054 + * resolve.c (is_non_constant_shape_array): New function. + (resolve_fl_variable): Remove code for the new function and call it. + (resolve_fl_namelist): New function. Add test for namelist array + with non-constant shape, using is_non_constant_shape_array. + (resolve_symbol): Remove code for resolve_fl_namelist and call it. + + PR fortran/25089 + * match.c (match_namelist): Increment the refs field of an accepted + namelist object symbol. + * resolve.c (resolve_fl_namelist): Test namelist objects for a conflict + with contained or module procedures. + 2006-02-18 Roger Sayle * trans-stmt.c (struct temporary_list): Delete. diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index a2b9c41d549..4c2fe1b71ce 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2589,6 +2589,7 @@ gfc_match_namelist (void) nl = gfc_get_namelist (); nl->sym = sym; + sym->refs++; if (group_name->namelist == NULL) group_name->namelist = group_name->namelist_tail = nl; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1de2446aa1f..63b2cd9904d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4598,6 +4598,35 @@ resolve_charlen (gfc_charlen *cl) } +/* Test for non-constant shape arrays. */ + +static bool +is_non_constant_shape_array (gfc_symbol *sym) +{ + gfc_expr *e; + int i; + + if (sym->as != NULL) + { + /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that + has not been simplified; parameter array references. Do the + simplification now. */ + for (i = 0; i < sym->as->rank; i++) + { + e = sym->as->lower[i]; + if (e && (resolve_index_expr (e) == FAILURE + || !gfc_is_constant_expr (e))) + return true; + + e = sym->as->upper[i]; + if (e && (resolve_index_expr (e) == FAILURE + || !gfc_is_constant_expr (e))) + return true; + } + } + return false; +} + /* Resolution of common features of flavors variable and procedure. */ static try @@ -4652,43 +4681,17 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) return FAILURE; /* The shape of a main program or module array needs to be constant. */ - if (sym->as != NULL - && sym->ns->proc_name + if (sym->ns->proc_name && (sym->ns->proc_name->attr.flavor == FL_MODULE || sym->ns->proc_name->attr.is_main_program) && !sym->attr.use_assoc && !sym->attr.allocatable - && !sym->attr.pointer) + && !sym->attr.pointer + && is_non_constant_shape_array (sym)) { - /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that - has not been simplified; parameter array references. Do the - simplification now. */ - flag = 0; - for (i = 0; i < sym->as->rank; i++) - { - e = sym->as->lower[i]; - if (e && (resolve_index_expr (e) == FAILURE - || !gfc_is_constant_expr (e))) - { - flag = 1; - break; - } - - e = sym->as->upper[i]; - if (e && (resolve_index_expr (e) == FAILURE - || !gfc_is_constant_expr (e))) - { - flag = 1; - break; - } - } - - if (flag) - { - gfc_error ("The module or main program array '%s' at %L must " + gfc_error ("The module or main program array '%s' at %L must " "have constant shape", sym->name, &sym->declared_at); return FAILURE; - } } if (sym->ts.type == BT_CHARACTER) @@ -4960,6 +4963,64 @@ resolve_fl_derived (gfc_symbol *sym) } +static try +resolve_fl_namelist (gfc_symbol *sym) +{ + gfc_namelist *nl; + gfc_symbol *nlsym; + + /* Reject PRIVATE objects in a PUBLIC namelist. */ + if (gfc_check_access(sym->attr.access, sym->ns->default_access)) + { + for (nl = sym->namelist; nl; nl = nl->next) + { + if (!nl->sym->attr.use_assoc + && !(sym->ns->parent == nl->sym->ns) + && !gfc_check_access(nl->sym->attr.access, + nl->sym->ns->default_access)) + { + gfc_error ("PRIVATE symbol '%s' cannot be member of " + "PUBLIC namelist at %L", nl->sym->name, + &sym->declared_at); + return FAILURE; + } + } + } + + /* Reject namelist arrays that are not constant shape. */ + for (nl = sym->namelist; nl; nl = nl->next) + { + if (is_non_constant_shape_array (nl->sym)) + { + gfc_error ("The array '%s' must have constant shape to be " + "a NAMELIST object at %L", nl->sym->name, + &sym->declared_at); + return FAILURE; + } + } + + /* 14.1.2 A module or internal procedure represent local entities + of the same type as a namelist member and so are not allowed. + Note that this is sometimes caught by check_conflict so the + same message has been used. */ + for (nl = sym->namelist; nl; nl = nl->next) + { + nlsym = NULL; + if (sym->ns->parent && nl->sym && nl->sym->name) + gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym); + if (nlsym && nlsym->attr.flavor == FL_PROCEDURE) + { + gfc_error ("PROCEDURE attribute conflicts with NAMELIST " + "attribute in '%s' at %L", nlsym->name, + &sym->declared_at); + return FAILURE; + } + } + + return SUCCESS; +} + + static try resolve_fl_parameter (gfc_symbol *sym) { @@ -5007,7 +5068,6 @@ resolve_symbol (gfc_symbol * sym) /* Zero if we are checking a formal namespace. */ static int formal_ns_flag = 1; int formal_ns_save, check_constant, mp_flag; - gfc_namelist *nl; gfc_symtree *symtree; gfc_symtree *this_symtree; gfc_namespace *ns; @@ -5162,23 +5222,8 @@ resolve_symbol (gfc_symbol * sym) break; case FL_NAMELIST: - /* Reject PRIVATE objects in a PUBLIC namelist. */ - if (gfc_check_access(sym->attr.access, sym->ns->default_access)) - { - for (nl = sym->namelist; nl; nl = nl->next) - { - if (!nl->sym->attr.use_assoc - && - !(sym->ns->parent == nl->sym->ns) - && - !gfc_check_access(nl->sym->attr.access, - nl->sym->ns->default_access)) - gfc_error ("PRIVATE symbol '%s' cannot be member of " - "PUBLIC namelist at %L", nl->sym->name, - &sym->declared_at); - } - } - + if (resolve_fl_namelist (sym) == FAILURE) + return; break; case FL_PARAMETER: @@ -5192,7 +5237,6 @@ resolve_symbol (gfc_symbol * sym) break; } - /* Make sure that intrinsic exist */ if (sym->attr.intrinsic && ! gfc_intrinsic_name(sym->name, 0) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f705bddb639..6cca5da64c6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2005-02-19 Paul Thomas + + PR fortran/25054 + * gfortran.dg/namelist_5.f90: New test. + + PR fortran/25089 + * gfortran.dg/namelist_4.f90: New test. + 2006-02-18 Andrew Pinski PR tree-opt/25680 diff --git a/gcc/testsuite/gfortran.dg/namelist_4.f90 b/gcc/testsuite/gfortran.dg/namelist_4.f90 new file mode 100644 index 00000000000..0e1b0eef51f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_4.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! This tests the fix for PR25089 in which it was noted that a +! NAMELIST member that is an internal(or module) procedure gave +! no error if the NAMELIST declaration appeared before the +! procedure declaration. Not mentioned in the PR is that any +! reference to the NAMELIST object would cause a segfault. +! +! Based on the contribution from Joost VanderVondele +! +module M1 +CONTAINS +! This is the original PR + INTEGER FUNCTION G1() + NAMELIST /NML1/ G2 ! { dg-error "PROCEDURE attribute conflicts" } + G1=1 + END FUNCTION + INTEGER FUNCTION G2() + G2=1 + END FUNCTION +! This has always been picked up - namelist after function + INTEGER FUNCTION G3() + NAMELIST /NML2/ G1 ! { dg-error "PROCEDURE attribute conflicts" } + G3=1 + END FUNCTION +END module M1 + +program P1 +CONTAINS +! This has the additional wrinkle of a reference to the object. + INTEGER FUNCTION F1() + NAMELIST /NML3/ F2 ! { dg-error "PROCEDURE attribute conflicts" } + f2 = 1 ! Used to ICE here + F1=1 + END FUNCTION + INTEGER FUNCTION F2() + F2=1 + END FUNCTION +END + diff --git a/gcc/testsuite/gfortran.dg/namelist_5.f90 b/gcc/testsuite/gfortran.dg/namelist_5.f90 new file mode 100644 index 00000000000..401302dd5dd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_5.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Tests the fix for PR25054 in which namelist objects with non-constant +! shape were allowed. +! +! Contributed by Joost VandeVondele +! +SUBROUTINE S1(I) + integer :: a,b(I) + NAMELIST /NLIST/ a,b ! { dg-error "must have constant shape to be a NAMELIST object" } + a=1 ; b=2 + write(6,NML=NLIST) +END SUBROUTINE S1 +END \ No newline at end of file