[patch,fortran] PR33162 Allow intrinsic functions in PROCEDURE statements

[patch,fortran] PR33162 Allow intrinsic functions in PROCEDURE statements

[Jerry DeLisle]

[-- Attachment #1: Type: text/plain, Size: 1370 bytes --]

:ADDPATCH fortran:

This patch allows intrinsics in PROCEDURE statements by removing the error call 
in decl.c and adding the necessary checks and resolving the interfaces. This is 
the last part to fixing this PR.

It has taken some time to get to this point, so I thought it best to get this 
out for review and testing with real code.

I think the explanation in the ChangeLog is sufficient.

Thanks to Janus Weil for several off list comments, now resolved.

Regression tested on x86-64.  New test cases provided.  One error condition in 
proc_decl_1.f90 is no longer an error, so that test is modified.  See attached.

OK for trunk?

Regards,

Jerry

2007-11-11  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/33162
	* decl.c (match_procedure_decl): Remove TODO and allow intrinsics in
	PROCEDURE declarations.  Set attr.untyped to allow the interface to be
	resolved later where the symbol type will be set.
	* interface.c (compare_intr_interfaces): Remove static from pointer
	declarations.  Add type and kind checks for dummy function arguments.
	(compare_actual_formal_intr): New function to compare an actual
	argument with an intrinsic function. (gfc_procedures_use): Add check for
	interface that points to an intrinsic function, use the new function.
	* resolve.c (resolve_specific_f0): Resolve the intrinsic interface.
	(resolve_specific_s0): Ditto.


[-- Attachment #2: pr33162-part3d.diff --]
[-- Type: text/x-patch, Size: 7040 bytes --]

Index: interface.c
===================================================================
--- interface.c	(revision 130085)
+++ interface.c	(working copy)
@@ -977,13 +977,25 @@ compare_interfaces (gfc_symbol *s1, gfc_
 static int
 compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
 {
-  static gfc_formal_arglist *f, *f1;
-  static gfc_intrinsic_arg *fi, *f2;
+  gfc_formal_arglist *f, *f1;
+  gfc_intrinsic_arg *fi, *f2;
   gfc_intrinsic_sym *isym;
 
   if (s1->attr.function != s2->attr.function
       || s1->attr.subroutine != s2->attr.subroutine)
     return 0;		/* Disagreement between function/subroutine.  */
+  
+  /* If the arguments are functions, check type and kind.  */
+  
+  if (s1->attr.dummy && s1->attr.function && s2->attr.function)
+    {
+      if (s1->ts.type != s2->ts.type)
+	return 0;
+      if (s1->ts.kind != s2->ts.kind)
+	return 0;
+      if (s1->attr.if_source == IFSRC_DECL)
+	return 1;
+    }
 
   isym = gfc_find_function (s2->name);
   
@@ -1024,6 +1036,55 @@ compare_intr_interfaces (gfc_symbol *s1,
 }
 
 
+/* Compare an actual argument list with an intrinsic argument list.  */
+
+static int
+compare_actual_formal_intr (gfc_actual_arglist **ap, gfc_symbol *s2)
+{
+  gfc_actual_arglist *a;
+  gfc_intrinsic_arg *fi, *f2;
+  gfc_intrinsic_sym *isym;
+
+  isym = gfc_find_function (s2->name);
+  
+  /* This should already have been checked in
+     resolve.c (resolve_actual_arglist).  */
+  gcc_assert (isym);
+
+  f2 = isym->formal;
+
+  /* Special case.  */
+  if (*ap == NULL && f2 == NULL)
+    return 1;
+  
+  /* First scan through the actual argument list and check the intrinsic.  */
+  fi = f2;
+  for (a = *ap; a; a = a->next)
+    {
+      if (fi == NULL)
+	return 0;
+      if ((fi->ts.type != a->expr->ts.type)
+	  || (fi->ts.kind != a->expr->ts.kind))
+	return 0;
+      fi = fi->next;
+    }
+
+  /* Now scan through the intrinsic argument list and check the formal.  */
+  a = *ap;
+  for (fi = f2; fi; fi = fi->next)
+    {
+      if (a == NULL)
+	return 0;
+      if ((fi->ts.type != a->expr->ts.type)
+	  || (fi->ts.kind != a->expr->ts.kind))
+	return 0;
+      a = a->next;
+    }
+
+  return 1;
+}
+
+
 /* Given a pointer to an interface pointer, remove duplicate
    interfaces and make sure that all symbols are either functions or
    subroutines.  Returns nonzero if something goes wrong.  */
@@ -2225,6 +2286,20 @@ gfc_procedure_use (gfc_symbol *sym, gfc_
     gfc_warning ("Procedure '%s' called with an implicit interface at %L",
 		 sym->name, where);
 
+  if (sym->interface && sym->interface->attr.intrinsic)
+    {
+      gfc_intrinsic_sym *isym;
+      isym = gfc_find_function (sym->interface->name);
+      if (isym != NULL)
+	{
+	  if (compare_actual_formal_intr (ap, sym->interface))
+	    return;
+	  gfc_error ("My Type/rank mismatch in argument '%s' at %L",
+		     sym->name, where);
+	  return;
+	}
+    }
+
   if (sym->attr.if_source == IFSRC_UNKNOWN
       || !compare_actual_formal (ap, sym->formal, 0,
 				 sym->attr.elemental, where))
Index: decl.c
===================================================================
--- decl.c	(revision 130085)
+++ decl.c	(working copy)
@@ -3968,19 +3968,9 @@ match_procedure_decl (void)
 		    "in PROCEDURE statement at %C", proc_if->name);
 	  return MATCH_ERROR;
 	}
-      /* TODO: Allow intrinsics with gfc_intrinsic_actual_ok
-	 (proc_if->name, 0) after PR33162 is fixed.  */
-      if (proc_if->attr.intrinsic)
-	{
-	  gfc_error ("Fortran 2003: Support for intrinsic procedure '%s' "
-		     "in PROCEDURE statement at %C not yet implemented "
-		     "in gfortran", proc_if->name);
-	  return MATCH_ERROR;
-	}
     }
 
 got_ts:
-
   if (gfc_match (" )") != MATCH_YES)
     {
       gfc_current_locus = entry_loc;
@@ -3995,7 +3985,6 @@ got_ts:
   /* Get procedure symbols.  */
   for(num=1;;num++)
     {
-
       m = gfc_match_symbol (&sym, 0);
       if (m == MATCH_NO)
 	goto syntax;
@@ -4040,7 +4029,10 @@ got_ts:
 
       /* Set interface.  */
       if (proc_if != NULL)
-	sym->interface = proc_if;
+	{
+	  sym->interface = proc_if;
+	  sym->attr.untyped = 1;
+	}
       else if (current_ts.type != BT_UNKNOWN)
 	{
 	  sym->interface = gfc_new_symbol ("", gfc_current_ns);
Index: ChangeLog
===================================================================
--- ChangeLog	(revision 130095)
+++ ChangeLog	(working copy)
@@ -1,3 +1,17 @@
+2007-11-11  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/33162
+	* decl.c (match_procedure_decl): Remove TODO and allow intrinsics in
+	PROCEDURE declarations.  Set attr.untyped to allow the interface to be
+	resolved later where the symbol type will be set.
+	* interface.c (compare_intr_interfaces): Remove static from pointer
+	declarations.  Add type and kind checks for dummy function arguments.
+	(compare_actual_formal_intr): New function to compare an actual
+	argument with an intrinsic function. (gfc_procedures_use): Add check for
+	interface that points to an intrinsic function, use the new function.
+	* resolve.c (resolve_specific_f0): Resolve the intrinsic interface.
+	(resolve_specific_s0): Ditto.
+
 2007-11-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	* trans-common.c: Remove prototype for gfc_get_common.
Index: resolve.c
===================================================================
--- resolve.c	(revision 130085)
+++ resolve.c	(working copy)
@@ -1074,6 +1074,7 @@ resolve_actual_arglist (gfc_actual_argli
 	  if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
 	    {
 	      gfc_intrinsic_sym *isym;
+
 	      isym = gfc_find_function (sym->name);
 	      if (isym == NULL || !isym->specific)
 		{
@@ -1083,6 +1084,7 @@ resolve_actual_arglist (gfc_actual_argli
 		  return FAILURE;
 		}
 	      sym->ts = isym->ts;
+	      sym->attr.intrinsic = 1;
 	      sym->attr.function = 1;
 	    }
 	  goto argument_list;
@@ -1487,6 +1489,22 @@ resolve_specific_f0 (gfc_symbol *sym, gf
 {
   match m;
 
+  /* See if we have an intrinsic interface.  */
+
+  if (sym->interface != NULL && sym->interface->attr.intrinsic)
+    {
+      gfc_intrinsic_sym *isym;
+      isym = gfc_find_function (sym->interface->name);
+
+      /* Existance of isym should be checked already.  */
+      gcc_assert (isym);
+
+      sym->ts = isym->ts;
+      sym->attr.function = 1;
+      sym->attr.proc = PROC_EXTERNAL;
+      goto found;
+    }
+
   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
     {
       if (sym->attr.dummy)
@@ -2513,6 +2531,22 @@ resolve_specific_s0 (gfc_code *c, gfc_sy
 {
   match m;
 
+  /* See if we have an intrinsic interface.  */
+  if (sym->interface != NULL && !sym->interface->attr.abstract
+      && !sym->interface->attr.subroutine)
+    {
+      gfc_intrinsic_sym *isym;
+
+      isym = gfc_find_function (sym->interface->name);
+
+      /* Existance of isym should be checked already.  */
+      gcc_assert (isym);
+
+      sym->ts = isym->ts;
+      sym->attr.function = 1;
+      goto found;
+    }
+
   if(sym->attr.is_iso_c)
     {
       m = gfc_iso_c_sub_interface (c,sym);

[-- Attachment #3: proc_decl_1.f90 --]
[-- Type: text/x-fortran, Size: 2102 bytes --]

! { dg-do compile }
! This tests various error messages for PROCEDURE declarations.
! Contributed by Janus Weil <jaydub66@gmail.com>

module m

  abstract interface
    subroutine sub()
    end subroutine
    subroutine sub2() bind(c)
    end subroutine
  end interface

  procedure(), public, private :: a  ! { dg-error "was already specified" }
  procedure(sub),bind(C) :: a2  ! { dg-error "requires an interface with BIND.C." }
  procedure(sub2), public, bind(c, name="myEF") :: e, f  ! { dg-error "Multiple identifiers provided with single NAME= specifier" }
  procedure(sub2), bind(C, name=""), pointer :: g  ! { dg-error "may not have POINTER attribute" }

  public:: h
  procedure(),public:: h  ! { dg-error "was already specified" }

end module m


program prog

  interface z
    subroutine z1()
    end subroutine
    subroutine z2(a)
      integer :: a
    end subroutine
  end interface

  procedure(z) :: bar   ! { dg-error "may not be generic" }

  procedure(), allocatable:: b  ! { dg-error "PROCEDURE attribute conflicts with ALLOCATABLE attribute" }
  procedure(), save:: c  ! { dg-error "PROCEDURE attribute conflicts with SAVE attribute" }

  procedure(dcos) :: my1
  procedure(amax0) :: my2  ! { dg-error "not allowed in PROCEDURE statement" }

  procedure(),pointer:: ptr  ! { dg-error "not yet implemented" }

  type t
    procedure(),pointer:: p  ! { dg-error "not yet implemented" }
  end type

  real f, x
  f(x) = sin(x**2)
  external oo

  procedure(f) :: q  ! { dg-error "may not be a statement function" }
  procedure(oo) :: p  ! { dg-error "must be explicit" }

contains

  subroutine foo(a,c)
    abstract interface
      subroutine b() bind(C)
      end subroutine b
    end interface
    procedure(b), bind(c,name="hjj") :: a  ! { dg-error "may not have BIND.C. attribute with NAME" }
    procedure(c),intent(in):: c  ! { dg-error "PROCEDURE attribute conflicts with INTENT attribute" }
  end subroutine foo 

end program


subroutine abc

 procedure() :: abc2

entry abc2(x)  ! { dg-error "PROCEDURE attribute conflicts with ENTRY attribute" }
 real x

end subroutine

[-- Attachment #4: proc_decl_7.f90 --]
[-- Type: text/x-fortran, Size: 470 bytes --]

! { dg-do compile }
! PR33162 INTRINSIC functions as ACTUAL argument
! Test case adapted from PR by Jerry DeLisle <jvdelisle@gcc.gnu.org>
module m
implicit none
contains
  subroutine sub(a)
    interface
      function a()
        real :: a
      end function a
    end interface
    print *, a()
  end subroutine sub
end module m
use m
implicit none
intrinsic cos
call sub(cos) ! { dg-error "Type/rank mismatch in argument" }
end
! { dg-final { cleanup-modules "m" } }

[-- Attachment #5: proc_decl_8.f90 --]
[-- Type: text/x-fortran, Size: 614 bytes --]

! { dg-do compile }
! PR33162 INTRINSIC functions as ACTUAL argument
! Test case adapted from PR by Jerry DeLisle <jvdelisle@gcc.gnu.org>
module m
implicit none
contains
  subroutine sub(a)
    interface
      function a(x)
        real :: a, x
        intent(in) :: x
      end function a
    end interface
    print *, a(4.0)
  end subroutine sub

end module m

use m
implicit none
EXTERNAL foo  ! interface is undefined
procedure(cos) :: foo ! { dg-error "Duplicate EXTERNAL attribute specified" }
call sub(foo)         ! { dg-error "Type/rank mismatch in argument" }
end
! { dg-final { cleanup-modules "m" } }

[-- Attachment #6: proc_decl_9.f90 --]
[-- Type: text/x-fortran, Size: 293 bytes --]

! { dg-do run }
! PR33162 INTRINSIC functions as ACTUAL argument
! Test case adapted from PR by Jerry DeLisle <jvdelisle@gcc.gnu.org>
real function t(x)
  real ::x
  t = x
end function

program p
  implicit none
  intrinsic sin
  procedure(sin):: t
  if (t(1.0) /= 1.0) call abort
end program

[-- Attachment #7: proc_decl_10.f90 --]
[-- Type: text/x-fortran, Size: 803 bytes --]

! { dg-do compile }
! PR33162 INTRINSIC functions as ACTUAL argument
! Test case adapted from PR by Jerry DeLisle <jvdelisle@gcc.gnu.org>
module m
implicit none
  interface
    double precision function my1(x)
      double precision, intent(in) :: x
    end function my1
  end interface
  interface
    real(kind=4) function my2(x)
      real, intent(in) :: x
    end function my2
  end interface
  interface
    real function  my3(x, y)
      real, intent(in) :: x, y
    end function my3
  end interface
end module

program test
use m
implicit none
procedure(dcos):: my1 ! { dg-error "Cannot change attributes" }
procedure(cos) :: my2 ! { dg-error "Cannot change attributes" }
procedure(dprod) :: my3 ! { dg-error "Cannot change attributes" }

end program test

! { dg-final { cleanup-modules "m" } }

Re: [patch,fortran] PR33162 Allow intrinsic functions in PROCEDURE statements

[Jerry DeLisle]

Jerry DeLisle wrote:
> :ADDPATCH fortran:
> 
> This patch allows intrinsics in PROCEDURE statements by removing the 
> error call in decl.c and adding the necessary checks and resolving the 
> interfaces. This is the last part to fixing this PR.
> 
> It has taken some time to get to this point, so I thought it best to get 
> this out for review and testing with real code.
> 
> I think the explanation in the ChangeLog is sufficient.
> 
> Thanks to Janus Weil for several off list comments, now resolved.
> 
> Regression tested on x86-64.  New test cases provided.  One error 
> condition in proc_decl_1.f90 is no longer an error, so that test is 
> modified.  See attached.
> 
> OK for trunk?
> 
> Regards,
> 
> Jerry
> 
> 2007-11-11  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
> 
>     PR fortran/33162
>     * decl.c (match_procedure_decl): Remove TODO and allow intrinsics in
>     PROCEDURE declarations.  Set attr.untyped to allow the interface to be
>     resolved later where the symbol type will be set.
>     * interface.c (compare_intr_interfaces): Remove static from pointer
>     declarations.  Add type and kind checks for dummy function arguments.
>     (compare_actual_formal_intr): New function to compare an actual
>     argument with an intrinsic function. (gfc_procedures_use): Add check 
> for
>     interface that points to an intrinsic function, use the new function.

There is a spurious "My " in the error message added in gfc_procedure_use.  I 
have taken care of that. :)

Jerry

Re: [patch,fortran] PR33162 Allow intrinsic functions in PROCEDURE statements

[Tobias Burnus]

:REVIEWMAIL:

Jerry DeLisle wrote:
> This patch allows intrinsics in PROCEDURE statements by removing the
> error call in decl.c and adding the necessary checks and resolving the
> interfaces. This is the last part to fixing this PR.
> It has taken some time to get to this point, so I thought it best to
> get this out for review and testing with real code.
I played a bit around and it looks ok. The problem is that there is not
much "real code" as the PROCEDURE feature is quite new and not many
compiler supports it; of my compilers only gfortran and NAG f95 do so -
and NAG seems to have also some small issues.

> Regression tested on x86-64. OK for trunk? 
OK with the "My" removed from the error message.

Tobias