+2007-07-28 Daniel Franke <franke.daniel@gmail.com>
+
+ 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 <pault@gcc.gnu.org>
PR fortran/32880
/* 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;
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++;
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;
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)
};
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 ();
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;
}
}
}
*/
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 ();
}
{
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)
+2007-07-28 Daniel Franke <franke.daniel@gmail.com>
+
+ * 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 <pault@gcc.gnu.org>
PR fortran/32880
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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
!
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
git://gcc.gnu.org / gcc.git / commitdiff