re PR fortran/32157 (intrinsic function name conflicts with subroutine if present in the same file)

2007-07-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/32157
	* resolve.c (is_external_proc): New function.  Adds test that
	the symbol is not an intrinsic procedure.
	* (resolve_function, resolve_call): Replace logical statements
	with call to is_external_proc.

	PR fortran/32689
	* simplify.c (gfc_simplify_transfer): If mold has rank, the
	result is an array.

	PR fortran/32634
	* module.c (write_generic): Write the local name of the
	interface. 


2007-07-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/32157
	* gfortran.dg/overload_2.f90: New test.

	PR fortran/32689
	* gfortran.dg/transfer_simplify_5.f90

	PR fortran/32634
	* gfortran.dg/interface_15.f90: New test.

From-SVN: r126509

gcc/fortran/ChangeLog

@@ -1,3 +1,19 @@
+2007-07-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32157
+	* resolve.c (is_external_proc): New function.  Adds test that
+	the symbol is not an intrinsic procedure.
+	* (resolve_function, resolve_call): Replace logical statements
+	with call to is_external_proc.
+
+	PR fortran/32689
+	* simplify.c (gfc_simplify_transfer): If mold has rank, the
+	result is an array.
+
+	PR fortran/32634
+	* module.c (write_generic): Write the local name of the
+	interface. 
+
 2007-07-09  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	PR fortran/29459

gcc/fortran/module.c

@@ -3947,6 +3947,9 @@ write_operator (gfc_user_op *uop)
 static void
 write_generic (gfc_symbol *sym)
 {
+  const char *p;
+  int nuse, j;
+
   if (sym->generic == NULL
       || !gfc_check_access (sym->attr.access, sym->ns->default_access))
     return;
@@ -3954,7 +3957,20 @@ write_generic (gfc_symbol *sym)
   if (sym->module == NULL)
     sym->module = gfc_get_string (module_name);
 
-  mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
+  /* See how many use names there are.  If none, go through the loop
+     at least once.  */
+  nuse = number_use_names (sym->name);
+  if (nuse == 0)
+    nuse = 1;
+
+  for (j = 1; j <= nuse; j++)
+    {
+      /* Get the jth local name for this symbol.  */
+      p = find_use_name_n (sym->name, &j);
+
+      /* Make an interface with that name.  */
+      mio_symbol_interface (&p, &sym->module, &sym->generic);
+    }
 }
 
 

gcc/fortran/resolve.c

@@ -1552,6 +1552,22 @@ set_type:
 }
 
 
+/* Return true, if the symbol is an external procedure.  */
+static bool
+is_external_proc (gfc_symbol *sym)
+{
+  if (!sym->attr.dummy && !sym->attr.contained
+	&& !(sym->attr.intrinsic
+	      || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
+	&& sym->attr.proc != PROC_ST_FUNCTION
+	&& !sym->attr.use_assoc
+	&& sym->name)
+    return true;
+  else
+    return false;
+}
+
+
 /* Figure out if a function reference is pure or not.  Also set the name
    of the function for a potential error message.  Return nonzero if the
    function is PURE, zero if not.  */
@@ -1893,12 +1909,8 @@ resolve_function (gfc_expr *expr)
       return FAILURE;
     }
 
-  /* If the procedure is not internal, a statement function or a module
-     procedure,it must be external and should be checked for usage.  */
-  if (sym && !sym->attr.dummy && !sym->attr.contained
-      && sym->attr.proc != PROC_ST_FUNCTION
-      && !sym->attr.use_assoc
-      && sym->name  )
+  /* If the procedure is external, check for usage.  */
+  if (sym && is_external_proc (sym))
     resolve_global_procedure (sym, &expr->where, 0);
 
   /* Switch off assumed size checking and do this again for certain kinds
@@ -2490,12 +2502,8 @@ resolve_call (gfc_code *c)
       return FAILURE;
     }
 
-  /* If the procedure is not internal or module, it must be external and
-     should be checked for usage.  */
-  if (c->symtree && c->symtree->n.sym
-      && !c->symtree->n.sym->attr.dummy
-      && !c->symtree->n.sym->attr.contained
-      && !c->symtree->n.sym->attr.use_assoc)
+  /* If external, check for usage.  */
+  if (c->symtree && is_external_proc (c->symtree->n.sym))
     resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
 
   /* Subroutines without the RECURSIVE attribution are not allowed to

gcc/fortran/simplify.c

@@ -3924,7 +3924,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
   
   /* Set the number of elements in the result, and determine its size.  */
   result_elt_size = gfc_target_expr_size (mold_element);
