Commit 6e2062b0 by Janus Weil

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
parent 7f7d4b12
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> 2011-02-16 Janus Weil <janus@gcc.gnu.org>
PR fortran/47745 PR fortran/47745
......
...@@ -2832,7 +2832,7 @@ gfc_try gfc_resolve_wait (gfc_wait *); ...@@ -2832,7 +2832,7 @@ gfc_try gfc_resolve_wait (gfc_wait *);
void gfc_module_init_2 (void); void gfc_module_init_2 (void);
void gfc_module_done_2 (void); void gfc_module_done_2 (void);
void gfc_dump_module (const char *, int); 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 *); void gfc_free_use_stmts (gfc_use_list *);
/* primary.c */ /* primary.c */
......
...@@ -4592,8 +4592,8 @@ read_module (void) ...@@ -4592,8 +4592,8 @@ read_module (void)
PRIVATE, then private, and otherwise it is public unless the default PRIVATE, then private, and otherwise it is public unless the default
access in this context has been declared PRIVATE. */ access in this context has been declared PRIVATE. */
bool static bool
gfc_check_access (gfc_access specific_access, gfc_access default_access) check_access (gfc_access specific_access, gfc_access default_access)
{ {
if (specific_access == ACCESS_PUBLIC) if (specific_access == ACCESS_PUBLIC)
return TRUE; return TRUE;
...@@ -4607,6 +4607,16 @@ gfc_check_access (gfc_access specific_access, gfc_access default_access) ...@@ -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. */ /* A structure to remember which commons we've already written. */
struct written_common struct written_common
...@@ -4792,8 +4802,7 @@ write_equiv (void) ...@@ -4792,8 +4802,7 @@ write_equiv (void)
static void static void
write_dt_extensions (gfc_symtree *st) write_dt_extensions (gfc_symtree *st)
{ {
if (!gfc_check_access (st->n.sym->attr.access, if (!gfc_check_symbol_access (st->n.sym))
st->n.sym->ns->default_access))
return; return;
mio_lparen (); mio_lparen ();
...@@ -4874,7 +4883,7 @@ write_symbol0 (gfc_symtree *st) ...@@ -4874,7 +4883,7 @@ write_symbol0 (gfc_symtree *st)
&& !sym->attr.subroutine && !sym->attr.function) && !sym->attr.subroutine && !sym->attr.function)
dont_write = true; dont_write = true;
if (!gfc_check_access (sym->attr.access, sym->ns->default_access)) if (!gfc_check_symbol_access (sym))
dont_write = true; dont_write = true;
if (!dont_write) if (!dont_write)
...@@ -4931,8 +4940,7 @@ write_operator (gfc_user_op *uop) ...@@ -4931,8 +4940,7 @@ write_operator (gfc_user_op *uop)
static char nullstring[] = ""; static char nullstring[] = "";
const char *p = nullstring; const char *p = nullstring;
if (uop->op == NULL if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
|| !gfc_check_access (uop->access, uop->ns->default_access))
return; return;
mio_symbol_interface (&uop->name, &p, &uop->op); mio_symbol_interface (&uop->name, &p, &uop->op);
...@@ -4956,8 +4964,7 @@ write_generic (gfc_symtree *st) ...@@ -4956,8 +4964,7 @@ write_generic (gfc_symtree *st)
if (!sym || check_unique_name (st->name)) if (!sym || check_unique_name (st->name))
return; return;
if (sym->generic == NULL if (sym->generic == NULL || !gfc_check_symbol_access (sym))
|| !gfc_check_access (sym->attr.access, sym->ns->default_access))
return; return;
if (sym->module == NULL) if (sym->module == NULL)
...@@ -4982,7 +4989,7 @@ write_symtree (gfc_symtree *st) ...@@ -4982,7 +4989,7 @@ write_symtree (gfc_symtree *st)
&& sym->ns->proc_name->attr.if_source == IFSRC_IFBODY) && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
return; 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.flavor == FL_PROCEDURE && sym->attr.generic
&& !sym->attr.subroutine && !sym->attr.function)) && !sym->attr.subroutine && !sym->attr.function))
return; return;
...@@ -5013,8 +5020,8 @@ write_module (void) ...@@ -5013,8 +5020,8 @@ write_module (void)
if (i == INTRINSIC_USER) if (i == INTRINSIC_USER)
continue; continue;
mio_interface (gfc_check_access (gfc_current_ns->operator_access[i], mio_interface (check_access (gfc_current_ns->operator_access[i],
gfc_current_ns->default_access) gfc_current_ns->default_access)
? &gfc_current_ns->op[i] : NULL); ? &gfc_current_ns->op[i] : NULL);
} }
......
...@@ -10146,7 +10146,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) ...@@ -10146,7 +10146,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
the host. */ the host. */
if (!(sym->ns->parent if (!(sym->ns->parent
&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE) && 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; gfc_interface *iface;
...@@ -10155,8 +10155,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) ...@@ -10155,8 +10155,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
if (arg->sym if (arg->sym
&& arg->sym->ts.type == BT_DERIVED && arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc && !arg->sym->ts.u.derived->attr.use_assoc
&& !gfc_check_access (arg->sym->ts.u.derived->attr.access, && !gfc_check_symbol_access (arg->sym->ts.u.derived)
arg->sym->ts.u.derived->ns->default_access)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a " && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
"PRIVATE type and cannot be a dummy argument" "PRIVATE type and cannot be a dummy argument"
" of '%s', which is PUBLIC at %L", " of '%s', which is PUBLIC at %L",
...@@ -10178,8 +10177,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) ...@@ -10178,8 +10177,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
if (arg->sym if (arg->sym
&& arg->sym->ts.type == BT_DERIVED && arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc && !arg->sym->ts.u.derived->attr.use_assoc
&& !gfc_check_access (arg->sym->ts.u.derived->attr.access, && !gfc_check_symbol_access (arg->sym->ts.u.derived)
arg->sym->ts.u.derived->ns->default_access)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure " && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
"'%s' in PUBLIC interface '%s' at %L " "'%s' in PUBLIC interface '%s' at %L "
"takes dummy arguments of '%s' which is " "takes dummy arguments of '%s' which is "
...@@ -10203,8 +10201,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) ...@@ -10203,8 +10201,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
if (arg->sym if (arg->sym
&& arg->sym->ts.type == BT_DERIVED && arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc && !arg->sym->ts.u.derived->attr.use_assoc
&& !gfc_check_access (arg->sym->ts.u.derived->attr.access, && !gfc_check_symbol_access (arg->sym->ts.u.derived)
arg->sym->ts.u.derived->ns->default_access)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure " && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
"'%s' in PUBLIC interface '%s' at %L " "'%s' in PUBLIC interface '%s' at %L "
"takes dummy arguments of '%s' which is " "takes dummy arguments of '%s' which is "
...@@ -11655,11 +11652,10 @@ resolve_fl_derived (gfc_symbol *sym) ...@@ -11655,11 +11652,10 @@ resolve_fl_derived (gfc_symbol *sym)
if (c->ts.type == BT_DERIVED if (c->ts.type == BT_DERIVED
&& sym->component_access != ACCESS_PRIVATE && 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) && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
&& !c->ts.u.derived->attr.use_assoc && !c->ts.u.derived->attr.use_assoc
&& !gfc_check_access (c->ts.u.derived->attr.access, && !gfc_check_symbol_access (c->ts.u.derived)
c->ts.u.derived->ns->default_access)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' " && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
"is a PRIVATE type and cannot be a component of " "is a PRIVATE type and cannot be a component of "
"'%s', which is PUBLIC at %L", c->name, "'%s', which is PUBLIC at %L", c->name,
...@@ -11823,14 +11819,13 @@ resolve_fl_namelist (gfc_symbol *sym) ...@@ -11823,14 +11819,13 @@ resolve_fl_namelist (gfc_symbol *sym)
} }
/* Reject PRIVATE objects in a PUBLIC namelist. */ /* 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) for (nl = sym->namelist; nl; nl = nl->next)
{ {
if (!nl->sym->attr.use_assoc if (!nl->sym->attr.use_assoc
&& !is_sym_host_assoc (nl->sym, sym->ns) && !is_sym_host_assoc (nl->sym, sym->ns)
&& !gfc_check_access(nl->sym->attr.access, && !gfc_check_symbol_access (nl->sym))
nl->sym->ns->default_access))
{ {
gfc_error ("NAMELIST object '%s' was declared PRIVATE and " gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
"cannot be member of PUBLIC namelist '%s' at %L", "cannot be member of PUBLIC namelist '%s' at %L",
...@@ -11851,9 +11846,7 @@ resolve_fl_namelist (gfc_symbol *sym) ...@@ -11851,9 +11846,7 @@ resolve_fl_namelist (gfc_symbol *sym)
/* Types with private components that are defined in the same module. */ /* Types with private components that are defined in the same module. */
if (nl->sym->ts.type == BT_DERIVED if (nl->sym->ts.type == BT_DERIVED
&& !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns) && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
&& !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp && nl->sym->ts.u.derived->attr.private_comp)
? ACCESS_PRIVATE : ACCESS_UNKNOWN,
nl->sym->ns->default_access))
{ {
gfc_error ("NAMELIST object '%s' has PRIVATE components and " gfc_error ("NAMELIST object '%s' has PRIVATE components and "
"cannot be a member of PUBLIC namelist '%s' at %L", "cannot be a member of PUBLIC namelist '%s' at %L",
...@@ -12226,8 +12219,7 @@ resolve_symbol (gfc_symbol *sym) ...@@ -12226,8 +12219,7 @@ resolve_symbol (gfc_symbol *sym)
return; return;
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds); gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
if (!ds && sym->attr.function if (!ds && sym->attr.function && gfc_check_symbol_access (sym))
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
{ {
symtree = gfc_new_symtree (&sym->ns->sym_root, symtree = gfc_new_symtree (&sym->ns->sym_root,
sym->ts.u.derived->name); sym->ts.u.derived->name);
...@@ -12243,9 +12235,8 @@ resolve_symbol (gfc_symbol *sym) ...@@ -12243,9 +12235,8 @@ resolve_symbol (gfc_symbol *sym)
if (sym->ts.type == BT_DERIVED if (sym->ts.type == BT_DERIVED
&& sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
&& !sym->ts.u.derived->attr.use_assoc && !sym->ts.u.derived->attr.use_assoc
&& gfc_check_access (sym->attr.access, sym->ns->default_access) && gfc_check_symbol_access (sym)
&& !gfc_check_access (sym->ts.u.derived->attr.access, && !gfc_check_symbol_access (sym->ts.u.derived)
sym->ts.u.derived->ns->default_access)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L " && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
"of PRIVATE derived type '%s'", "of PRIVATE derived type '%s'",
(sym->attr.flavor == FL_PARAMETER) ? "parameter" (sym->attr.flavor == FL_PARAMETER) ? "parameter"
...@@ -13356,9 +13347,8 @@ resolve_fntype (gfc_namespace *ns) ...@@ -13356,9 +13347,8 @@ resolve_fntype (gfc_namespace *ns)
if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
&& !sym->attr.contained && !sym->attr.contained
&& !gfc_check_access (sym->ts.u.derived->attr.access, && !gfc_check_symbol_access (sym->ts.u.derived)
sym->ts.u.derived->ns->default_access) && gfc_check_symbol_access (sym))
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
{ {
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at " gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
"%L of PRIVATE type '%s'", sym->name, "%L of PRIVATE type '%s'", sym->name,
......
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> 2011-02-18 Dodji Seketeli <dodji@redhat.com>
PR c++/47208 PR c++/47208
......
! { 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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment