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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 340df016154f0c2623cf402c73a20a9fa18f6d4c..8d7614ad5109ad1f2b7d5274ad289df8e80a5333 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ebba2a814fb48cc0c4b8c1d453137835ec4f28fc..ae1253400f1d75d65533b8a722c72d20a563e2d0 100644 (file)
--- 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 267809c4d77c09f982393608feb3f21353f0763b..6f1520c0205eff9d2649035ba7180fda0226c078 100644 (file)
--- 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 fefb6436c96031ac68451aaac6bcda979e7d98e1..1c1024378645793b6b8f0927693b196dd166a48e 100644 (file)
--- 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 2b4e1fa6ac39325cb0ce98d0df7a8539ba8fa87b..998cfc211fab62bc66ec865d6c216be60fa2f73e 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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

diff --git a/gcc/testsuite/gfortran.dg/class_40.f03 b/gcc/testsuite/gfortran.dg/class_40.f03
new file mode 100644 (file)
index 0000000..bd367df
--- /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 <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" } }