From 6e2062b00f9270676ded3f8bfe16273843f449d6 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Fri, 18 Feb 2011 11:04:30 +0100 Subject: [PATCH] re PR fortran/47767 ([OOP] SELECT TYPE fails to execute correct TYPE IS block) 2011-02-18 Janus Weil 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 PR fortran/47767 * gfortran.dg/class_40.f03: New. From-SVN: r170269 --- gcc/fortran/ChangeLog | 15 ++++++++++ gcc/fortran/gfortran.h | 2 +- gcc/fortran/module.c | 31 +++++++++++++-------- gcc/fortran/resolve.c | 38 ++++++++++---------------- gcc/testsuite/ChangeLog | 5 ++++ gcc/testsuite/gfortran.dg/class_40.f03 | 36 ++++++++++++++++++++++++ 6 files changed, 90 insertions(+), 37 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_40.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 340df016154..8d7614ad510 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2011-02-18 Janus Weil + + 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 PR fortran/47745 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ebba2a814fb..ae1253400f1 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 */ diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 267809c4d77..6f1520c0205 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.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); } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fefb6436c96..1c102437864 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2b4e1fa6ac3..998cfc211fa 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-02-18 Janus Weil + + PR fortran/47767 + * gfortran.dg/class_40.f03: New. + 2011-02-18 Dodji Seketeli PR c++/47208 diff --git a/gcc/testsuite/gfortran.dg/class_40.f03 b/gcc/testsuite/gfortran.dg/class_40.f03 new file mode 100644 index 00000000000..bd367dfe5b5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_40.f03 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR 47767: [OOP] SELECT TYPE fails to execute correct TYPE IS block +! +! Contributed by Andrew Benson + +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" } }