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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@114987
138bc75d-0d04-0410-961f-
82ee72b054a4
+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
}
}
+ 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
/* 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)
{
&& 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:
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;
*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;
|| 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 "
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))
gfc_expr *case_expr;
gfc_case *cp, *default_case, *tail, *head;
int seen_unreachable;
+ int seen_logical;
int ncases;
bt type;
try t;
default_case = NULL;
head = tail = NULL;
ncases = 0;
+ seen_logical = 0;
for (body = code->block; body; body = body->block)
{
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)
resolve_code (gfc_code * code, gfc_namespace * ns)
{
int omp_workshare_save;
+ int forall_save;
code_stack frame;
gfc_alloc *a;
try t;
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)
{
}
t = gfc_resolve_expr (code->expr);
+ forall_flag = forall_save;
+
if (gfc_resolve_expr (code->expr2) == FAILURE)
t = FAILURE;
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
+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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
+
OSDN Git Service
