re PR fortran/36947 (Attributes not fully checked comparing actual vs dummy procedure)

2009-05-18  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36947
	PR fortran/40039
	* expr.c (gfc_check_pointer_assign): Check intents when comparing
	interfaces.
	* gfortran.h (typedef struct gfc_intrinsic_arg): Add 'intent' member.
	(gfc_compare_interfaces): Additional argument.
	* interface.c (operator_correspondence): Add check for equality of
	intents, and new argument 'intent_check'.
	(gfc_compare_interfaces): New argument 'intent_check', which is passed
	on to operator_correspondence.
	(check_interface1): Don't check intents when comparing interfaces.
	(compare_parameter): Do check intents when comparing interfaces.
	* intrinsic.c (add_sym): Add intents for arguments of intrinsic
	procedures.
	(add_sym_1,add_sym_1s,add_sym_1m,add_sym_2,add_sym_2s,add_sym_3,
	add_sym_3ml,add_sym_3red,add_sym_3s,add_sym_4): Use INTENT_IN by
	default.
	(add_sym_1_intent,add_sym_1s_intent,add_sym_2s_intent,add_sym_3s_intent)
	: New functions to add intrinsic symbols, specifying custom intents.
	(add_sym_4s,add_sym_5s): Add new arguments to specify intents.
	(add_functions,add_subroutines): Add intents for various intrinsics.
	* resolve.c (check_generic_tbp_ambiguity): Don't check intents when
	comparing interfaces.
	* symbol.c (gfc_copy_formal_args_intr): Copy intent.


2009-05-18  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36947
	PR fortran/40039
	* gfortran.dg/interface_27.f90: New.
	* gfortran.dg/interface_28.f90: New.
	* gfortran.dg/proc_ptr_11.f90: Fixing invalid test case.
	* gfortran.dg/proc_ptr_result_1.f90: Ditto.

From-SVN: r147655

gcc/fortran/ChangeLog

+2009-05-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36947
+	PR fortran/40039
+	* expr.c (gfc_check_pointer_assign): Check intents when comparing
+	interfaces.
+	* gfortran.h (typedef struct gfc_intrinsic_arg): Add 'intent' member.
+	(gfc_compare_interfaces): Additional argument.
+	* interface.c (operator_correspondence): Add check for equality of
+	intents, and new argument 'intent_check'.
+	(gfc_compare_interfaces): New argument 'intent_check', which is passed
+	on to operator_correspondence.
+	(check_interface1): Don't check intents when comparing interfaces.
+	(compare_parameter): Do check intents when comparing interfaces.
+	* intrinsic.c (add_sym): Add intents for arguments of intrinsic
+	procedures.
+	(add_sym_1,add_sym_1s,add_sym_1m,add_sym_2,add_sym_2s,add_sym_3,
+	add_sym_3ml,add_sym_3red,add_sym_3s,add_sym_4): Use INTENT_IN by
+	default.
+	(add_sym_1_intent,add_sym_1s_intent,add_sym_2s_intent,add_sym_3s_intent)
+	: New functions to add intrinsic symbols, specifying custom intents.
+	(add_sym_4s,add_sym_5s): Add new arguments to specify intents.
+	(add_functions,add_subroutines): Add intents for various intrinsics.
+	* resolve.c (check_generic_tbp_ambiguity): Don't check intents when
+	comparing interfaces.
+	* symbol.c (gfc_copy_formal_args_intr): Copy intent.
+
 2009-05-17  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	* iso-fortran-env.def: Define INT8, INT16, INT32, INT64, REAL32,

gcc/fortran/expr.c

@@ -3176,7 +3176,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 	return SUCCESS;
       if (rvalue->expr_type == EXPR_VARIABLE
 	  && !gfc_compare_interfaces (lvalue->symtree->n.sym,
-				      rvalue->symtree->n.sym, 0))
+				      rvalue->symtree->n.sym, 0, 1))
 	{
 	  gfc_error ("Interfaces don't match "
 		     "in procedure pointer assignment at %L", &rvalue->where);

gcc/fortran/gfortran.h

@@ -1445,6 +1445,7 @@ typedef struct gfc_intrinsic_arg
 
   gfc_typespec ts;
   int optional;
+  ENUM_BITFIELD (sym_intent) intent:2;
   gfc_actual_arglist *actual;
 
   struct gfc_intrinsic_arg *next;
@@ -2566,7 +2567,7 @@ gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *);
 void gfc_free_interface (gfc_interface *);
 int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
 int gfc_compare_types (gfc_typespec *, gfc_typespec *);
-int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int);
+int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int);
 void gfc_check_interfaces (gfc_namespace *);
 void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
 gfc_symbol *gfc_search_interface (gfc_interface *, int,

gcc/fortran/interface.c

@@ -873,23 +873,32 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
    which makes this test much easier than that for generic tests.
 
    This subroutine is also used when comparing a formal and actual
-   argument list when an actual parameter is a dummy procedure.  At
-   that point, two formal interfaces must be compared for equality
-   which is what happens here.  */
+   argument list when an actual parameter is a dummy procedure, and in
+   procedure pointer assignments. In these cases, two formal interfaces must be
+   compared for equality which is what happens here. 'intent_flag' specifies
+   whether the intents of the arguments are required to match, which is not the
+   case for ambiguity checks.  */
 
 static int
-operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
+operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
+			 int intent_flag)
 {
   for (;;)
     {
+      /* Check existence.  */
       if (f1 == NULL && f2 == NULL)
 	break;
       if (f1 == NULL || f2 == NULL)
 	return 1;
 
+      /* Check type and rank.  */
       if (!compare_type_rank (f1->sym, f2->sym))
 	return 1;
 
+      /* Check intent.  */
+      if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
+       return 1;
+
       f1 = f1->next;
       f2 = f2->next;
     }
@@ -961,7 +970,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
    would be ambiguous between the two interfaces, zero otherwise.  */
 
 int
-gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
+gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
+			int intent_flag)
 {
   gfc_formal_arglist *f1, *f2;
 
@@ -1001,7 +1011,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
     }
   else
     {
-      if (operator_correspondence (f1, f2))
+      if (operator_correspondence (f1, f2, intent_flag))
 	return 0;
     }
 
