From 5cca320dca64f20a69be6cbfd0145df99a5168ac Mon Sep 17 00:00:00 2001 From: Daniel Franke Date: Sat, 28 Jul 2007 04:51:06 -0400 Subject: [PATCH] re PR fortran/31818 (Wrongly accepts namelists with assumed-shape arrays) gcc/fortran: 2007-07-28 Daniel Franke PR fortran/31818 PR fortran/32876 PR fortran/32905 * gfortran.h (symbol_attribute): Added bits for pointer_comp, private_comp. * parse.c (parse_derived): Set pointer_comp/private_comp bits if the derived type ultimately contains pointer components or private components. * module.c (ab_attribute): New values AB_POINTER_COMP, AB_PRIVATE_COMP. (attr_bits): Added names for new ab_attributes. (mio_symbol_attribute): Save/restore new attribute bits in modules. * match.c (gfc_match_namelist): Removed check for namelist objects of assumed shape. * resolve.c (resolve_fl_namelist): Added check for pointer or private components in nested types. Added check for namelist objects of assumed shape. gcc/testsuite: 2007-07-28 Daniel Franke * gfortran.dg/namelist_5.f90: Adjusted error message. * gfortran.dg/assumed_shape_nml.f90: Renamed to ... * gfortran.dg/namelist_31.f90: ... this. Removed dg-warning directive. * gfortran.dg/assumed_size_nml.f90: Renamed to ... * gfortran.dg/namelist_32.f90: ... this. PR fortran/32876 * gfortran.dg/namelist_33.f90: New test. PR fortran/32905 * gfortran.dg/namelist_34.f90: New test. PR fortran/31818 * gfortran.dg/namelist_35.f90: New test. From-SVN: r127014 --- gcc/fortran/ChangeLog | 17 +++++ gcc/fortran/gfortran.h | 6 +- gcc/fortran/match.c | 6 -- gcc/fortran/module.c | 16 ++++- gcc/fortran/parse.c | 21 ++++++- gcc/fortran/resolve.c | 72 +++++++++++++++------- gcc/testsuite/ChangeLog | 17 +++++ .../{assumed_shape_nml.f90 => namelist_31.f90} | 4 +- .../{assumed_size_nml.f90 => namelist_32.f90} | 0 gcc/testsuite/gfortran.dg/namelist_33.f90 | 40 ++++++++++++ gcc/testsuite/gfortran.dg/namelist_34.f90 | 30 +++++++++ gcc/testsuite/gfortran.dg/namelist_35.f90 | 11 ++++ gcc/testsuite/gfortran.dg/namelist_5.f90 | 2 +- 13 files changed, 205 insertions(+), 37 deletions(-) rename gcc/testsuite/gfortran.dg/{assumed_shape_nml.f90 => namelist_31.f90} (80%) rename gcc/testsuite/gfortran.dg/{assumed_size_nml.f90 => namelist_32.f90} (100%) create mode 100644 gcc/testsuite/gfortran.dg/namelist_33.f90 create mode 100644 gcc/testsuite/gfortran.dg/namelist_34.f90 create mode 100644 gcc/testsuite/gfortran.dg/namelist_35.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5f8e39d..adc065d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2007-07-28 Daniel Franke + + PR fortran/31818 + PR fortran/32876 + PR fortran/32905 + * gfortran.h (symbol_attribute): Added bits for pointer_comp, private_comp. + * parse.c (parse_derived): Set pointer_comp/private_comp bits if the derived + type ultimately contains pointer components or private components. + * module.c (ab_attribute): New values AB_POINTER_COMP, AB_PRIVATE_COMP. + (attr_bits): Added names for new ab_attributes. + (mio_symbol_attribute): Save/restore new attribute bits in modules. + * match.c (gfc_match_namelist): Removed check for namelist objects of assumed + shape. + * resolve.c (resolve_fl_namelist): Added check for pointer or private + components in nested types. Added check for namelist objects of assumed + shape. + 2007-07-28 Paul Thomas PR fortran/32880 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a0b79e5..a668bf4 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -702,9 +702,9 @@ typedef struct /* Special attributes for Cray pointers, pointees. */ unsigned cray_pointer:1, cray_pointee:1; - /* The symbol is a derived type with allocatable components, possibly - nested. */ - unsigned alloc_comp:1; + /* The symbol is a derived type with allocatable components, pointer + components or private components, possibly nested. */ + unsigned alloc_comp:1, pointer_comp:1, private_comp:1; /* The namespace where the VOLATILE attribute has been set. */ struct gfc_namespace *volatile_ns; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 18b943d..9c524b2 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2822,12 +2822,6 @@ gfc_match_namelist (void) gfc_error_check (); } - if (sym->as && sym->as->type == AS_ASSUMED_SHAPE - && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in " - "namelist '%s' at %C is an extension.", - sym->name, group_name->name) == FAILURE) - gfc_error_check (); - nl = gfc_get_namelist (); nl->sym = sym; sym->refs++; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 31b7c9b..447ba00 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -1512,8 +1512,8 @@ typedef enum AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, - AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_IS_BIND_C, AB_IS_C_INTEROP, - AB_IS_ISO_C + AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED, + AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C } ab_attribute; @@ -1548,6 +1548,8 @@ static const mstring attr_bits[] = minit ("IS_ISO_C", AB_IS_ISO_C), minit ("VALUE", AB_VALUE), minit ("ALLOC_COMP", AB_ALLOC_COMP), + minit ("POINTER_COMP", AB_POINTER_COMP), + minit ("PRIVATE_COMP", AB_PRIVATE_COMP), minit ("PROTECTED", AB_PROTECTED), minit (NULL, -1) }; @@ -1654,6 +1656,10 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits); if (attr->alloc_comp) MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits); + if (attr->pointer_comp) + MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits); + if (attr->private_comp) + MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits); mio_rparen (); @@ -1760,6 +1766,12 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_ALLOC_COMP: attr->alloc_comp = 1; break; + case AB_POINTER_COMP: + attr->pointer_comp = 1; + break; + case AB_PRIVATE_COMP: + attr->private_comp = 1; + break; } } } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 974f3a2..c8d223a 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1615,17 +1615,34 @@ parse_derived (void) */ derived_sym = gfc_current_block(); - /* Look for allocatable components. */ sym = gfc_current_block (); for (c = sym->components; c; c = c->next) { + /* Look for allocatable components. */ if (c->allocatable || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)) { sym->attr.alloc_comp = 1; break; } - } + + /* Look for pointer components. */ + if (c->pointer + || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp)) + { + sym->attr.pointer_comp = 1; + break; + } + + /* Look for private components. */ + if (sym->component_access == ACCESS_PRIVATE + || c->access == ACCESS_PRIVATE + || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp)) + { + sym->attr.private_comp = 1; + break; + } + } pop_state (); } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1a5c001..a7edd16 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7027,45 +7027,75 @@ resolve_fl_namelist (gfc_symbol *sym) { for (nl = sym->namelist; nl; nl = nl->next) { - if (!nl->sym->attr.use_assoc - && !(sym->ns->parent == nl->sym->ns) - && !(sym->ns->parent - && sym->ns->parent->parent == nl->sym->ns) - && !gfc_check_access(nl->sym->attr.access, - nl->sym->ns->default_access)) + if (nl->sym->attr.use_assoc + || (sym->ns->parent == nl->sym->ns) + || (sym->ns->parent + && sym->ns->parent->parent == nl->sym->ns)) + continue; + + if (!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); + gfc_error ("NAMELIST object '%s' was declared PRIVATE and " + "cannot be member of PUBLIC namelist '%s' at %L", + nl->sym->name, sym->name, &sym->declared_at); + return FAILURE; + } + + if (nl->sym->ts.type == BT_DERIVED + && !gfc_check_access (nl->sym->ts.derived->attr.private_comp + ? ACCESS_PRIVATE : ACCESS_UNKNOWN, + nl->sym->ns->default_access)) + { + gfc_error ("NAMELIST object '%s' has PRIVATE components and " + "cannot be a member of PUBLIC namelist '%s' at %L", + nl->sym->name, sym->name, &sym->declared_at); return FAILURE; } } } - /* Reject namelist arrays that are not constant shape. */ for (nl = sym->namelist; nl; nl = nl->next) { + /* Reject namelist arrays of assumed shape. */ + if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE + && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' " + "must not have assumed shape in namelist " + "'%s' at %L", nl->sym->name, sym->name, + &sym->declared_at) == FAILURE) + return FAILURE; + + /* Reject namelist arrays that are not constant shape. */ 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); + gfc_error ("NAMELIST array object '%s' must have constant " + "shape in namelist '%s' at %L", nl->sym->name, + sym->name, &sym->declared_at); return FAILURE; } - } - /* Namelist objects cannot have allocatable components. */ - for (nl = sym->namelist; nl; nl = nl->next) - { - if (nl->sym->ts.type == BT_DERIVED - && nl->sym->ts.derived->attr.alloc_comp) + /* Namelist objects cannot have allocatable or pointer components. */ + if (nl->sym->ts.type != BT_DERIVED) + continue; + + if (nl->sym->ts.derived->attr.alloc_comp) { - gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE " - "components", nl->sym->name, &sym->declared_at); + gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot " + "have ALLOCATABLE components", + nl->sym->name, sym->name, &sym->declared_at); + return FAILURE; + } + + if (nl->sym->ts.derived->attr.pointer_comp) + { + gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot " + "have POINTER components", + nl->sym->name, 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. */ for (nl = sym->namelist; nl; nl = nl->next) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8f81053..5352bce 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,20 @@ +2007-07-28 Daniel Franke + + * gfortran.dg/namelist_5.f90: Adjusted error message. + * gfortran.dg/assumed_shape_nml.f90: Renamed to ... + * gfortran.dg/namelist_31.f90: ... this. Removed dg-warning directive. + * gfortran.dg/assumed_size_nml.f90: Renamed to ... + * gfortran.dg/namelist_32.f90: ... this. + + PR fortran/32876 + * gfortran.dg/namelist_33.f90: New test. + + PR fortran/32905 + * gfortran.dg/namelist_34.f90: New test. + + PR fortran/31818 + * gfortran.dg/namelist_35.f90: New test. + 2007-07-28 Paul Thomas PR fortran/32880 diff --git a/gcc/testsuite/gfortran.dg/assumed_shape_nml.f90 b/gcc/testsuite/gfortran.dg/namelist_31.f90 similarity index 80% rename from gcc/testsuite/gfortran.dg/assumed_shape_nml.f90 rename to gcc/testsuite/gfortran.dg/namelist_31.f90 index c2a8808..b7aba98 100644 --- a/gcc/testsuite/gfortran.dg/assumed_shape_nml.f90 +++ b/gcc/testsuite/gfortran.dg/namelist_31.f90 @@ -10,8 +10,8 @@ program assumed_shape_nml call foo (z) contains subroutine foo (y) - real, DIMENSION (1:) :: y - namelist /mynml/ y ! { dg-warning "is an extension" } + real, DIMENSION (:) :: y + namelist /mynml/ y write (*, mynml) end subroutine foo end program assumed_shape_nml diff --git a/gcc/testsuite/gfortran.dg/assumed_size_nml.f90 b/gcc/testsuite/gfortran.dg/namelist_32.f90 similarity index 100% rename from gcc/testsuite/gfortran.dg/assumed_size_nml.f90 rename to gcc/testsuite/gfortran.dg/namelist_32.f90 diff --git a/gcc/testsuite/gfortran.dg/namelist_33.f90 b/gcc/testsuite/gfortran.dg/namelist_33.f90 new file mode 100644 index 0000000..1642389 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_33.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! +! PR fortran/32876 - accepts private items in public NAMELISTs +! +MODULE types + type :: tp4 + PRIVATE + real :: x + integer :: i + end type + + ! nested type + type :: tp3 + real :: x + integer, private :: i + end type + + type :: tp2 + type(tp3) :: t + end type + + type :: tp1 + integer :: i + type(tp2) :: t + end type +END MODULE + +MODULE nml +USE types + type(tp1) :: t1 + type(tp4) :: t4 + + namelist /a/ t1 ! { dg-error "has PRIVATE components and cannot be a member of PUBLIC namelist" } + namelist /b/ t4 ! { dg-error "has PRIVATE components and cannot be a member of PUBLIC namelist" } + + integer, private :: i + namelist /c/ i ! { dg-error "was declared PRIVATE and cannot be member of PUBLIC namelist" } +END MODULE + +! { dg-final { cleanup-modules "types nml" } } diff --git a/gcc/testsuite/gfortran.dg/namelist_34.f90 b/gcc/testsuite/gfortran.dg/namelist_34.f90 new file mode 100644 index 0000000..be050d9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_34.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR fortran/32905 - accepts types with ultimate POINTER components +! +MODULE types + type :: tp3 + real :: x + integer, pointer :: i + end type + + type :: tp2 + type(tp3) :: t + end type + + type :: tp1 + integer :: i + type(tp2) :: t + end type +END MODULE + +MODULE nml +USE types + type(tp1) :: t1 + type(tp3) :: t3 + + namelist /a/ t1 ! { dg-error "cannot have POINTER components" } + namelist /b/ t3 ! { dg-error "cannot have POINTER components" } +END MODULE + +! { dg-final { cleanup-modules "types nml" } } diff --git a/gcc/testsuite/gfortran.dg/namelist_35.f90 b/gcc/testsuite/gfortran.dg/namelist_35.f90 new file mode 100644 index 0000000..531f636 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_35.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/31818 - accepts namelists with assumed-shape arrays +! + +subroutine test(cha) + implicit none + character(len=10) :: cha(:) + namelist /z/ cha ! { dg-error "must not have assumed shape" } +end subroutine test diff --git a/gcc/testsuite/gfortran.dg/namelist_5.f90 b/gcc/testsuite/gfortran.dg/namelist_5.f90 index 401302d..d7ccfd1 100644 --- a/gcc/testsuite/gfortran.dg/namelist_5.f90 +++ b/gcc/testsuite/gfortran.dg/namelist_5.f90 @@ -6,7 +6,7 @@ ! SUBROUTINE S1(I) integer :: a,b(I) - NAMELIST /NLIST/ a,b ! { dg-error "must have constant shape to be a NAMELIST object" } + NAMELIST /NLIST/ a,b ! { dg-error "must have constant shape" } a=1 ; b=2 write(6,NML=NLIST) END SUBROUTINE S1 -- 2.7.4