aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog7
-rw-r--r--gcc/fortran/decl.c19
-rw-r--r--gcc/fortran/dump-parse-tree.c1
-rw-r--r--gcc/fortran/gfortran.h1
-rw-r--r--gcc/fortran/module.c20
-rw-r--r--gcc/fortran/symbol.c14
-rw-r--r--gcc/testsuite/ChangeLog11
-rw-r--r--gcc/testsuite/gfortran.dg/entry_12.f9061
-rw-r--r--gcc/testsuite/gfortran.dg/entry_13.f9080
9 files changed, 161 insertions, 53 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2e29300..e9b2ed3 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2007-08-04 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/31214
+ * gfortran.dg/entry_13.f90: New test.
+
+ * gfortran.dg/entry_12.f90: Clean up .mod file.
+
2008-08-04 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/32969
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index a94085f..d674aeb 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -681,8 +681,27 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
{
/* Present if entry is declared to be a module procedure. */
rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
+
if (*result == NULL)
rc = gfc_get_symbol (name, NULL, result);
+ else if (gfc_get_symbol (name, NULL, &sym) == 0
+ && sym
+ && sym->ts.type != BT_UNKNOWN
+ && (*result)->ts.type == BT_UNKNOWN
+ && sym->attr.flavor == FL_UNKNOWN)
+ /* Pick up the typespec for the entry, if declared in the function
+ body. Note that this symbol is FL_UNKNOWN because it will
+ only have appeared in a type declaration. The local symtree
+ is set to point to the module symbol and a unique symtree
+ to the local version. This latter ensures a correct clearing
+ of the symbols. */
+ {
+ (*result)->ts = sym->ts;
+ gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
+ st->n.sym = *result;
+ st = gfc_get_unique_symtree (gfc_current_ns);
+ st->n.sym = sym;
+ }
}
else
rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index c99fc42..ac6a6f5 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1084,6 +1084,7 @@ gfc_show_code_node (int level, gfc_code *c)
break;
case EXEC_CALL:
+ case EXEC_ASSIGN_CALL:
if (c->resolved_sym)
gfc_status ("CALL %s ", c->resolved_sym->name);
else if (c->symtree)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a87366f..329fae2 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2124,6 +2124,7 @@ gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *);
gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
+gfc_symtree *gfc_get_unique_symtree (gfc_namespace *);
gfc_user_op *gfc_get_uop (const char *);
gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
void gfc_free_symbol (gfc_symbol *);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index fc30eae..baba5c7 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1822,20 +1822,6 @@ mio_charlen (gfc_charlen **clp)
}
-/* Return a symtree node with a name that is guaranteed to be unique
- within the namespace and corresponds to an illegal fortran name. */
-
-static gfc_symtree *
-get_unique_symtree (gfc_namespace *ns)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- static int serial = 0;
-
- sprintf (name, "@%d", serial++);
- return gfc_new_symtree (&ns->sym_root, name);
-}
-
-
/* See if a name is a generated name. */
static int
@@ -2287,7 +2273,7 @@ mio_symtree_ref (gfc_symtree **stp)
if (in_load_equiv && p->u.rsym.symtree == NULL)
{
/* Since this is not used, it must have a unique name. */
- p->u.rsym.symtree = get_unique_symtree (gfc_current_ns);
+ p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
/* Make the symbol. */
if (p->u.rsym.sym == NULL)
@@ -3418,7 +3404,7 @@ read_cleanup (pointer_info *p)
{
/* Add hidden symbols to the symtree. */
q = get_integer (p->u.rsym.ns);
- st = get_unique_symtree ((gfc_namespace *) q->u.pointer);
+ st = gfc_get_unique_symtree ((gfc_namespace *) q->u.pointer);
st->n.sym = p->u.rsym.sym;
st->n.sym->refs++;
@@ -3598,7 +3584,7 @@ read_module (void)
/* Create a symtree node in the current namespace for this
symbol. */
st = check_unique_name (p)
- ? get_unique_symtree (gfc_current_ns)
+ ? gfc_get_unique_symtree (gfc_current_ns)
: gfc_new_symtree (&gfc_current_ns->sym_root, p);
st->ambiguous = ambiguous;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 40e3435..3aae04c 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2129,6 +2129,20 @@ gfc_find_symtree (gfc_symtree *st, const char *name)
}
+/* Return a symtree node with a name that is guaranteed to be unique
+ within the namespace and corresponds to an illegal fortran name. */
+
+gfc_symtree *
+gfc_get_unique_symtree (gfc_namespace *ns)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ static int serial = 0;
+
+ sprintf (name, "@%d", serial++);
+ return gfc_new_symtree (&ns->sym_root, name);
+}
+
+
/* Given a name find a user operator node, creating it if it doesn't
exist. These are much simpler than symbols because they can't be
ambiguous with one another. */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d18f3b9..3dabc56 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,10 +1,9 @@
-2007-08-04 Thomas Koenig <tkoenig@gcc.gnu.org>
+2007-08-04 Paul Thomas <pault@gcc.gnu.org>
- PR fortran/32770
- * gfortran.dg/streamio_8.f90: Adjust so test case passes
- for -fdefault-integer-8 and -fdefault-real-8.
- * gfortran.dg/streamio_10.f90: Likewise.
- * gfortran.dg/sizeof.f90: Likewise.
+ PR fortran/31214
+ * gfortran.dg/entry_13.f90: New test.
+
+ * gfortran.dg/entry_12.f90: Clean up .mod file.
2007-08-04 Thomas Koenig <tkoenig@gcc.gnu.org>
diff --git a/gcc/testsuite/gfortran.dg/entry_12.f90 b/gcc/testsuite/gfortran.dg/entry_12.f90
index 8793b42..5513697 100644
--- a/gcc/testsuite/gfortran.dg/entry_12.f90
+++ b/gcc/testsuite/gfortran.dg/entry_12.f90
@@ -1,30 +1,31 @@
-! { dg-do run }
-! Tests the fix for pr31609, where module procedure entries found
-! themselves in the wrong namespace. This test checks that all
-! combinations of generic and specific calls work correctly.
-!
-! Contributed by Paul Thomas <pault@gcc.gnu.org> as comment #8 to the pr.
-!
-MODULE ksbin1_aux_mod
- interface foo
- module procedure j
- end interface
- interface bar
- module procedure k
- end interface
- interface foobar
- module procedure j, k
- end interface
- CONTAINS
- FUNCTION j ()
- j = 1
- return
- ENTRY k (i)
- k = 2
- END FUNCTION j
-END MODULE ksbin1_aux_mod
-
- use ksbin1_aux_mod
- if (any ((/foo (), bar (99), foobar (), foobar (99), j (), k (99)/) .ne. &
- (/1, 2, 1, 2, 1, 2/))) Call abort ()
-end
+! { dg-do run }
+! Tests the fix for pr31609, where module procedure entries found
+! themselves in the wrong namespace. This test checks that all
+! combinations of generic and specific calls work correctly.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org> as comment #8 to the pr.
+!
+MODULE ksbin1_aux_mod
+ interface foo
+ module procedure j
+ end interface
+ interface bar
+ module procedure k
+ end interface
+ interface foobar
+ module procedure j, k
+ end interface
+ CONTAINS
+ FUNCTION j ()
+ j = 1
+ return
+ ENTRY k (i)
+ k = 2
+ END FUNCTION j
+END MODULE ksbin1_aux_mod
+
+ use ksbin1_aux_mod
+ if (any ((/foo (), bar (99), foobar (), foobar (99), j (), k (99)/) .ne. &
+ (/1, 2, 1, 2, 1, 2/))) Call abort ()
+end
+! { dg-final { cleanup-modules "ksbin1_aux_mod" } }
diff --git a/gcc/testsuite/gfortran.dg/entry_13.f90 b/gcc/testsuite/gfortran.dg/entry_13.f90
new file mode 100644
index 0000000..2d2aeda
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/entry_13.f90
@@ -0,0 +1,80 @@
+! { dg-do run }
+! Tests the fix for pr31214, in which the typespec for the entry would be lost,
+! thereby causing the function to be disallowed, since the function and entry
+! types did not match.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+module type_mod
+ implicit none
+
+ type x
+ real x
+ end type x
+ type y
+ real x
+ end type y
+ type z
+ real x
+ end type z
+
+ interface assignment(=)
+ module procedure equals
+ end interface assignment(=)
+
+ interface operator(//)
+ module procedure a_op_b, b_op_a
+ end interface operator(//)
+
+ interface operator(==)
+ module procedure a_po_b, b_po_a
+ end interface operator(==)
+
+ contains
+ subroutine equals(x,y)
+ type(z), intent(in) :: y
+ type(z), intent(out) :: x
+
+ x%x = y%x
+ end subroutine equals
+
+ function a_op_b(a,b)
+ type(x), intent(in) :: a
+ type(y), intent(in) :: b
+ type(z) a_op_b
+ type(z) b_op_a
+ a_op_b%x = a%x + b%x
+ return
+ entry b_op_a(b,a)
+ b_op_a%x = a%x - b%x
+ end function a_op_b
+
+ function a_po_b(a,b)
+ type(x), intent(in) :: a
+ type(y), intent(in) :: b
+ type(z) a_po_b
+ type(z) b_po_a
+ entry b_po_a(b,a)
+ a_po_b%x = a%x/b%x
+ end function a_po_b
+end module type_mod
+
+program test
+ use type_mod
+ implicit none
+ type(x) :: x1 = x(19.0_4)
+ type(y) :: y1 = y(7.0_4)
+ type(z) z1
+
+ z1 = x1//y1
+ if (z1%x .ne. 19.0_4 + 7.0_4) call abort ()
+ z1 = y1//x1
+ if (z1%x .ne. 19.0_4 - 7.0_4) call abort ()
+
+ z1 = x1==y1
+ if (z1%x .ne. 19.0_4/7.0_4) call abort ()
+ z1 = y1==x1
+ if (z1%x .ne. 19.0_4/7.0_4) call abort ()
+end program test
+! { dg-final { cleanup-modules "type_mod" } }
+
generated by cgit v1.1 at 2024-10-20 19:35:46 +0000