aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog15
-rw-r--r--gcc/fortran/gfortran.h2
-rw-r--r--gcc/fortran/module.c31
-rw-r--r--gcc/fortran/resolve.c38
-rw-r--r--gcc/testsuite/ChangeLog5
-rw-r--r--gcc/testsuite/gfortran.dg/class_40.f0336
6 files changed, 90 insertions, 37 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 340df01..8d7614a 100644
--- 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 ebba2a8..ae12534 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 267809c..6f1520c 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 fefb643..1c10243 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 2b4e1fa..998cfc2 100644
--- 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
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" } }
generated by cgit v1.1 at 2024-11-03 05:06:42 +0000