From: Steven G. Kargl Date: Sun, 11 Feb 2018 18:44:05 +0000 (+0000) Subject: re PR fortran/54223 (Statement function statement with dummy arguments that are also... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=f3883269c3dd4528cb089c640edb35029b1398a0;p=gcc.git re PR fortran/54223 (Statement function statement with dummy arguments that are also OPTIONAL may crash in wrong calls) 2018-02-11 Steven G. Kargl PR fortran/54223 PR fortran/84276 * interface.c (compare_actual_formal): Add in_statement_function bool parameter. Skip check of INTENT attribute for statement functions. Arguments to a statement function cannot be optional, issue error for missing argument. (gfc_procedure_use, gfc_ppc_use, gfc_arglist_matches_symbol): Use in_statement_function. 2018-02-11 Steven G. Kargl PR fortran/54223 PR fortran/84276 * gfortran.dg/statement_function_1.f90: New test. * gfortran.dg/statement_function_2.f90: New test. From-SVN: r257565 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index bebf155bfd0..d5c2675a427 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2018-02-11 Steven G. Kargl + + PR fortran/54223 + PR fortran/84276 + * interface.c (compare_actual_formal): Add in_statement_function + bool parameter. Skip check of INTENT attribute for statement + functions. Arguments to a statement function cannot be optional, + issue error for missing argument. + (gfc_procedure_use, gfc_ppc_use, gfc_arglist_matches_symbol): Use + in_statement_function. + 2018-02-11 Paul Thomas PR fortran/84074 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 9e55e9dc310..a5f3f4dda16 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2835,7 +2835,8 @@ lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments) static bool compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, - int ranks_must_agree, int is_elemental, locus *where) + int ranks_must_agree, int is_elemental, + bool in_statement_function, locus *where) { gfc_actual_arglist **new_arg, *a, *actual; gfc_formal_arglist *f; @@ -3204,8 +3205,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, } /* Check intent = OUT/INOUT for definable actual argument. */ - if ((f->sym->attr.intent == INTENT_OUT - || f->sym->attr.intent == INTENT_INOUT)) + if (!in_statement_function + && (f->sym->attr.intent == INTENT_OUT + || f->sym->attr.intent == INTENT_INOUT)) { const char* context = (where ? _("actual argument to INTENT = OUT/INOUT") @@ -3310,7 +3312,8 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, "at %L", where); return false; } - if (!f->sym->attr.optional) + if (!f->sym->attr.optional + || (in_statement_function && f->sym->attr.optional)) { if (where) gfc_error ("Missing actual argument for argument %qs at %L", @@ -3598,6 +3601,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) bool gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) { + gfc_actual_arglist *a; gfc_formal_arglist *dummy_args; /* Warn about calls with an implicit interface. Special case @@ -3631,8 +3635,6 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) if (sym->attr.if_source == IFSRC_UNKNOWN) { - gfc_actual_arglist *a; - if (sym->attr.pointer) { gfc_error ("The pointer object %qs at %L must have an explicit " @@ -3724,9 +3726,12 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) dummy_args = gfc_sym_get_dummy_args (sym); - if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, where)) + /* For a statement function, check that types and type parameters of actual + arguments and dummy arguments match. */ + if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, + sym->attr.proc == PROC_ST_FUNCTION, where)) return false; - + if (!check_intents (dummy_args, *ap)) return false; @@ -3773,7 +3778,7 @@ gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where) } if (!compare_actual_formal (ap, comp->ts.interface->formal, 0, - comp->attr.elemental, where)) + comp->attr.elemental, false, where)) return; check_intents (comp->ts.interface->formal, *ap); @@ -3798,7 +3803,7 @@ gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym) dummy_args = gfc_sym_get_dummy_args (sym); r = !sym->attr.elemental; - if (compare_actual_formal (args, dummy_args, r, !r, NULL)) + if (compare_actual_formal (args, dummy_args, r, !r, false, NULL)) { check_intents (dummy_args, *args); if (warn_aliasing) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 72b4e36fd16..9d84fca2d98 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2018-02-11 Steven G. Kargl + + PR fortran/54223 + PR fortran/84276 + * gfortran.dg/statement_function_1.f90: New test. + * gfortran.dg/statement_function_2.f90: New test. + 2018-02-11 Paul Thomas PR fortran/84074 diff --git a/gcc/testsuite/gfortran.dg/statement_function_1.f90 b/gcc/testsuite/gfortran.dg/statement_function_1.f90 new file mode 100644 index 00000000000..f26f25c8712 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/statement_function_1.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! PR fortran/84276 + subroutine stepns(hh, h, s, w) + real, intent(inout) :: h, hh, s + real, intent(out) :: w + real :: qofs + integer i + qofs(s) = s + w = qofs(hh + h) + i = 42 + w = qofs(i) ! { dg-error "Type mismatch in argument" } + end subroutine stepns + + subroutine step(hh, h, s, w) + real, intent(inout) :: h, hh, s + real, intent(out) :: w + real :: qofs + integer i + qofs(s, i) = i * s + i = 42 + w = qofs(hh, i) +! +! The following line should cause an error, because keywords are not +! allowed in a function with an implicit interface. +! + w = qofs(i = i, s = hh) + end subroutine step +! { dg-prune-output " Obsolescent feature" } diff --git a/gcc/testsuite/gfortran.dg/statement_function_2.f90 b/gcc/testsuite/gfortran.dg/statement_function_2.f90 new file mode 100644 index 00000000000..703ca1716ca --- /dev/null +++ b/gcc/testsuite/gfortran.dg/statement_function_2.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! PR fortran/54223 +subroutine r(d) + implicit none + integer, optional :: d + integer :: h, q + q(d) = d + 1 ! statement function statement + h = q(d) +end subroutine r + +subroutine s(x) + implicit none + integer, optional :: x + integer :: g, z + g(x) = x + 1 ! statement function statement + z = g() ! { dg-error "Missing actual argument" } +end subroutine s + +subroutine t(a) + implicit none + integer :: a + integer :: f, y + f(a) = a + 1 ! statement function statement + y = f() ! { dg-error "Missing actual argument" } +end subroutine t +! { dg-prune-output " Obsolescent feature" }