re PR fortran/29992 ([4.1 only] INTERFACE equivalent to MODULE PROCEDURE?!)

2006-12-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29992
	* interface.c (check_sym_interfaces): Module procedures in a
	generic must be use associated or contained in the module.
	* decl.c (gfc_match_modproc): Set attribute mod_proc.
	* gfortran.h (symbol_attribute): Add mod_proc atribute.

	PR fortran/30081
	* resolve.c (resolve_generic_f, resolve_generic_s): Use
	gfc_intrinsic_name to find out if the function is intrinsic
	because it does not have to be a generic intrinsic to be
	overloaded.

2006-12-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29992
	* gfortran.dg/generic_9.f90: New test.

	PR fortran/30081
	* gfortran.dg/generic_10.f90: New test.

From-SVN: r120072

gcc/fortran/ChangeLog

+2006-12-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29992
+	* interface.c (check_sym_interfaces): Module procedures in a
+	generic must be use associated or contained in the module.
+	* decl.c (gfc_match_modproc): Set attribute mod_proc.
+	* gfortran.h (symbol_attribute): Add mod_proc atribute.
+
+	PR fortran/30081
+	* resolve.c (resolve_generic_f, resolve_generic_s): Use
+	gfc_intrinsic_name to find out if the function is intrinsic
+	because it does not have to be a generic intrinsic to be
+	overloaded.
+
 2006-12-19  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/39238

gcc/fortran/decl.c

@@ -4289,6 +4289,8 @@ gfc_match_modproc (void)
       if (gfc_add_interface (sym) == FAILURE)
 	return MATCH_ERROR;
 
+      sym->attr.mod_proc = 1;
+
       if (gfc_match_eos () == MATCH_YES)
 	break;
       if (gfc_match_char (',') != MATCH_YES)

gcc/fortran/gfortran.h

@@ -494,7 +494,7 @@ typedef struct
 
   /* Function/subroutine attributes */
   unsigned sequence:1, elemental:1, pure:1, recursive:1;
-  unsigned unmaskable:1, masked:1, contained:1;
+  unsigned unmaskable:1, masked:1, contained:1, mod_proc:1;
 
   /* This is set if the subroutine doesn't return.  Currently, this
      is only possible for intrinsic subroutines.  */

gcc/fortran/interface.c

@@ -1011,6 +1011,7 @@ check_sym_interfaces (gfc_symbol * sym)
 {
   char interface_name[100];
   bool k;
+  gfc_interface *p;
 
   if (sym->ns != gfc_current_ns)
     return;
@@ -1021,6 +1022,18 @@ check_sym_interfaces (gfc_symbol * sym)
       if (check_interface0 (sym->generic, interface_name))
 	return;
 
+      for (p = sym->generic; p; p = p->next)
+	{
+	  if (!p->sym->attr.use_assoc
+		&& p->sym->attr.mod_proc
+		&& p->sym->attr.if_source != IFSRC_DECL)
+	    {
+	      gfc_error ("MODULE PROCEDURE '%s' at %L does not come "
+			 "from a module", p->sym->name, &p->where);
+	      return;
+	    }
+	}
+
       /* Originally, this test was aplied to host interfaces too;
 	 this is incorrect since host associated symbols, from any
 	 source, cannot be ambiguous with local symbols.  */

gcc/fortran/resolve.c

@@ -1215,9 +1215,9 @@ generic:
 	goto generic;
     }
 
-  /* Last ditch attempt.  */
-
-  if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
+  /* Last ditch attempt.  See if the reference is to an intrinsic
+     that possesses a matching interface.  14.1.2.4  */
+  if (!gfc_intrinsic_name (sym->name, 0))
     {
       gfc_error ("There is no specific function for the generic '%s' at %L",
 		 expr->symtree->n.sym->name, &expr->where);
@@ -1675,9 +1675,11 @@ generic:
 	goto generic;
     }
 
-  /* Last ditch attempt.  */
+  /* Last ditch attempt.  See if the reference is to an intrinsic
+     that possesses a matching interface.  14.1.2.4  */
   sym = c->symtree->n.sym;
-  if (!gfc_generic_intrinsic (sym->name))
+
+  if (!gfc_intrinsic_name (sym->name, 1))
     {
       gfc_error
 	("There is no specific subroutine for the generic '%s' at %L",

gcc/testsuite/ChangeLog

+2006-12-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29992
+	* gfortran.dg/generic_9.f90: New test.
+
+	PR fortran/30081
+	* gfortran.dg/generic_10.f90: New test.
+
 2006-12-19  Andrew Pinski  <pinskia@gmail.com>
 
 	PR tree-opt/30045

gcc/testsuite/gfortran.dg/generic_10.f90

+! { dg-do compile }
+! Test the patch for PR30081 in which non-generic intrinsic
+! procedures could not be overloaded by generic interfaces.
+!
+! Contributed by Harald Anlauf  <anlauf@gmx.de>
+!
+module gfcbug46
+  interface random_seed
+     module procedure put_seed
+  end interface
+  interface random_number
+     module procedure random_vector
+  end interface
+  type t_t
+     real :: x(2)
+  end type t_t
+contains
+  subroutine put_seed (n, seed)
+    integer, intent(inout) :: n
+    integer, intent(in)    :: seed
+    call random_seed (size=n)
+  end subroutine put_seed
+  subroutine random_vector (t)
+    type(t_t) :: t
+    call random_number (t% x)
+  end subroutine random_vector
+end module gfcbug46
+
+  use gfcbug46
+  type(t_t) :: z
+  integer :: n = 2, seed = 1
+  call put_seed (n, seed)
+  call random_number (z)
+  print *, z
+end
+! { dg-final { cleanup-modules "gfcbug46" } }

gcc/testsuite/gfortran.dg/generic_9.f90

+! { dg-do compile }
+! Test the patch for PR29992. The standard requires that a
+! module procedure be contained in the same scope as the
+! interface or is use associated to it(12.3.2.1).
+!
+! Contributed by Daniel Franke  <franke.daniel@gmail.com>
+!
+MODULE class_foo_type
+  TYPE :: foo
+    INTEGER :: dummy
+  END TYPE
+contains
+  SUBROUTINE bar_init_set_int(this, value)
+    TYPE(foo), INTENT(out) :: this
+    integer, intent(in) :: value
+    this%dummy = value
+  END SUBROUTINE
+END MODULE
+
+MODULE class_foo
+USE class_foo_type, ONLY: foo, bar_init_set_int
+
+INTERFACE foo_init
+  MODULE PROCEDURE foo_init_default  ! { dg-error "does not come from a module" }
+END INTERFACE
+
+INTERFACE bar_init
+  MODULE PROCEDURE bar_init_default, bar_init_set_int  ! These are OK
+END INTERFACE
+
+INTERFACE
+  SUBROUTINE foo_init_default(this)
+    USE class_foo_type, ONLY: foo
+    TYPE(foo), INTENT(out) :: this
+  END SUBROUTINE
+END INTERFACE
+
+contains
+  SUBROUTINE bar_init_default(this)
+    TYPE(foo), INTENT(out) :: this
+    this%dummy = 42
+  END SUBROUTINE
+
+END MODULE
+! { dg-final { cleanup-modules "class_foo_type class_foo" } }