-  if (mold->expr_type == EXPR_ARRAY || size)
+  if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
     {
       int result_length;
 

gcc/testsuite/ChangeLog

@@ -1,3 +1,14 @@
+2007-07-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32157
+	* gfortran.dg/overload_2.f90: New test.
+
+	PR fortran/32689
+	* gfortran.dg/transfer_simplify_5.f90
+
+	PR fortran/32634
+	* gfortran.dg/interface_15.f90: New test.
+
 2007-07-09  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR libfortran/32336

gcc/testsuite/gfortran.dg/interface_16.f90

@@ -0,0 +1,101 @@
+! { dg-do compile }
+! This tests the fix for PR32634, in which the generic interface
+! in foo_pr_mod was given the original rather than the local name.
+! This meant that the original name had to be used in the calll
+! in foo_sub.
+!
+! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it>
+
+module foo_base_mod
+  type foo_dmt
+    real(kind(1.d0)), allocatable  :: rv(:)
+    integer, allocatable :: iv1(:), iv2(:)
+  end type foo_dmt
+  type foo_zmt
+    complex(kind(1.d0)), allocatable  :: rv(:)
+    integer, allocatable  :: iv1(:), iv2(:)
+  end type foo_zmt
+  type foo_cdt
+     integer, allocatable :: md(:)
+     integer, allocatable :: hi(:), ei(:)
+  end type foo_cdt
+end module foo_base_mod
+
+module bar_prt
+  use foo_base_mod, only : foo_dmt, foo_zmt, foo_cdt
+  type bar_dbprt
+    type(foo_dmt), allocatable :: av(:) 
+    real(kind(1.d0)), allocatable      :: d(:)  
+    type(foo_cdt)                :: cd 
+  end type bar_dbprt
+  type bar_dprt
+    type(bar_dbprt), allocatable  :: bpv(:) 
+  end type bar_dprt
+  type bar_zbprt
+    type(foo_zmt), allocatable :: av(:) 
+    complex(kind(1.d0)), allocatable   :: d(:)  
+    type(foo_cdt)                :: cd 
+  end type bar_zbprt
+  type bar_zprt
+    type(bar_zbprt), allocatable  :: bpv(:) 
+  end type bar_zprt
+end module bar_prt
+
+module bar_pr_mod
+  use bar_prt
+  interface bar_pwrk
+    subroutine bar_dppwrk(pr,x,y,cd,info,trans,work)
+      use foo_base_mod
+      use bar_prt
+      type(foo_cdt),intent(in)    :: cd
+      type(bar_dprt), intent(in)  :: pr
+      real(kind(0.d0)),intent(inout)    :: x(:), y(:)
+      integer, intent(out)              :: info
+      character(len=1), optional        :: trans
+      real(kind(0.d0)),intent(inout), optional, target :: work(:)
+    end subroutine bar_dppwrk
+    subroutine bar_zppwrk(pr,x,y,cd,info,trans,work)
+      use foo_base_mod
+      use bar_prt
+      type(foo_cdt),intent(in)    :: cd
+      type(bar_zprt), intent(in)  :: pr
+      complex(kind(0.d0)),intent(inout) :: x(:), y(:)
+      integer, intent(out)              :: info
+      character(len=1), optional        :: trans
+      complex(kind(0.d0)),intent(inout), optional, target :: work(:)
+    end subroutine bar_zppwrk
+  end interface
+end module bar_pr_mod
+
+module foo_pr_mod
+  use bar_prt, &
+       & foo_dbprt  => bar_dbprt,&
+       & foo_zbprt  => bar_zbprt,&
+       & foo_dprt   => bar_dprt,&
+       & foo_zprt   => bar_zprt 
+  use bar_pr_mod, &
+       & foo_pwrk  => bar_pwrk
+end module foo_pr_mod
+
+Subroutine foo_sub(a,pr,b,x,eps,cd,info)
+  use foo_base_mod
+  use foo_pr_mod
+  Implicit None
+!!$  parameters 
+  Type(foo_dmt), Intent(in)  :: a
+  Type(foo_dprt), Intent(in)   :: pr 
+  Type(foo_cdt), Intent(in)    :: cd
+  Real(Kind(1.d0)), Intent(in)       :: b(:)
+  Real(Kind(1.d0)), Intent(inout)    :: x(:)
+  Real(Kind(1.d0)), Intent(in)       :: eps
+  integer, intent(out)               :: info
+!!$   Local data
+  Real(Kind(1.d0)), allocatable, target   :: aux(:),wwrk(:,:)
+  Real(Kind(1.d0)), allocatable   :: p(:), f(:)
+  info = 0
+  Call foo_pwrk(pr,p,f,cd,info,work=aux)  ! This worked if bar_pwrk was called!
+  return
+End Subroutine foo_sub
+
+! { dg-final { cleanup-modules "foo_base_mod foo_pr_mod bar_pr_mod bar_prt" } }
+

gcc/testsuite/gfortran.dg/overload_2.f90

@@ -0,0 +1,27 @@
+! { dg-do compile }
+! Test the fix for PR32157, in which overloading 'LEN', as
+! in 'test' below would cause a compile error.
+!
+! Contributed by Michael Richmond <michael.a.richmond@nasa.gov>
+!
+subroutine len(c)
+  implicit none
+  character :: c
+  c = "X"
+end subroutine len
+
+subroutine test()
+  implicit none
+  character :: str
+  external len
+  call len(str)
+  if(str /= "X") call abort()
+end subroutine test
+
+PROGRAM VAL
+ implicit none
+ external test
+ intrinsic len
+ call test()
+ if(len(" ") /= 1) call abort()
+END

gcc/testsuite/gfortran.dg/transfer_simplify_5.f90

@@ -0,0 +1,16 @@
+! { dg-do compile }
+! Tests the fix for PR32689, in which the TRANSFER with MOLD
+! an array variable, as below, did not simplify.
+!
+! Contributed by Harald Anlauf <anlauf@gmx.de>
+!
+program gfcbug67
+  implicit none
+
+  type mytype
+     integer, pointer :: i(:) => NULL ()
+  end type mytype
+  type(mytype) :: t
+
+  print *, size (transfer (1, t% i))
+end program gfcbug67