@@ -1080,7 +1090,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
 	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
 	  continue;
 
-	if (gfc_compare_interfaces (p->sym, q->sym, generic_flag))
+	if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0))
 	  {
 	    if (referenced)
 	      {
@@ -1362,7 +1372,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	  || actual->symtree->n.sym->attr.external)
 	return 1;		/* Assume match.  */
 
-      if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
+      if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0, 1))
 	goto proc_fail;
 
       return 1;

gcc/fortran/resolve.c

@@ -8585,7 +8585,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
     }
 
   /* Compare the interfaces.  */
-  if (gfc_compare_interfaces (sym1, sym2, 1))
+  if (gfc_compare_interfaces (sym1, sym2, 1, 0))
     {
       gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
 		 sym1->name, sym2->name, generic_name, &where);

gcc/fortran/symbol.c

@@ -3914,6 +3914,7 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
       /* May need to copy more info for the symbol.  */
       formal_arg->sym->ts = curr_arg->ts;
       formal_arg->sym->attr.optional = curr_arg->optional;
+      formal_arg->sym->attr.intent = curr_arg->intent;
       formal_arg->sym->attr.flavor = FL_VARIABLE;
       formal_arg->sym->attr.dummy = 1;
 

gcc/testsuite/ChangeLog

+2009-05-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/36947
+	PR fortran/40039
+	* gfortran.dg/interface_27.f90: New.
+	* gfortran.dg/interface_28.f90: New.
+	* gfortran.dg/proc_ptr_11.f90: Fixing invalid test case.
+	* gfortran.dg/proc_ptr_result_1.f90: Ditto.
+
 2009-05-18  Maxim Kuvyrkov  <maxim@codesourcery.com>
 
 	* gcc.target/m68k/tls-ie.c: New test.

gcc/testsuite/gfortran.dg/interface_27.f90

+! { dg-do compile }
+!
+! PR 40039: Procedures as actual arguments: Check intent of arguments
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+
+contains
+
+subroutine a(x,f)
+  real :: x
+  interface
+    real function f(y)
+      real,intent(in) :: y
+    end function
+  end interface
+  print *,f(x)
+end subroutine
+
+real function func(z)
+  real,intent(inout) :: z
+  func = z**2
+end function
+
+subroutine caller
+  interface
+    real function p(y)
+      real,intent(in) :: y
+    end function
+  end interface
+  pointer :: p
+
+  call a(4.3,func)  ! { dg-error "Type/rank mismatch in argument" }
+  p => func         ! { dg-error "Interfaces don't match in procedure pointer assignment" }
+end subroutine
+
+end module 
+
+! { dg-final { cleanup-modules "m" } }
+

gcc/testsuite/gfortran.dg/interface_28.f90

+! { dg-do compile }
+!
+! PR 36947: Attributes not fully checked comparing actual vs dummy procedure
+!
+! Contributed by Walter Spector <w6ws@earthlink.net>
+
+module testsub
+  contains
+  subroutine test(sub)
+    interface
+      subroutine sub(x)
+        integer, intent(in), optional:: x
+      end subroutine
+    end interface
+    print *, "In test(), about to call sub()"
+    call sub()
+  end subroutine
+end module
+
+module sub
+  contains
+  subroutine subActual(x)
+    ! actual subroutine's argment is different in intent and optional
+    integer, intent(inout):: x
+    print *, "In subActual():", x
+  end subroutine
+end module
+
+program interfaceCheck
+  use testsub
+  use sub
+
+  integer :: a
+
+  call test(subActual)  ! { dg-error "Type/rank mismatch in argument" }
+end program
+
+! { dg-final { cleanup-modules "sub testsub" } }
+

gcc/testsuite/gfortran.dg/proc_ptr_11.f90

@@ -23,6 +23,7 @@ program bsp
   interface
     function p3(x)
       real(8) :: p3,x
+      intent(in) :: x
     end function p3
   end interface
 

gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90

@@ -114,7 +114,7 @@ contains
     pointer :: f
     interface
       integer function f(x)
-        integer :: x
+        integer,intent(in) :: x
       end function
     end interface
     f => iabs
@@ -123,7 +123,7 @@ contains
   function g()
     interface
       integer function g(x)
-        integer :: x
+        integer,intent(in) :: x
       end function g
     end interface
     pointer :: g
@@ -133,13 +133,13 @@ contains
   function h(arg)
     interface
       subroutine arg(b)
-        integer :: b
+        integer,intent(inout) :: b
       end subroutine arg
     end interface
     pointer :: h
     interface
       subroutine h(a)
-        integer :: a
+        integer,intent(inout) :: a
       end subroutine h
     end interface
     h => arg
@@ -150,6 +150,7 @@ contains
     interface
       function i(x)
         integer :: i,x
+        intent(in) :: x
       end function i
     end interface
     i => iabs