From: Paul Thomas Date: Mon, 3 Nov 2008 06:44:47 +0000 (+0000) Subject: re PR fortran/37445 (Host-associated proc not found if same-name generic is use-assoc... X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=67cec813c625940ddf829c57f4bfd1c14fd7e563;p=platform%2Fupstream%2Fgcc.git re PR fortran/37445 (Host-associated proc not found if same-name generic is use-associated) 2008-11-03 Paul Thomas PR fortran/37445 * resolve.c (resolve_actual_arglist ): Correct comparison of FL_VARIABLE with e->expr_type. (resolve_call): Check that host association is correct. (resolve_actual_arglist ): Remove return is old_sym is use associated. Only reparse expression if old and new symbols have different types. PR fortran/PR35769 * resolve.c (gfc_resolve_assign_in_forall): Change error to a warning. 2008-11-03 Paul Thomas PR fortran/37445 * gfortran.dg/host_assoc_call_3.f90: New test. * gfortran.dg/host_assoc_call_4.f90: New test. * gfortran.dg/host_assoc_function_4.f90: New test. From-SVN: r141543 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 49b9e3f..9017b79 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2008-11-03 Paul Thomas + + PR fortran/37445 + * resolve.c (resolve_actual_arglist ): Correct comparison of + FL_VARIABLE with e->expr_type. + (resolve_call): Check that host association is correct. + (resolve_actual_arglist ): Remove return is old_sym is use + associated. Only reparse expression if old and new symbols + have different types. + + PR fortran/PR35769 + * resolve.c (gfc_resolve_assign_in_forall): Change error to a + warning. + 2008-11-01 Janus Weil PR fortran/36426 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bf21416..4774b0b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1105,7 +1105,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, continue; } - if (e->expr_type == FL_VARIABLE + if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.generic && no_formal_args && count_specific_procs (e) != 1) @@ -2857,7 +2857,7 @@ resolve_call (gfc_code *c) { gfc_try t; procedure_type ptype = PROC_INTRINSIC; - gfc_symbol *csym; + gfc_symbol *csym, *sym; bool no_formal_args; csym = c->symtree ? c->symtree->n.sym : NULL; @@ -2869,6 +2869,20 @@ resolve_call (gfc_code *c) return FAILURE; } + if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns) + { + gfc_find_symbol (csym->name, gfc_current_ns, 1, &sym); + if (sym && csym != sym + && sym->ns == gfc_current_ns + && sym->attr.flavor == FL_PROCEDURE + && sym->attr.contained) + { + sym->refs++; + csym = sym; + c->symtree->n.sym = sym; + } + } + /* If external, check for usage. */ if (csym && is_external_proc (csym)) resolve_global_procedure (csym, &c->loc, 1); @@ -4248,14 +4262,12 @@ check_host_association (gfc_expr *e) old_sym = e->symtree->n.sym; - if (old_sym->attr.use_assoc) - return retval; - if (gfc_current_ns->parent && old_sym->ns != gfc_current_ns) { gfc_find_symbol (old_sym->name, gfc_current_ns, 1, &sym); if (sym && old_sym != sym + && sym->ts.type == old_sym->ts.type && sym->attr.flavor == FL_PROCEDURE && sym->attr.contained) { @@ -6117,12 +6129,14 @@ gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) else { /* If one of the FORALL index variables doesn't appear in the - assignment target, then there will be a many-to-one - assignment. */ + assignment variable, then there could be a many-to-one + assignment. Emit a warning rather than an error because the + mask could be resolving this problem. */ if (find_forall_index (code->expr, forall_index, 0) == FAILURE) - gfc_error ("The FORALL with index '%s' cause more than one " - "assignment to this object at %L", - var_expr[n]->symtree->name, &code->expr->where); + gfc_warning ("The FORALL with index '%s' is not used on the " + "left side of the assignment at %L and so might " + "cause multiple assignment to this object", + var_expr[n]->symtree->name, &code->expr->where); } } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e7c3464..7609084 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2008-11-03 Paul Thomas + + PR fortran/37445 + * gfortran.dg/host_assoc_call_3.f90: New test. + * gfortran.dg/host_assoc_call_4.f90: New test. + * gfortran.dg/host_assoc_function_4.f90: New test. + 2008-11-02 Richard Guenther PR tree-optimization/37542 diff --git a/gcc/testsuite/gfortran.dg/host_assoc_call_3.f90 b/gcc/testsuite/gfortran.dg/host_assoc_call_3.f90 new file mode 100644 index 0000000..6646270 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/host_assoc_call_3.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! +! PR fortran/37445, in which the contained 'putaline' would be +! ignored and no specific interface found in the generic version. +! +! Contributed by Norman S Clerman < clerman@fuse.net> +! +MODULE M1 + INTERFACE putaline + MODULE PROCEDURE S1,S2 + END INTERFACE +CONTAINS + SUBROUTINE S1(I) + END SUBROUTINE + SUBROUTINE S2(F) + END SUBROUTINE +END MODULE + +MODULE M2 + USE M1 +CONTAINS + SUBROUTINE S3 + integer :: check = 0 + CALL putaline() + if (check .ne. 1) call abort + CALL putaline("xx") + if (check .ne. 2) call abort +! CALL putaline(1.0) ! => this now causes an error, as it should + CONTAINS + SUBROUTINE putaline(x) + character, optional :: x + if (present(x)) then + check = 2 + else + check = 1 + end if + END SUBROUTINE + END SUBROUTINE +END MODULE + + USE M2 + CALL S3 +END +! { dg-final { cleanup-modules "M1 M2" } } diff --git a/gcc/testsuite/gfortran.dg/host_assoc_call_4.f90 b/gcc/testsuite/gfortran.dg/host_assoc_call_4.f90 new file mode 100644 index 0000000..f97a644 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/host_assoc_call_4.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! +! PR fortran/37445, in which the first version of the fix regressed on the +! calls to GetBasicElementData; picking up the local GetBasicElementData instead. +! +! Contributed by Norman S Clerman < clerman@fuse.net> +! and reduced by Tobias Burnus +! +MODULE ErrElmnt + IMPLICIT NONE + TYPE :: TErrorElement + integer :: i + end type TErrorElement +contains + subroutine GetBasicData ( AnElement, ProcedureName, ErrorNumber, & + Level, Message, ReturnStat) + type (TErrorElement) :: AnElement + character (*, 1), optional :: & + ProcedureName + integer (4), optional :: ErrorNumber + character (*, 1), optional :: Level + character (*, 1), optional :: Message + integer (4), optional :: ReturnStat + end subroutine GetBasicData +end module ErrElmnt + +MODULE ErrorMod + USE ErrElmnt, only: GetBasicElementData => GetBasicData , TErrorElement + IMPLICIT NONE +contains + subroutine GetBasicData () + integer (4) :: CallingStat, LocalErrorNum + character (20, 1) :: LocalErrorMessage + character (20, 1) :: LocalProcName + character (20, 1) :: Locallevel + type (TErrorElement) :: AnElement + call GetBasicElementData (AnElement, LocalProcName, LocalErrorNum, LocalLevel, LocalErrorMessage, CallingStat) + end subroutine GetBasicData + SUBROUTINE WH_ERR () + integer (4) :: ErrorNumber, CallingStat + character (20, 1) :: ProcedureName + character (20, 1) :: ErrorLevel + character (20, 1) :: ErrorMessage + type (TErrorElement) :: TargetElement + call GetBasicElementData (TargetElement, ProcedureName, ErrorNumber, ErrorLevel, ErrorMessage, CallingStat) + end subroutine WH_ERR +end module ErrorMod +! { dg-final { cleanup-modules "ErrElmnt ErrorMod" } } diff --git a/gcc/testsuite/gfortran.dg/host_assoc_function_4.f90 b/gcc/testsuite/gfortran.dg/host_assoc_function_4.f90 new file mode 100644 index 0000000..799eb00 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/host_assoc_function_4.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! PR fortran/37445, in which the contained 's1' would be +! ignored and the use+host associated version used. +! +! Contributed by Norman S Clerman < clerman@fuse.net> +! +MODULE M1 +CONTAINS + integer function S1 () + s1 = 0 + END function +END MODULE + +MODULE M2 + USE M1 +CONTAINS + SUBROUTINE S2 + if (s1 () .ne. 1) call abort + CONTAINS + integer function S1 () + s1 = 1 + END function + END SUBROUTINE +END MODULE + + USE M2 + CALL S2 +END +! { dg-final { cleanup-modules "M1 M2" } }