This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [Patch, Fortran] PR39850: Too strict checking for procedures as actual argument


>> program test
>> ? external func ?! subroutine or implicitly typed real function
>> ? call sub(func)
>> ? call sub2(func)
>> contains
>> ? subroutine sub(a)
>> ? ? real, external :: a
>> ? ? print *, a(0.4)
>> ? end subroutine sub
>> ? subroutine sub2(a2)
>> ? ? interface
>> ? ? ? subroutine a2
>> ? ? ? end subroutine
>> ? ? end interface
>> ? ? call a2()
>> ? end subroutine
>> end
>>
>
> The program is invalid: Before the first call, "func" can be either a
> subroutine or a function. But then for "sub" it is used as function
> while for "sub2" it is used as subroutine, which is not simultaneously
> possible. Thus if you had either call, the program is valid, but if you
> have both calls it isn't.

Ok, right. I added a check for this invalidity, and corrected/extended
the test case accordingly.


> Sorry for raising again another issue.

I guess that's what you're supposed to do as a reviewer :)


> Best regards on this very rainy day,

Rainy indeed. But good for coding ;)

The new patch is regtesting right now. Ok if successful?

Cheers,
Janus


2009-06-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39850
	* interface.c (gfc_compare_interfaces): Take care of implicit typing
	when checking the function attribute. Plus another bugfix.
	(compare_parameter): Set attr.function and attr.subroutine according
	to the usage of a procedure as actual argument.


2009-06-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39850
	* gfortran.dg/interface_19.f90: Add 'cleanup-modules'.
	* gfortran.dg/interface_20.f90: Ditto.
	* gfortran.dg/interface_21.f90: Ditto.
	* gfortran.dg/interface_22.f90: Ditto.
	* gfortran.dg/interface_30.f90: New.
	* gfortran.dg/proc_ptr_11.f90: Fix invalid test case.
Index: gcc/testsuite/gfortran.dg/interface_22.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_22.f90	(revision 148765)
+++ gcc/testsuite/gfortran.dg/interface_22.f90	(working copy)
@@ -23,3 +23,6 @@ module gswap
     module procedure sreal, schar, sint => sreal ! { dg-error "Syntax error in MODULE PROCEDURE statement" }
   end interface swap
 end module gswap
+
+! { dg-final { cleanup-modules "foo g gswap" } }
+
Index: gcc/testsuite/gfortran.dg/proc_ptr_11.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_11.f90	(revision 148765)
+++ gcc/testsuite/gfortran.dg/proc_ptr_11.f90	(working copy)
@@ -55,7 +55,7 @@ program bsp
     end function add
 
     integer function f(x)
-      integer :: x
+      integer,intent(in) :: x
       f = 317 + x
     end function
 
Index: gcc/testsuite/gfortran.dg/interface_19.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_19.f90	(revision 148765)
+++ gcc/testsuite/gfortran.dg/interface_19.f90	(working copy)
@@ -27,3 +27,6 @@ intrinsic dcos
 call sub()
 call sub(dcos)
 end
+
+! { dg-final { cleanup-modules "m" } }
+
Index: gcc/testsuite/gfortran.dg/interface_21.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_21.f90	(revision 148765)
+++ gcc/testsuite/gfortran.dg/interface_21.f90	(working copy)
@@ -20,3 +20,6 @@ implicit none
 EXTERNAL foo  ! implicit interface is undefined
 call sub(foo) ! { dg-error "is not a function" }
 end
+
+! { dg-final { cleanup-modules "m" } }
+
Index: gcc/testsuite/gfortran.dg/interface_20.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_20.f90	(revision 148765)
+++ gcc/testsuite/gfortran.dg/interface_20.f90	(working copy)
@@ -18,3 +18,6 @@ implicit none
 intrinsic cos
 call sub(cos) ! { dg-error "wrong number of arguments" }
 end
+
+! { dg-final { cleanup-modules "m" } }
+
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 148765)
+++ gcc/fortran/interface.c	(working copy)
@@ -939,7 +939,9 @@ gfc_compare_interfaces (gfc_symbol *s1, 
 {
   gfc_formal_arglist *f1, *f2;
 
-  if (s1->attr.function && !s2->attr.function)
+  if (s1->attr.function && (s2->attr.subroutine
+      || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
+	  && gfc_get_default_type (s2->name, s2->ns)->type == BT_UNKNOWN)))
     {
       if (errmsg != NULL)
 	snprintf (errmsg, err_len, "'%s' is not a function", s2->name);
@@ -967,8 +969,6 @@ gfc_compare_interfaces (gfc_symbol *s1, 
 		      "of '%s'", s2->name);
 	  return 0;
 	}
-      if (s1->attr.if_source == IFSRC_DECL)
-	return 1;
     }
 
   if (s1->attr.if_source == IFSRC_UNKNOWN
@@ -1388,6 +1388,7 @@ compare_parameter (gfc_symbol *formal, g
   if (actual->ts.type == BT_PROCEDURE)
     {
       char err[200];
+      gfc_symbol *act_sym = actual->symtree->n.sym;
 
       if (formal->attr.flavor != FL_PROCEDURE)
 	{
@@ -1396,7 +1397,7 @@ compare_parameter (gfc_symbol *formal, g
 	  return 0;
 	}
 
-      if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0, 1, err,
+      if (!gfc_compare_interfaces (formal, act_sym, 0, 1, err,
 				   sizeof(err)))
 	{
 	  if (where)
@@ -1405,6 +1406,13 @@ compare_parameter (gfc_symbol *formal, g
 	  return 0;
 	}
 
+      if (formal->attr.function && !act_sym->attr.function)
+	gfc_add_function (&act_sym->attr, act_sym->name, &act_sym->declared_at);
+
+      if (formal->attr.subroutine && !act_sym->attr.subroutine)
+	gfc_add_subroutine (&act_sym->attr, act_sym->name,
+			    &act_sym->declared_at);
+
       return 1;
     }
 
! { dg-do compile }
!
! PR39850: Too strict checking for procedures as actual argument
!
! Original test case by Tobias Burnus <burnus@gcc.gnu.org>
! Modified by Janus Weil <janus@gcc.gnu.org>

real function func()
  print *,"func"
  func = 42.0
end function func

program test
  external func1,func2,func3,func4  ! subroutine or implicitly typed real function
  call sub1(func1)
  call sub2(func2)
  call sub1(func3)
  call sub2(func3)  ! { dg-error "Type mismatch in argument" }
  call sub2(func4)
  call sub1(func4)  ! { dg-error "Interface mismatch in dummy procedure" }
contains
  subroutine sub1(a1)
    interface
      real function a1()
      end function
    end interface
    print *, a1()
  end subroutine sub1
  subroutine sub2(a2)
    interface
      subroutine a2
      end subroutine
    end interface
    call a2()
  end subroutine
end


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]