diff mbox series

Fix handling of arguments in statement functions

Message ID 20180210174657.GA16695@troutmask.apl.washington.edu
State New
Headers show
Series Fix handling of arguments in statement functions | expand

Commit Message

Steve Kargl Feb. 10, 2018, 5:46 p.m. UTC 
All,

The attach patch address 3 issues with statement functions.
First, a dummy argument in a statement function declarations
acquires only its type and type parameters from the containing
scope.  All attributes should be ignores.  The first fix for
PR fortran/84276 disables a check for the INTENT(INOUT,OUT) 
attribute.  The second fix for PR fortran/54223 disables a 
check for missing OPTIONAL arguments as an argument to a 
statement function cannot be optional.

In reviewing the bugs for statement functions, I came across
PR fortran/35229.  There is a long audit trail, but I have come
to agree with comment #3 from FX.  I have taken his suggested
patch for updating the error message.  Note, this issue is 
10 years old, and AFAIK, no one has sent a duplicate PR or an
email to fortran@gnu complaining about the current error 
message.  The new error message simply gives a better locus.
OK to commit?

Release Manager, I can hold the patch until after 8.0/1 is
released, but it is highly unlikely that this patch will 
cause a regression and it does fix two ICE.

2018-02-10  Steven G. Kargl  <kargl@gcc.gnu.org>

	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-10  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/54223
	PR fortran/84276
	* gfortran.dg/statement_function_1.f90: New test.
	* gfortran.dg/statement_function_3.f90: New test.

	PR fortran/35299
	* gfortran.dg/statement_function_3.f: New test.

Comments

Steve Kargl Feb. 10, 2018, 5:51 p.m. UTC | #1 
On Sat, Feb 10, 2018 at 09:46:57AM -0800, Steve Kargl wrote:
> 
> 	PR fortran/35299
> 	* gfortran.dg/statement_function_3.f: New test.

This patch should be credited to FX.  I've added

2018-02-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>

to the ChangeLog entry.
diff mbox series

Patch

Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 257464)
+++ gcc/fortran/interface.c	(working copy)
@@ -2835,7 +2835,8 @@  lookup_arg_fuzzy (const char *arg, gfc_formal_arglist 
 
 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_fo
 	}
 
       /* 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_fo
 		       "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_argli
 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
 
   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
 
   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 *
     }
 
   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,
   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)
Index: gcc/testsuite/gfortran.dg/statement_function_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/statement_function_1.f90	(nonexistent)
+++ gcc/testsuite/gfortran.dg/statement_function_1.f90	(working copy)
@@ -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" }
Index: gcc/testsuite/gfortran.dg/statement_function_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/statement_function_2.f90	(nonexistent)
+++ gcc/testsuite/gfortran.dg/statement_function_2.f90	(working copy)
@@ -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" }
Index: gcc/testsuite/gfortran.dg/statement_function_3.f
===================================================================
--- gcc/testsuite/gfortran.dg/statement_function_3.f	(nonexistent)
+++ gcc/testsuite/gfortran.dg/statement_function_3.f	(working copy)
@@ -0,0 +1,15 @@ 
+! { dg-do compile }
+! PR fortran/35299
+      subroutine phtod(e,n,i,h)
+      dimension e(n)
+      hstar(e,b)=b**.4*((1.25*fun(-e/40)+.18)) ! { dg-error "must be scalar" }
+      a = 1.
+      h = hstar(e(i-1), a)
+      end
+
+      function fun(a)
+         real a(*)
+         fun = 42
+      end
+! { dg-prune-output " Obsolescent feature" }
+