[patch, fortran] PR33162 INTRINSIC functions as ACTUAL argument

[Jerry DeLisle <jvdelisle at verizon dot net>]

:ADDPATCH fortran:

Hi all,

This patch fixes the second part of this PR by implementing checking of 
intrinsic argument lists against a formal argument list.  There were two problems.

The symbol generated from "INTRINSIC cos" does not have the function attribute 
set.  This prevented proper processing of the symbol in resolve_actual_arglist. 
  I relax this constraint and set the function attribute if the intrinsic 
function is found.

After that point, the compare_interfaces function could not compare properly 
because a gfc_formal_arglist is quite different from a gfc_intrinsic_arg and the 
symbol actually has the formal pointer as NULL

To correct this, I implemented a new function that compares the two different 
argument lists, verifying the argument count, types, and kinds.

Remaining for this PR is allowing PROCEDURE(cos) :: my1

Three new test cases provided.

Regression tested on x86-64-Gnu-linux.

OK for trunk?

Best regards,

Jerry


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

	PR fortran/33162
	* interface.c (compare_intr_interfaces): New function to check intrinsic
	function arguments against formal arguments. (compare_interfaces): Fix
	logic in comparison of function and subroutine attributes.
	(compare_parameter): Use new function for intrinsic as argument.
	* resolve.c (resolve_actual_arglist): Allow an intrinsic without
	function attribute to be checked further.  Set function attribute if
	intrinsic symbol is found, return FAILURE if not.

Index: interface.c
===================================================================
--- interface.c	(revision 129787)
+++ interface.c	(working copy)
@@ -468,6 +468,7 @@ compare_type_rank (gfc_symbol *s1, gfc_s
 
 
 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
+static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *);
 
 /* Given two symbols that are formal arguments, compare their types
    and rank and their formal interfaces if they are both dummy
@@ -942,7 +943,7 @@ compare_interfaces (gfc_symbol *s1, gfc_
   gfc_formal_arglist *f1, *f2;
 
   if (s1->attr.function != s2->attr.function
-      && s1->attr.subroutine != s2->attr.subroutine)
+      || s1->attr.subroutine != s2->attr.subroutine)
     return 0;		/* Disagreement between function/subroutine.  */
 
   f1 = s1->formal;
@@ -973,6 +974,56 @@ 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_intrinsic_sym *isym;
+
+  if (s1->attr.function != s2->attr.function
+      || s1->attr.subroutine != s2->attr.subroutine)
+    return 0;		/* Disagreement between function/subroutine.  */
+
+  isym = gfc_find_function (s2->name);
+  
+  /* This should already have been checked in
+     resolve.c (resolve_actual_arglist).  */
+  gcc_assert (isym);
+
+  f1 = s1->formal;
+  f2 = isym->formal;
+
+  /* Special case.  */
+  if (f1 == NULL && f2 == NULL)
+    return 1;
+  
+  /* First scan through the formal argument list and check the intrinsic.  */
+  fi = f2;
+  for (f = f1; f; f = f->next)
+    {
+      if (fi == NULL)
+	return 0;
+      if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
+	return 0;
+      fi = fi->next;
+    }
+
+  /* Now scan through the intrinsic argument list and check the formal.  */
+  f = f1;
+  for (fi = f2; fi; fi = fi->next)
+    {
+      if (f == NULL)
+	return 0;
+      if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
+	return 0;
+      f = f->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.  */
@@ -1323,7 +1374,10 @@ compare_parameter (gfc_symbol *formal, g
 	  || actual->symtree->n.sym->attr.external)
 	return 1;		/* Assume match.  */
 
-      return compare_interfaces (formal, actual->symtree->n.sym, 0);
+      if (actual->symtree->n.sym->attr.intrinsic)
+	return compare_intr_interfaces (formal, actual->symtree->n.sym);
+      else
+	return compare_interfaces (formal, actual->symtree->n.sym, 0);
     }
 
   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
Index: resolve.c
===================================================================
--- resolve.c	(revision 129787)
+++ resolve.c	(working copy)
@@ -1071,8 +1071,7 @@ resolve_actual_arglist (gfc_actual_argli
 	    goto got_variable;
 
 	  /* If all else fails, see if we have a specific intrinsic.  */
-	  if (sym->attr.function
-	      && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
+	  if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
 	    {
 	      gfc_intrinsic_sym *isym;
 	      isym = gfc_find_function (sym->name);
@@ -1081,8 +1080,10 @@ resolve_actual_arglist (gfc_actual_argli
 		  gfc_error ("Unable to find a specific INTRINSIC procedure "
 			     "for the reference '%s' at %L", sym->name,
 			     &e->where);
+		  return FAILURE;
 		}
 	      sym->ts = isym->ts;
+	      sym->attr.function = 1;
 	    }
 	  goto argument_list;
 	}

! { dg-do run }
! 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)
    optional :: a
    character(25) :: temp
    interface
      function a(x)
        real(kind=8):: a
        real(kind=8):: x
        intent(in) :: x
      end function a
    end interface
    if(present(a)) then
      write(temp,'(f16.10)')a(4.0d0)
      if (trim(temp) /= '   -0.6536436209') call abort
    endif
  end subroutine sub
end module m

use m
implicit none
intrinsic dcos
call sub()
call sub(dcos)
end

! { 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-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  ! implicit interface is undefined
call sub(foo) ! { dg-error "Type/rank mismatch in argument" }
end