2008-11-03 Paul Thomas <pault@gcc.gnu.org>
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 <pault@gcc.gnu.org>
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
+2008-11-03 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <janus@gcc.gnu.org>
PR fortran/36426
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)
{
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;
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);
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)
{
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);
}
}
}
+2008-11-03 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <rguenther@suse.de>
PR tree-optimization/37542
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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 <burnus@gcc.gnu.org>
+!
+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" } }
--- /dev/null
+! { 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" } }
projects / gcc.git / commitdiff