From aa84a9a5e414aad8acbbdf4efae1f951bc9a1de7 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 4 Aug 2007 20:46:11 +0000 Subject: [PATCH] re PR fortran/31214 (User-defined operator using entry leads to ICE) 2007-08-04 Paul Thomas PR fortran/31214 * symbol.c (get_unique_symtree): Moved from module.c. * module.c (get_unique_symtree): Moved to symbol.c. * decl.c (get_proc_name): Transfer the typespec from the local symbol to the module symbol, in the case that an entry is also a module procedure. Ensure the local symbol is cleaned up by pointing to it with a unique symtree. * dump_parse_tree (gfc_show_code_node): Add EXEC_ASSIGN_CALL. 2007-08-04 Paul Thomas PR fortran/31214 * gfortran.dg/entry_13.f90: New test. * gfortran.dg/entry_12.f90: Clean up .mod file. From-SVN: r127213 --- gcc/fortran/ChangeLog | 7 +++ gcc/fortran/decl.c | 19 ++++++ gcc/fortran/dump-parse-tree.c | 1 + gcc/fortran/gfortran.h | 1 + gcc/fortran/module.c | 20 +------ gcc/fortran/symbol.c | 14 +++++ gcc/testsuite/ChangeLog | 11 ++-- gcc/testsuite/gfortran.dg/entry_12.f90 | 61 ++++++++++---------- gcc/testsuite/gfortran.dg/entry_13.f90 | 80 ++++++++++++++++++++++++++ 9 files changed, 161 insertions(+), 53 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/entry_13.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2e29300e7be..e9b2ed30682 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2007-08-04 Paul Thomas + + 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 PR fortran/32969 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index a94085fce18..d674aeb92e1 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 c99fc425375..ac6a6f5d7b8 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 a87366f8e49..329fae2103f 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 fc30eae7732..baba5c7434c 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 40e3435521e..3aae04c4923 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 d18f3b94d69..3dabc56d37c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,10 +1,9 @@ -2007-08-04 Thomas Koenig +2007-08-04 Paul Thomas - 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 diff --git a/gcc/testsuite/gfortran.dg/entry_12.f90 b/gcc/testsuite/gfortran.dg/entry_12.f90 index 8793b42520e..5513697a17c 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 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 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 00000000000..2d2aedaf3d8 --- /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 +! +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" } } +