re PR fortran/47767 ([OOP] SELECT TYPE fails to execute correct TYPE IS block)
2011-02-18 Janus Weil <janus@gcc.gnu.org> PR fortran/47767 * gfortran.h (gfc_check_access): Removed prototype. (gfc_check_symbol_access): Added prototype. * module.c (gfc_check_access): Renamed to 'check_access', made static. (gfc_check_symbol_access): New function, basically a shortcut for 'check_access'. (write_dt_extensions,write_symbol0,write_generic,write_symtree): Use 'gfc_check_symbol_access'. (write_operator,write_module): Renamed 'gfc_check_access'. * resolve.c (resolve_fl_procedure,resolve_fl_derived, resolve_fl_namelist,resolve_symbol,resolve_fntype): Use 'gfc_check_symbol_access'. 2011-02-18 Janus Weil <janus@gcc.gnu.org> PR fortran/47767 * gfortran.dg/class_40.f03: New. From-SVN: r170269
This commit is contained in:
Janus Weil
parent
7f7d4b122b
commit
6e2062b00f
|
|
@ -1,3 +1,18 @@
|
|||
2011-02-18 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/47767
|
||||
* gfortran.h (gfc_check_access): Removed prototype.
|
||||
(gfc_check_symbol_access): Added prototype.
|
||||
* module.c (gfc_check_access): Renamed to 'check_access', made static.
|
||||
(gfc_check_symbol_access): New function, basically a shortcut for
|
||||
'check_access'.
|
||||
(write_dt_extensions,write_symbol0,write_generic,write_symtree): Use
|
||||
'gfc_check_symbol_access'.
|
||||
(write_operator,write_module): Renamed 'gfc_check_access'.
|
||||
* resolve.c (resolve_fl_procedure,resolve_fl_derived,
|
||||
resolve_fl_namelist,resolve_symbol,resolve_fntype): Use
|
||||
'gfc_check_symbol_access'.
|
||||
|
||||
2011-02-16 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/47745
|
||||
|
|
|
|||
|
|
@ -2832,7 +2832,7 @@ gfc_try gfc_resolve_wait (gfc_wait *);
|
|||
void gfc_module_init_2 (void);
|
||||
void gfc_module_done_2 (void);
|
||||
void gfc_dump_module (const char *, int);
|
||||
bool gfc_check_access (gfc_access, gfc_access);
|
||||
bool gfc_check_symbol_access (gfc_symbol *);
|
||||
void gfc_free_use_stmts (gfc_use_list *);
|
||||
|
||||
/* primary.c */
|
||||
|
|
|
|||
|
|
@ -4592,8 +4592,8 @@ read_module (void)
|
|||
PRIVATE, then private, and otherwise it is public unless the default
|
||||
access in this context has been declared PRIVATE. */
|
||||
|
||||
bool
|
||||
gfc_check_access (gfc_access specific_access, gfc_access default_access)
|
||||
static bool
|
||||
check_access (gfc_access specific_access, gfc_access default_access)
|
||||
{
|
||||
if (specific_access == ACCESS_PUBLIC)
|
||||
return TRUE;
|
||||
|
|
@ -4607,6 +4607,16 @@ gfc_check_access (gfc_access specific_access, gfc_access default_access)
|
|||
}
|
||||
|
||||
|
||||
bool
|
||||
gfc_check_symbol_access (gfc_symbol *sym)
|
||||
{
|
||||
if (sym->attr.vtab || sym->attr.vtype)
|
||||
return true;
|
||||
else
|
||||
return check_access (sym->attr.access, sym->ns->default_access);
|
||||
}
|
||||
|
||||
|
||||
/* A structure to remember which commons we've already written. */
|
||||
|
||||
struct written_common
|
||||
|
|
@ -4792,8 +4802,7 @@ write_equiv (void)
|
|||
static void
|
||||
write_dt_extensions (gfc_symtree *st)
|
||||
{
|
||||
if (!gfc_check_access (st->n.sym->attr.access,
|
||||
st->n.sym->ns->default_access))
|
||||
if (!gfc_check_symbol_access (st->n.sym))
|
||||
return;
|
||||
|
||||
mio_lparen ();
|
||||
|
|
@ -4874,7 +4883,7 @@ write_symbol0 (gfc_symtree *st)
|
|||
&& !sym->attr.subroutine && !sym->attr.function)
|
||||
dont_write = true;
|
||||
|
||||
if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
|
||||
if (!gfc_check_symbol_access (sym))
|
||||
dont_write = true;
|
||||
|
||||
if (!dont_write)
|
||||
|
|
@ -4931,8 +4940,7 @@ write_operator (gfc_user_op *uop)
|
|||
static char nullstring[] = "";
|
||||
const char *p = nullstring;
|
||||
|
||||
if (uop->op == NULL
|
||||
|| !gfc_check_access (uop->access, uop->ns->default_access))
|
||||
if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
|
||||
return;
|
||||
|
||||
mio_symbol_interface (&uop->name, &p, &uop->op);
|
||||
|
|
@ -4956,8 +4964,7 @@ write_generic (gfc_symtree *st)
|
|||
if (!sym || check_unique_name (st->name))
|
||||
return;
|
||||
|
||||
if (sym->generic == NULL
|
||||
|| !gfc_check_access (sym->attr.access, sym->ns->default_access))
|
||||
if (sym->generic == NULL || !gfc_check_symbol_access (sym))
|
||||
return;
|
||||
|
||||
if (sym->module == NULL)
|
||||
|
|
@ -4982,7 +4989,7 @@ write_symtree (gfc_symtree *st)
|
|||
&& sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
|
||||
return;
|
||||
|
||||
if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
|
||||
if (!gfc_check_symbol_access (sym)
|
||||
|| (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
|
||||
&& !sym->attr.subroutine && !sym->attr.function))
|
||||
return;
|
||||
|
|
@ -5013,8 +5020,8 @@ write_module (void)
|
|||
if (i == INTRINSIC_USER)
|
||||
continue;
|
||||
|
||||
mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
|
||||
gfc_current_ns->default_access)
|
||||
mio_interface (check_access (gfc_current_ns->operator_access[i],
|
||||
gfc_current_ns->default_access)
|
||||
? &gfc_current_ns->op[i] : NULL);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -10146,7 +10146,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
|
|||
the host. */
|
||||
if (!(sym->ns->parent
|
||||
&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
|
||||
&& gfc_check_access(sym->attr.access, sym->ns->default_access))
|
||||
&& gfc_check_symbol_access (sym))
|
||||
{
|
||||
gfc_interface *iface;
|
||||
|
||||
|
|
@ -10155,8 +10155,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
|
|||
if (arg->sym
|
||||
&& arg->sym->ts.type == BT_DERIVED
|
||||
&& !arg->sym->ts.u.derived->attr.use_assoc
|
||||
&& !gfc_check_access (arg->sym->ts.u.derived->attr.access,
|
||||
arg->sym->ts.u.derived->ns->default_access)
|
||||
&& !gfc_check_symbol_access (arg->sym->ts.u.derived)
|
||||
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
|
||||
"PRIVATE type and cannot be a dummy argument"
|
||||
" of '%s', which is PUBLIC at %L",
|
||||
|
|
@ -10178,8 +10177,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
|
|||
if (arg->sym
|
||||
&& arg->sym->ts.type == BT_DERIVED
|
||||
&& !arg->sym->ts.u.derived->attr.use_assoc
|
||||
&& !gfc_check_access (arg->sym->ts.u.derived->attr.access,
|
||||
arg->sym->ts.u.derived->ns->default_access)
|
||||
&& !gfc_check_symbol_access (arg->sym->ts.u.derived)
|
||||
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
|
||||
"'%s' in PUBLIC interface '%s' at %L "
|
||||
"takes dummy arguments of '%s' which is "
|
||||
|
|
@ -10203,8 +10201,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
|
|||
if (arg->sym
|
||||
&& arg->sym->ts.type == BT_DERIVED
|
||||
&& !arg->sym->ts.u.derived->attr.use_assoc
|
||||
&& !gfc_check_access (arg->sym->ts.u.derived->attr.access,
|
||||
arg->sym->ts.u.derived->ns->default_access)
|
||||
&& !gfc_check_symbol_access (arg->sym->ts.u.derived)
|
||||
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
|
||||
"'%s' in PUBLIC interface '%s' at %L "
|
||||
"takes dummy arguments of '%s' which is "
|
||||
|
|
@ -11655,11 +11652,10 @@ resolve_fl_derived (gfc_symbol *sym)
|
|||
|
||||
if (c->ts.type == BT_DERIVED
|
||||
&& sym->component_access != ACCESS_PRIVATE
|
||||
&& gfc_check_access (sym->attr.access, sym->ns->default_access)
|
||||
&& gfc_check_symbol_access (sym)
|
||||
&& !is_sym_host_assoc (c->ts.u.derived, sym->ns)
|
||||
&& !c->ts.u.derived->attr.use_assoc
|
||||
&& !gfc_check_access (c->ts.u.derived->attr.access,
|
||||
c->ts.u.derived->ns->default_access)
|
||||
&& !gfc_check_symbol_access (c->ts.u.derived)
|
||||
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
|
||||
"is a PRIVATE type and cannot be a component of "
|
||||
"'%s', which is PUBLIC at %L", c->name,
|
||||
|
|
@ -11823,14 +11819,13 @@ resolve_fl_namelist (gfc_symbol *sym)
|
|||
}
|
||||
|
||||
/* Reject PRIVATE objects in a PUBLIC namelist. */
|
||||
if (gfc_check_access(sym->attr.access, sym->ns->default_access))
|
||||
if (gfc_check_symbol_access (sym))
|
||||
{
|
||||
for (nl = sym->namelist; nl; nl = nl->next)
|
||||
{
|
||||
if (!nl->sym->attr.use_assoc
|
||||
&& !is_sym_host_assoc (nl->sym, sym->ns)
|
||||
&& !gfc_check_access(nl->sym->attr.access,
|
||||
nl->sym->ns->default_access))
|
||||
&& !gfc_check_symbol_access (nl->sym))
|
||||
{
|
||||
gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
|
||||
"cannot be member of PUBLIC namelist '%s' at %L",
|
||||
|
|
@ -11851,9 +11846,7 @@ resolve_fl_namelist (gfc_symbol *sym)
|
|||
/* Types with private components that are defined in the same module. */
|
||||
if (nl->sym->ts.type == BT_DERIVED
|
||||
&& !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
|
||||
&& !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
|
||||
? ACCESS_PRIVATE : ACCESS_UNKNOWN,
|
||||
nl->sym->ns->default_access))
|
||||
&& nl->sym->ts.u.derived->attr.private_comp)
|
||||
{
|
||||
gfc_error ("NAMELIST object '%s' has PRIVATE components and "
|
||||
"cannot be a member of PUBLIC namelist '%s' at %L",
|
||||
|
|
@ -12226,8 +12219,7 @@ resolve_symbol (gfc_symbol *sym)
|
|||
return;
|
||||
|
||||
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
|
||||
if (!ds && sym->attr.function
|
||||
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
|
||||
if (!ds && sym->attr.function && gfc_check_symbol_access (sym))
|
||||
{
|
||||
symtree = gfc_new_symtree (&sym->ns->sym_root,
|
||||
sym->ts.u.derived->name);
|
||||
|
|
@ -12243,9 +12235,8 @@ resolve_symbol (gfc_symbol *sym)
|
|||
if (sym->ts.type == BT_DERIVED
|
||||
&& sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
|
||||
&& !sym->ts.u.derived->attr.use_assoc
|
||||
&& gfc_check_access (sym->attr.access, sym->ns->default_access)
|
||||
&& !gfc_check_access (sym->ts.u.derived->attr.access,
|
||||
sym->ts.u.derived->ns->default_access)
|
||||
&& gfc_check_symbol_access (sym)
|
||||
&& !gfc_check_symbol_access (sym->ts.u.derived)
|
||||
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
|
||||
"of PRIVATE derived type '%s'",
|
||||
(sym->attr.flavor == FL_PARAMETER) ? "parameter"
|
||||
|
|
@ -13356,9 +13347,8 @@ resolve_fntype (gfc_namespace *ns)
|
|||
|
||||
if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
|
||||
&& !sym->attr.contained
|
||||
&& !gfc_check_access (sym->ts.u.derived->attr.access,
|
||||
sym->ts.u.derived->ns->default_access)
|
||||
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
|
||||
&& !gfc_check_symbol_access (sym->ts.u.derived)
|
||||
&& gfc_check_symbol_access (sym))
|
||||
{
|
||||
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
|
||||
"%L of PRIVATE type '%s'", sym->name,
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2011-02-18 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/47767
|
||||
* gfortran.dg/class_40.f03: New.
|
||||
|
||||
2011-02-18 Dodji Seketeli <dodji@redhat.com>
|
||||
|
||||
PR c++/47208
|
||||
|
|
|
|||
|
|
@ -0,0 +1,36 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! PR 47767: [OOP] SELECT TYPE fails to execute correct TYPE IS block
|
||||
!
|
||||
! Contributed by Andrew Benson <abenson@caltech.edu>
|
||||
|
||||
module Tree_Nodes
|
||||
type treeNode
|
||||
contains
|
||||
procedure :: walk
|
||||
end type
|
||||
contains
|
||||
subroutine walk (thisNode)
|
||||
class (treeNode) :: thisNode
|
||||
print *, SAME_TYPE_AS (thisNode, treeNode())
|
||||
end subroutine
|
||||
end module
|
||||
|
||||
module Merger_Trees
|
||||
use Tree_Nodes
|
||||
private
|
||||
type(treeNode), public :: baseNode
|
||||
end module
|
||||
|
||||
module Merger_Tree_Build
|
||||
use Merger_Trees
|
||||
end module
|
||||
|
||||
program test
|
||||
use Merger_Tree_Build
|
||||
use Tree_Nodes
|
||||
type(treeNode) :: node
|
||||
call walk (node)
|
||||
end program
|
||||
|
||||
! { dg-final { cleanup-modules "Tree_Nodes Merger_Trees Merger_Tree_Build" } }
|
||||
Loading…
Reference in New Issue