re PR fortran/25056 (non-PURE function should not be a valid argument)
2006-06-25 Paul Thomas <pault@gcc.gnu.org> PR fortran/25056 * interface.c (compare_actual_formal): Signal an error if the formal argument is a pure procedure and the actual is not pure. PR fortran/27554 * resolve.c (resolve_actual_arglist): If the type of procedure passed as an actual argument is not already declared, see if it is an intrinsic. PR fortran/25073 * resolve.c (resolve_select): Use bits 1 and 2 of a new int to keep track of the appearance of constant logical case expressions. Signal an error is either value appears more than once. PR fortran/20874 * resolve.c (resolve_fl_procedure): Signal an error if an elemental function is not scalar valued. PR fortran/20867 * match.c (recursive_stmt_fcn): Perform implicit typing of variables. PR fortran/22038 * match.c (match_forall_iterator): Mark new variables as FL_UNKNOWN if the match fails. PR fortran/28119 * match.c (gfc_match_forall): Remove extraneous call to gfc_match_eos. PR fortran/25072 * resolve.c (resolve_code, resolve_function): Rework forall_flag scheme so that it is set and has a value of 2, when the code->expr (ie. the forall mask) is resolved. This is used to change "block" to "mask" in the non-PURE error message. 2006-06-25 Paul Thomas <pault@gcc.gnu.org> PR fortran/20867 * gfortran.dg/stfunc_3.f90: New test. PR fortran/25056 * gfortran.dg/impure_actual_1.f90: New test. PR fortran/20874 * gfortran.dg/elemental_result_1.f90: New test. PR fortran/25073 * gfortran.dg/select_7.f90: New test. PR fortran/27554 * intrinsic_actual_1.f: New test. PR fortran/22038 PR fortran/28119 * gfortran.dg/forall_4.f90: New test. PR fortran/25072 * gfortran.dg/forall_5.f90: New test. From-SVN: r114987
This commit is contained in:
Paul Thomas
parent
344f237baf
commit
d68bd5a8f2
|
|
@ -1,3 +1,41 @@
|
|||
2006-06-25 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/25056
|
||||
* interface.c (compare_actual_formal): Signal an error if the formal
|
||||
argument is a pure procedure and the actual is not pure.
|
||||
|
||||
PR fortran/27554
|
||||
* resolve.c (resolve_actual_arglist): If the type of procedure
|
||||
passed as an actual argument is not already declared, see if it is
|
||||
an intrinsic.
|
||||
|
||||
PR fortran/25073
|
||||
* resolve.c (resolve_select): Use bits 1 and 2 of a new int to
|
||||
keep track of the appearance of constant logical case expressions.
|
||||
Signal an error is either value appears more than once.
|
||||
|
||||
PR fortran/20874
|
||||
* resolve.c (resolve_fl_procedure): Signal an error if an elemental
|
||||
function is not scalar valued.
|
||||
|
||||
PR fortran/20867
|
||||
* match.c (recursive_stmt_fcn): Perform implicit typing of variables.
|
||||
|
||||
PR fortran/22038
|
||||
* match.c (match_forall_iterator): Mark new variables as
|
||||
FL_UNKNOWN if the match fails.
|
||||
|
||||
PR fortran/28119
|
||||
* match.c (gfc_match_forall): Remove extraneous call to
|
||||
gfc_match_eos.
|
||||
|
||||
PR fortran/25072
|
||||
* resolve.c (resolve_code, resolve_function): Rework
|
||||
forall_flag scheme so that it is set and has a value of
|
||||
2, when the code->expr (ie. the forall mask) is resolved.
|
||||
This is used to change "block" to "mask" in the non-PURE
|
||||
error message.
|
||||
|
||||
2006-06-24 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
PR fortran/28081
|
||||
|
|
|
|||
|
|
@ -1296,6 +1296,17 @@ compare_actual_formal (gfc_actual_arglist ** ap,
|
|||
}
|
||||
}
|
||||
|
||||
if (f->sym->attr.flavor == FL_PROCEDURE
|
||||
&& f->sym->attr.pure
|
||||
&& a->expr->ts.type == BT_PROCEDURE
|
||||
&& !a->expr->symtree->n.sym->attr.pure)
|
||||
{
|
||||
if (where)
|
||||
gfc_error ("Expected a PURE procedure for argument '%s' at %L",
|
||||
f->sym->name, &a->expr->where);
|
||||
return 0;
|
||||
}
|
||||
|
||||
if (f->sym->as
|
||||
&& f->sym->as->type == AS_ASSUMED_SHAPE
|
||||
&& a->expr->expr_type == EXPR_VARIABLE
|
||||
|
|
|
|||
|
|
@ -2802,7 +2802,11 @@ cleanup:
|
|||
|
||||
/* Check that a statement function is not recursive. This is done by looking
|
||||
for the statement function symbol(sym) by looking recursively through its
|
||||
expression(e). If a reference to sym is found, true is returned. */
|
||||
expression(e). If a reference to sym is found, true is returned.
|
||||
12.5.4 requires that any variable of function that is implicitly typed
|
||||
shall have that type confirmed by any subsequent type declaration. The
|
||||
implicit typing is conveniently done here. */
|
||||
|
||||
static bool
|
||||
recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
|
||||
{
|
||||
|
|
@ -2836,11 +2840,17 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
|
|||
&& recursive_stmt_fcn (e->symtree->n.sym->value, sym))
|
||||
return true;
|
||||
|
||||
if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
|
||||
gfc_set_default_type (e->symtree->n.sym, 0, NULL);
|
||||
|
||||
break;
|
||||
|
||||
case EXPR_VARIABLE:
|
||||
if (e->symtree && sym->name == e->symtree->n.sym->name)
|
||||
return true;
|
||||
|
||||
if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
|
||||
gfc_set_default_type (e->symtree->n.sym, 0, NULL);
|
||||
break;
|
||||
|
||||
case EXPR_OP:
|
||||
|
|
@ -3392,6 +3402,13 @@ syntax:
|
|||
m = MATCH_ERROR;
|
||||
|
||||
cleanup:
|
||||
/* Make sure that potential internal function references in the
|
||||
mask do not get messed up. */
|
||||
if (iter->var
|
||||
&& iter->var->expr_type == EXPR_VARIABLE
|
||||
&& iter->var->symtree->n.sym->refs == 1)
|
||||
iter->var->symtree->n.sym->attr.flavor = FL_UNKNOWN;
|
||||
|
||||
gfc_current_locus = where;
|
||||
gfc_free_forall_iterator (iter);
|
||||
return m;
|
||||
|
|
@ -3586,9 +3603,6 @@ gfc_match_forall (gfc_statement * st)
|
|||
*c = new_st;
|
||||
c->loc = gfc_current_locus;
|
||||
|
||||
if (gfc_match_eos () != MATCH_YES)
|
||||
goto syntax;
|
||||
|
||||
gfc_clear_new_st ();
|
||||
new_st.op = EXEC_FORALL;
|
||||
new_st.expr = mask;
|
||||
|
|
|
|||
|
|
@ -829,6 +829,14 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
|
|||
|| sym->attr.external)
|
||||
{
|
||||
|
||||
/* If a procedure is not already determined to be something else
|
||||
check if it is intrinsic. */
|
||||
if (!sym->attr.intrinsic
|
||||
&& !(sym->attr.external || sym->attr.use_assoc
|
||||
|| sym->attr.if_source == IFSRC_IFBODY)
|
||||
&& gfc_intrinsic_name (sym->name, sym->attr.subroutine))
|
||||
sym->attr.intrinsic = 1;
|
||||
|
||||
if (sym->attr.proc == PROC_ST_FUNCTION)
|
||||
{
|
||||
gfc_error ("Statement function '%s' at %L is not allowed as an "
|
||||
|
|
@ -1381,8 +1389,9 @@ resolve_function (gfc_expr * expr)
|
|||
if (forall_flag)
|
||||
{
|
||||
gfc_error
|
||||
("Function reference to '%s' at %L is inside a FORALL block",
|
||||
name, &expr->where);
|
||||
("reference to non-PURE function '%s' at %L inside a "
|
||||
"FORALL %s", name, &expr->where, forall_flag == 2 ?
|
||||
"mask" : "block");
|
||||
t = FAILURE;
|
||||
}
|
||||
else if (gfc_pure (NULL))
|
||||
|
|
@ -3619,6 +3628,7 @@ resolve_select (gfc_code * code)
|
|||
gfc_expr *case_expr;
|
||||
gfc_case *cp, *default_case, *tail, *head;
|
||||
int seen_unreachable;
|
||||
int seen_logical;
|
||||
int ncases;
|
||||
bt type;
|
||||
try t;
|
||||
|
|
@ -3701,6 +3711,7 @@ resolve_select (gfc_code * code)
|
|||
default_case = NULL;
|
||||
head = tail = NULL;
|
||||
ncases = 0;
|
||||
seen_logical = 0;
|
||||
|
||||
for (body = code->block; body; body = body->block)
|
||||
{
|
||||
|
|
@ -3753,6 +3764,21 @@ resolve_select (gfc_code * code)
|
|||
break;
|
||||
}
|
||||
|
||||
if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
|
||||
{
|
||||
int value;
|
||||
value = cp->low->value.logical == 0 ? 2 : 1;
|
||||
if (value & seen_logical)
|
||||
{
|
||||
gfc_error ("constant logical value in CASE statement "
|
||||
"is repeated at %L",
|
||||
&cp->low->where);
|
||||
t = FAILURE;
|
||||
break;
|
||||
}
|
||||
seen_logical |= value;
|
||||
}
|
||||
|
||||
if (cp->low != NULL && cp->high != NULL
|
||||
&& cp->low != cp->high
|
||||
&& gfc_compare_expr (cp->low, cp->high) > 0)
|
||||
|
|
@ -4513,6 +4539,7 @@ static void
|
|||
resolve_code (gfc_code * code, gfc_namespace * ns)
|
||||
{
|
||||
int omp_workshare_save;
|
||||
int forall_save;
|
||||
code_stack frame;
|
||||
gfc_alloc *a;
|
||||
try t;
|
||||
|
|
@ -4524,14 +4551,13 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
|
|||
for (; code; code = code->next)
|
||||
{
|
||||
frame.current = code;
|
||||
forall_save = forall_flag;
|
||||
|
||||
if (code->op == EXEC_FORALL)
|
||||
{
|
||||
int forall_save = forall_flag;
|
||||
|
||||
forall_flag = 1;
|
||||
gfc_resolve_forall (code, ns, forall_save);
|
||||
forall_flag = forall_save;
|
||||
forall_flag = 2;
|
||||
}
|
||||
else if (code->block)
|
||||
{
|
||||
|
|
@ -4567,6 +4593,8 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
|
|||
}
|
||||
|
||||
t = gfc_resolve_expr (code->expr);
|
||||
forall_flag = forall_save;
|
||||
|
||||
if (gfc_resolve_expr (code->expr2) == FAILURE)
|
||||
t = FAILURE;
|
||||
|
||||
|
|
@ -5181,6 +5209,16 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
|
|||
return FAILURE;
|
||||
}
|
||||
|
||||
/* An elemental function is required to return a scalar 12.7.1 */
|
||||
if (sym->attr.elemental && sym->attr.function && sym->as)
|
||||
{
|
||||
gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
|
||||
"result", sym->name, &sym->declared_at);
|
||||
/* Reset so that the error only occurs once. */
|
||||
sym->attr.elemental = 0;
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* 5.1.1.5 of the Standard: A function name declared with an asterisk
|
||||
char-len-param shall not be array-valued, pointer-valued, recursive
|
||||
or pure. ....snip... A character value of * may only be used in the
|
||||
|
|
|
|||
|
|
@ -1,3 +1,27 @@
|
|||
2006-06-25 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/20867
|
||||
* gfortran.dg/stfunc_3.f90: New test.
|
||||
|
||||
PR fortran/25056
|
||||
* gfortran.dg/impure_actual_1.f90: New test.
|
||||
|
||||
PR fortran/20874
|
||||
* gfortran.dg/elemental_result_1.f90: New test.
|
||||
|
||||
PR fortran/25073
|
||||
* gfortran.dg/select_7.f90: New test.
|
||||
|
||||
PR fortran/27554
|
||||
* intrinsic_actual_1.f: New test.
|
||||
|
||||
PR fortran/22038
|
||||
PR fortran/28119
|
||||
* gfortran.dg/forall_4.f90: New test.
|
||||
|
||||
PR fortran/25072
|
||||
* gfortran.dg/forall_5.f90: New test.
|
||||
|
||||
2006-06-25 Lee Millward <lee.millward@gmail.com>
|
||||
|
||||
PR c++/28051
|
||||
|
|
|
|||
|
|
@ -0,0 +1,21 @@
|
|||
! { dg-do compile }
|
||||
! Tests the fix for PR20874 in which array valued elemental
|
||||
! functions were permitted.
|
||||
!
|
||||
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
|
||||
!
|
||||
MODULE Test
|
||||
CONTAINS
|
||||
ELEMENTAL FUNCTION LL(I) ! { dg-error "must have a scalar result" }
|
||||
INTEGER, INTENT(IN) :: I
|
||||
INTEGER :: LL(2)
|
||||
END FUNCTION LL
|
||||
!
|
||||
! This was already OK.
|
||||
!
|
||||
ELEMENTAL FUNCTION MM(I)
|
||||
INTEGER, INTENT(IN) :: I
|
||||
INTEGER, pointer :: MM ! { dg-error "conflicts with ELEMENTAL" }
|
||||
END FUNCTION MM
|
||||
END MODULE Test
|
||||
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
! { dg-do run }
|
||||
! Tests the fix for PR25072, in which mask expressions
|
||||
! that start with an internal or intrinsic function
|
||||
! reference would give a syntax error.
|
||||
!
|
||||
! The fix for PR28119 is tested as well; here, the forall
|
||||
! statement could not be followed by another statement on
|
||||
! the same line.
|
||||
!
|
||||
! Contributed by Paul Thomas <pault@gcc.gnu.org>
|
||||
!
|
||||
module foo
|
||||
integer, parameter :: n = 4
|
||||
contains
|
||||
pure logical function foot (i)
|
||||
integer, intent(in) :: i
|
||||
foot = (i == 2) .or. (i == 3)
|
||||
end function foot
|
||||
end module foo
|
||||
|
||||
use foo
|
||||
integer :: i, a(n)
|
||||
logical :: s(n)
|
||||
s = (/(foot (i), i=1, n)/)
|
||||
|
||||
! Check that non-mask case is still OK and the fix for PR28119
|
||||
a = 0
|
||||
forall (i=1:n) a(i) = i ; if (any (a .ne. (/1,2,3,4/))) call abort ()
|
||||
|
||||
! Now a mask using a function with an explicit interface
|
||||
! via use association.
|
||||
a = 0
|
||||
forall (i=1:n, foot (i)) a(i) = i
|
||||
if (any (a .ne. (/0,2,3,0/))) call abort ()
|
||||
|
||||
! Now an array variable mask
|
||||
a = 0
|
||||
forall (i=1:n, .not. s(i)) a(i) = i
|
||||
if (any (a .ne. (/1,0,0,4/))) call abort ()
|
||||
|
||||
! This was the PR - an internal function mask
|
||||
a = 0
|
||||
forall (i=1:n, t (i)) a(i) = i
|
||||
if (any (a .ne. (/0,2,0,4/))) call abort ()
|
||||
|
||||
! Check that an expression is OK - this also gave a syntax
|
||||
! error
|
||||
a = 0
|
||||
forall (i=1:n, mod (i, 2) == 0) a(i) = i
|
||||
if (any (a .ne. (/0,2,0,4/))) call abort ()
|
||||
|
||||
! And that an expression that used to work is OK
|
||||
a = 0
|
||||
forall (i=1:n, s (i) .or. t(i)) a(i) = w (i)
|
||||
if (any (a .ne. (/0,3,2,1/))) call abort ()
|
||||
|
||||
contains
|
||||
pure logical function t(i)
|
||||
integer, intent(in) :: i
|
||||
t = (mod (i, 2) == 0)
|
||||
end function t
|
||||
pure integer function w(i)
|
||||
integer, intent(in) :: i
|
||||
w = 5 - i
|
||||
end function w
|
||||
end
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
! { dg-do compile }
|
||||
! Tests the fix for PR25072, in which non-PURE functions could
|
||||
! be referenced inside a FORALL mask.
|
||||
!
|
||||
! Contributed by Paul Thomas <pault@gcc.gnu.org>
|
||||
!
|
||||
module foo
|
||||
integer, parameter :: n = 4
|
||||
contains
|
||||
logical function foot (i)
|
||||
integer, intent(in) :: i
|
||||
foot = (i == 2) .or. (i == 3)
|
||||
end function foot
|
||||
end module foo
|
||||
|
||||
use foo
|
||||
integer :: i, a(n)
|
||||
logical :: s(n)
|
||||
|
||||
a = 0
|
||||
forall (i=1:n, foot (i)) a(i) = i ! { dg-error "non-PURE" }
|
||||
if (any (a .ne. (/0,2,3,0/))) call abort ()
|
||||
|
||||
forall (i=1:n, s (i) .or. t(i)) a(i) = i ! { dg-error "non-PURE|LOGICAL" }
|
||||
if (any (a .ne. (/0,3,2,1/))) call abort ()
|
||||
|
||||
a = 0
|
||||
forall (i=1:n, mod (i, 2) == 0) a(i) = w (i) ! { dg-error "non-PURE" }
|
||||
if (any (a .ne. (/0,2,0,4/))) call abort ()
|
||||
|
||||
contains
|
||||
logical function t(i)
|
||||
integer, intent(in) :: i
|
||||
t = (mod (i, 2) == 0)
|
||||
end function t
|
||||
integer function w(i)
|
||||
integer, intent(in) :: i
|
||||
w = 5 - i
|
||||
end function w
|
||||
end
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
! { dg-do compile }
|
||||
! Tests the fix for PR25056 in which a non-PURE procedure could be
|
||||
! passed as the actual argument to a PURE procedure.
|
||||
!
|
||||
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
|
||||
!
|
||||
MODULE M1
|
||||
CONTAINS
|
||||
FUNCTION L()
|
||||
L=1
|
||||
END FUNCTION L
|
||||
PURE FUNCTION J(K)
|
||||
INTERFACE
|
||||
PURE FUNCTION K()
|
||||
END FUNCTION K
|
||||
END INTERFACE
|
||||
J=K()
|
||||
END FUNCTION J
|
||||
END MODULE M1
|
||||
USE M1
|
||||
write(6,*) J(L) ! { dg-error "Expected a PURE procedure for argument" }
|
||||
END
|
||||
|
||||
! { dg-final { cleanup-modules "M1" } }
|
||||
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
! { dg-do compile }
|
||||
! Tests the fix for PR27554, where the actual argument reference
|
||||
! to abs would not be recognised as being to an intrinsic
|
||||
! procedure and would produce junk in the assembler.
|
||||
!
|
||||
! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
!
|
||||
subroutine foo (proc, z)
|
||||
external proc
|
||||
real proc, z
|
||||
if ((proc(z) .ne. abs (z)) .and.
|
||||
& (proc(z) .ne. alog10 (abs(z)))) call abort ()
|
||||
return
|
||||
end
|
||||
|
||||
external cos
|
||||
interface
|
||||
function sin (a)
|
||||
real a, sin
|
||||
end function sin
|
||||
end interface
|
||||
|
||||
|
||||
intrinsic alog10
|
||||
real x
|
||||
x = 100.
|
||||
! The reference here would prevent the actual arg from being seen
|
||||
! as an intrinsic procedure in the call to foo.
|
||||
x = -abs(x)
|
||||
call foo(abs, x)
|
||||
! The intrinsic function can be locally over-ridden by an interface
|
||||
call foo(sin, x)
|
||||
! or an external declaration.
|
||||
call foo(cos, x)
|
||||
! Just make sure with another intrinsic but this time not referenced.
|
||||
call foo(alog10, -x)
|
||||
end
|
||||
|
||||
function sin (a)
|
||||
real a, sin
|
||||
sin = -a
|
||||
return
|
||||
end
|
||||
|
||||
function cos (a)
|
||||
real a, cos
|
||||
cos = -a
|
||||
return
|
||||
end
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
! { dg-do compile }
|
||||
! Tests the fix for PR25073 in which overlap in logical case
|
||||
! expressions was permitted.
|
||||
!
|
||||
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
|
||||
!
|
||||
LOGICAL :: L
|
||||
SELECT CASE(L)
|
||||
CASE(.true.)
|
||||
CASE(.false.)
|
||||
CASE(.true.) ! { dg-error "value in CASE statement is repeated" }
|
||||
END SELECT
|
||||
END
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
! { dg-do compile }
|
||||
! Tests the fix for PR20867 in which implicit typing was not done within
|
||||
! statement functions and so was not confirmed or not by subsequent
|
||||
! type delarations.
|
||||
!
|
||||
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
|
||||
!
|
||||
REAL :: st1
|
||||
st1(I)=I**2
|
||||
REAL :: I ! { dg-error " already has basic type of INTEGER" }
|
||||
END
|
||||
|
||||
|
||||
Loading…
Reference in New Issue