Index: gcc/fortran/interface.c =================================================================== *** gcc/fortran/interface.c (revision 114823) --- gcc/fortran/interface.c (working copy) *************** compare_actual_formal (gfc_actual_arglis *** 1296,1301 **** --- 1296,1312 ---- } } + 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 Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 114823) --- gcc/fortran/resolve.c (working copy) *************** resolve_actual_arglist (gfc_actual_argli *** 829,834 **** --- 829,842 ---- || 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 " *************** resolve_select (gfc_code * code) *** 3615,3620 **** --- 3623,3629 ---- gfc_expr *case_expr; gfc_case *cp, *default_case, *tail, *head; int seen_unreachable; + int seen_logical; int ncases; bt type; try t; *************** resolve_select (gfc_code * code) *** 3697,3702 **** --- 3706,3712 ---- default_case = NULL; head = tail = NULL; ncases = 0; + seen_logical = 0; for (body = code->block; body; body = body->block) { *************** resolve_select (gfc_code * code) *** 3749,3754 **** --- 3759,3777 ---- break; } + if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT) + { + if (cp->low->value.logical & seen_logical) + { + gfc_error ("constant logical value in CASE statement " + "is repeated at %L", + &cp->low->where); + t = FAILURE; + break; + } + seen_logical |= cp->low->value.logical == 0 ? 2 : 1; + } + if (cp->low != NULL && cp->high != NULL && cp->low != cp->high && gfc_compare_expr (cp->low, cp->high) > 0) *************** resolve_fl_procedure (gfc_symbol *sym, i *** 5177,5182 **** --- 5200,5215 ---- 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 Index: gcc/fortran/match.c =================================================================== *** gcc/fortran/match.c (revision 114823) --- gcc/fortran/match.c (working copy) *************** cleanup: *** 2796,2802 **** /* 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. */ static bool recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) { --- 2796,2806 ---- /* 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. ! 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 (gfc_expr *e, gfc_sym *** 2830,2840 **** --- 2834,2850 ---- && 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: Index: gcc/testsuite/gfortran.dg/stfunc_3.f90 =================================================================== *** gcc/testsuite/gfortran.dg/stfunc_3.f90 (revision 0) --- gcc/testsuite/gfortran.dg/stfunc_3.f90 (revision 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 + ! + REAL :: st1 + st1(I)=I**2 + REAL :: I ! { dg-error " already has basic type of INTEGER" } + END + + Index: gcc/testsuite/gfortran.dg/impure_actual_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/impure_actual_1.f90 (revision 0) --- gcc/testsuite/gfortran.dg/impure_actual_1.f90 (revision 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 + ! + 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" } } + Index: gcc/testsuite/gfortran.dg/elemental_result_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/elemental_result_1.f90 (revision 0) --- gcc/testsuite/gfortran.dg/elemental_result_1.f90 (revision 0) *************** *** 0 **** --- 1,21 ---- + ! { dg-do compile } + ! Tests the fix for PR20874 in which array valued elemental + ! functions were permitted. + ! + ! Contributed by Joost VandeVondele + ! + 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 + Index: gcc/testsuite/gfortran.dg/select_7.f90 =================================================================== *** gcc/testsuite/gfortran.dg/select_7.f90 (revision 0) --- gcc/testsuite/gfortran.dg/select_7.f90 (revision 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 + ! + LOGICAL :: L + SELECT CASE(L) + CASE(.true.) + CASE(.false.) + CASE(.true.) ! { dg-error "value in CASE statement is repeated" } + END SELECT + END Index: gcc/testsuite/gfortran.dg/intrinsic_actual_1.f =================================================================== *** gcc/testsuite/gfortran.dg/intrinsic_actual_1.f (revision 0) --- gcc/testsuite/gfortran.dg/intrinsic_actual_1.f (revision 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 + ! + 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