re PR fortran/29373 (implicit type declaration and contained function clash)

2006-10-13 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/29373
	* decl.c (get_proc_name, gfc_match_function_decl): Add
	attr.implicit_type to conditions that throw error for
	existing explicit interface and that allow new type-
	spec to be applied.

	PR fortran/29407
	* resolve.c (resolve_fl_namelist): Do not check for
	namelist/procedure conflict, if the symbol corresponds
	to a good local variable declaration.

	PR fortran/27701
	* decl.c (get_proc_name): Replace the detection of a declared
	procedure by the presence of a formal argument list by the
	attributes of the symbol and the presence of an explicit
	interface.

	PR fortran/29232
	* resolve.c (resolve_fl_variable): See if the host association
	of a derived type is blocked by the presence of another type I
	object in the current namespace.

	PR fortran/29364
	* resolve.c (resolve_fl_derived): Check for the presence of
	the derived type for a derived type component.

	PR fortran/24398
	* module.c (gfc_use_module): Check that the first words in a
	module file are 'GFORTRAN module'.

	PR fortran/29422
	* resolve.c (resolve_transfer): Test functions for suitability
	for IO, as well as variables.

	PR fortran/29428
	* trans-expr.c (gfc_trans_scalar_assign): Remove nullify of
	rhs expression.


2006-10-13 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/29373
	* gfortran.dg/implicit_9.f90: New test.

	PR fortran/29407
	* gfortran.dg/namelist_25.f90: New test.

	PR fortran/27701
	* gfortran.dg/same_name_2.f90: New test.

	PR fortran/29232
	* gfortran.dg/host_assoc_types_1.f90: New test.

	PR fortran/29364
	* gfortran.dg/missing_derived_type_1.f90: New test.
	* gfortran.dg/implicit_actual.f90: Comment out USE GLOBAL.

	PR fortran/29422
	* gfortran.dg/alloc_comp_constraint_4.f90: New test.

	PR fortran/29428
	* gfortran.dg/alloc_comp_assign_5.f90: New test.

From-SVN: r117692

gcc/fortran/ChangeLog

@@ -1,3 +1,43 @@
+2006-10-13 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29373
+	* decl.c (get_proc_name, gfc_match_function_decl): Add
+	attr.implicit_type to conditions that throw error for
+	existing explicit interface and that allow new type-
+	spec to be applied.
+
+	PR fortran/29407
+	* resolve.c (resolve_fl_namelist): Do not check for
+	namelist/procedure conflict, if the symbol corresponds
+	to a good local variable declaration.
+
+	PR fortran/27701
+	* decl.c (get_proc_name): Replace the detection of a declared
+	procedure by the presence of a formal argument list by the
+	attributes of the symbol and the presence of an explicit
+	interface.
+
+	PR fortran/29232
+	* resolve.c (resolve_fl_variable): See if the host association
+	of a derived type is blocked by the presence of another type I
+	object in the current namespace.
+
+	PR fortran/29364
+	* resolve.c (resolve_fl_derived): Check for the presence of
+	the derived type for a derived type component.
+
+	PR fortran/24398
+	* module.c (gfc_use_module): Check that the first words in a
+	module file are 'GFORTRAN module'.
+
+	PR fortran/29422
+	* resolve.c (resolve_transfer): Test functions for suitability
+	for IO, as well as variables.
+
+	PR fortran/29428
+	* trans-expr.c (gfc_trans_scalar_assign): Remove nullify of
+	rhs expression.
+
 2006-10-13  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	PR fortran/29391

gcc/fortran/decl.c

@@ -635,7 +635,8 @@ get_proc_name (const char *name, gfc_symbol ** result,
 	 accessible names.  */
       if (sym->attr.flavor != 0
 	    && sym->attr.proc != 0
-	    && sym->formal)
+	    && (sym->attr.subroutine || sym->attr.function)
+	    && sym->attr.if_source != IFSRC_UNKNOWN)
 	gfc_error_now ("Procedure '%s' at %C is already defined at %L",
 		       name, &sym->declared_at);
 
@@ -643,6 +644,7 @@ get_proc_name (const char *name, gfc_symbol ** result,
 	 signature for this is that ts.kind is set.  Legitimate
 	 references only set ts.type.  */
       if (sym->ts.kind != 0
+	    && !sym->attr.implicit_type
 	    && sym->attr.proc == 0
 	    && gfc_current_ns->parent != NULL
 	    && sym->attr.access == 0
@@ -2679,7 +2681,9 @@ gfc_match_function_decl (void)
       || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
     goto cleanup;
 
-  if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN)
+  if (current_ts.type != BT_UNKNOWN
+	&& sym->ts.type != BT_UNKNOWN
+	&& !sym->attr.implicit_type)
     {
       gfc_error ("Function '%s' at %C already has a type of %s", name,
 		 gfc_basic_typename (sym->ts.type));

gcc/fortran/module.c

@@ -3790,7 +3790,7 @@ gfc_use_module (void)
 {
   char *filename;
   gfc_state_data *p;
-  int c, line;
+  int c, line, start;
 
   filename = (char *) alloca(strlen(module_name) + strlen(MODULE_EXTENSION)
 			     + 1);
@@ -3805,15 +3805,23 @@ gfc_use_module (void)
   iomode = IO_INPUT;
   module_line = 1;
   module_column = 1;
+  start = 0;
 
-  /* Skip the first two lines of the module.  */
-  /* FIXME: Could also check for valid two lines here, instead.  */
+  /* Skip the first two lines of the module, after checking that this is
+     a gfortran module file.  */
   line = 0;
   while (line < 2)
     {
       c = module_char ();
       if (c == EOF)
 	bad_module ("Unexpected end of module");
+      if (start++ < 2)
+	parse_name (c);
+      if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
+	    || (start == 2 && strcmp (atom_name, " module") != 0))
+	gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
+			  "file", filename);
+
       if (c == '\n')
 	line++;
     }

gcc/fortran/resolve.c

@@ -4167,7 +4167,8 @@ resolve_transfer (gfc_code * code)
 
   exp = code->expr;
 
-  if (exp->expr_type != EXPR_VARIABLE)
+  if (exp->expr_type != EXPR_VARIABLE
+	&& exp->expr_type != EXPR_FUNCTION)
     return;
 
   sym = exp->symtree->n.sym;
@@ -5384,6 +5385,24 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
       return FAILURE;
     }
 
+  /* Check to see if a derived type is blocked from being host associated
+     by the presence of another class I symbol in the same namespace.
+     14.6.1.3 of the standard and the discussion on comp.lang.fortran.  */
+  if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns)
+    {
+      gfc_symbol *s;
+      gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
+      if (s && (s->attr.flavor != FL_DERIVED
+		  || !gfc_compare_derived_types (s, sym->ts.derived)))
+	{
+	  gfc_error ("The type %s cannot be host associated at %L because "
+		     "it is blocked by an incompatible object of the same "
+		     "name at %L", sym->ts.derived->name, &sym->declared_at,
+		     &s->declared_at);
+	  return FAILURE;
+	}
+    }
+
   /* 4th constraint in section 11.3:  "If an object of a type for which
      component-initialization is specified (R429) appears in the
      specification-part of a module and does not have the ALLOCATABLE
@@ -5577,6 +5596,15 @@ resolve_fl_derived (gfc_symbol *sym)
 	    }
 	}
 
+      if (c->ts.type == BT_DERIVED && c->pointer
+	    && c->ts.derived->components == NULL)
+	{
+	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
+		     "that has not been declared", c->name, sym->name,
+		     &c->loc);
+	  return FAILURE;
+	}
+
       if (c->pointer || c->allocatable ||  c->as == NULL)
 	continue;
 
@@ -5668,16 +5696,18 @@ resolve_fl_namelist (gfc_symbol *sym)
      same message has been used.  */
   for (nl = sym->namelist; nl; nl = nl->next)
     {
+      if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
+	continue;
       nlsym = NULL;
-	if (sym->ns->parent && nl->sym && nl->sym->name)
-	  gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
-	if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
-	  {
-	    gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
-		       "attribute in '%s' at %L", nlsym->name,
-		       &sym->declared_at);
-	    return FAILURE;
-	  }
+      if (sym->ns->parent && nl->sym && nl->sym->name)
+	gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
+      if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
+	{
+	  gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
+		     "attribute in '%s' at %L", nlsym->name,
+		     &sym->declared_at);
+	  return FAILURE;
+	}
     }
 
   return SUCCESS;

gcc/fortran/trans-expr.c

@@ -3261,19 +3261,13 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
 
       /* Do a deep copy if the rhs is a variable, if it is not the
-	 same as the lhs.  Otherwise, nullify the data fields so that the
-	 lhs retains the allocated resources.  */
+	 same as the lhs.  */
       if (r_is_var)
 	{
 	  tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
 	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
-      else
-	{
-	  tmp = gfc_nullify_alloc_comp (ts.derived, rse->expr, 0);
-	  gfc_add_expr_to_block (&block, tmp);
-	}
     }
   else
     {

gcc/testsuite/ChangeLog

@@ -1,3 +1,27 @@
+2006-10-13 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29373
+	* gfortran.dg/implicit_9.f90: New test.
+
+	PR fortran/29407
+	* gfortran.dg/namelist_25.f90: New test.
+
+	PR fortran/27701
+	* gfortran.dg/same_name_2.f90: New test.
+
+	PR fortran/29232
+	* gfortran.dg/host_assoc_types_1.f90: New test.
+
+	PR fortran/29364
+	* gfortran.dg/missing_derived_type_1.f90: New test.
+	* gfortran.dg/implicit_actual.f90: Comment out USE GLOBAL.
+
+	PR fortran/29422
+	* gfortran.dg/alloc_comp_constraint_4.f90: New test.
+
+	PR fortran/29428
+	* gfortran.dg/alloc_comp_assign_5.f90: New test.
+
 2006-10-13  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	PR fortran/29391

gcc/testsuite/gfortran.dg/alloc_comp_assign_5.f90

@@ -0,0 +1,33 @@
+! { dg-do run }
+! { dg-options "-O2" }
+! Tests the fix for PR29428, in which the assignment of
+! a function result would result in the function being
+! called twice, if it were not a result by reference,
+! because of a spurious nullify in gfc_trans_scalar_assign.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+program test
+implicit none
+
+  type A
+    integer, allocatable :: j(:)
+  end type A
+
+  type(A):: x
+  integer :: ctr = 0
+
+  x = f()
+
+  if (ctr /= 1) call abort ()
+
+contains
+
+  function f()
+    type(A):: f
+      ctr = ctr + 1
+      f = A ((/1,2/))
+  end function f
+
+end program
+

gcc/testsuite/gfortran.dg/alloc_comp_constraint_4.f90

@@ -0,0 +1,21 @@
+! { dg-do compile }
+! Tests the fix for PR29422, in which function results
+! were not tested for suitability in IO statements.
+!
+! Contributed by Dominique d'Humieres  <dominiq@lps.ens.fr>
+!
+Type drv
+ Integer :: i
+ Integer, allocatable :: arr(:)
+End type drv
+
+  print *, fun1 () ! { dg-error "cannot have ALLOCATABLE" }
+
+contains
+  Function fun1 ()
+
+    Type(drv) :: fun1
+    fun1%i = 10
+  end function fun1
+end
+

gcc/testsuite/gfortran.dg/host_assoc_types_1.f90

@@ -0,0 +1,18 @@
+! { dg-do compile }
+! Tests the fix for PR29232, in which the invalid code below was not
+! diagnosed.
+!
+! Contributed by Tobias Burnus  <tobias.burnus@physik.fu-berlin.de>
+!
+MODULE test
+     TYPE vertex
+           INTEGER :: k
+     END TYPE vertex
+CONTAINS
+     SUBROUTINE S1()
+         TYPE(vertex) :: a  ! { dg-error "cannot be host associated" }
+         vertex : DO i=1,2  ! { dg-error "incompatible object of the same name" }
+         ENDDO vertex
+     END SUBROUTINE
+END MODULE test
+! { dg-final { cleanup-modules "test" } }

gcc/testsuite/gfortran.dg/implicit_9.f90

@@ -0,0 +1,24 @@
+! { dg-do compile }
+! Tests patch for PR29373, in which the implicit character
+! statement messes up the function declaration because the
+! requisite functions in decl.c were told nothing about
+! implicit types.
+!
+! Contributed by Tobias Schlueter  <tobi@gcc.gnu.org>
+!
+  implicit character*32 (a-z)
+  CHARACTER(len=255), DIMENSION(1,2)  :: a
+
+! Reporters original, which triggers another error:
+! gfc_todo: Not Implemented: complex character array
+! constructors.=> PR29431
+!  a = reshape((/ to_string(1.0) /), (/ 1, 2 /))
+
+  a = to_string(1.0)
+  print *, a
+  CONTAINS
+    CHARACTER*(32) FUNCTION to_string(x)
+      REAL, INTENT(in) :: x
+      WRITE(to_string, FMT="(F6.3)") x
+    END FUNCTION
+END PROGRAM

gcc/testsuite/gfortran.dg/implicit_actual.f90

@@ -1,19 +1,19 @@
 ! { dg-do compile }
-! { dg-options "-O0" }
 ! Tests patch for problem that was found whilst investigating
 ! PR24158. The call to foo would cause an ICE because the
-! actual argument was of a type that was not defined.
+! actual argument was of a type that was not defined.  The USE
+! GLOBAL was commented out, following the fix for PR29364.
 !
 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
 !
 module global
   type :: t2
-    type(t3), pointer :: d
+    type(t3), pointer :: d ! { dg-error "has not been declared" }
   end type t2
 end module global
 
 program snafu
-  use global
+!  use global
   implicit type (t3) (z)
 
   call foo (zin) ! { dg-error "defined|Type/rank" }

gcc/testsuite/gfortran.dg/missing_derived_type_1.f90

@@ -0,0 +1,14 @@
+! { dg-do compile }
+! Tests the fix for PR29364, in which the the absence of the derived type
+! 'nonexist' was not diagnosed.
+!
+! Contributed by Tobias Burnus  <tobias.burnus@physik.fu-berlin.de>
+!
+module test
+  implicit none
+  type epot_t
+    integer :: c
+    type(nonexist),pointer :: l ! { dg-error "has not been declared" }
+  end type epot_t
+end module test
+! { dg-final { cleanup-modules "test" } }

gcc/testsuite/gfortran.dg/namelist_25.f90

@@ -0,0 +1,18 @@
+! { dg-do compile }
+! Tests patch for PR29407, in which the declaration of 'my' as
+! a local variable was ignored, so that the procedure and namelist
+! attributes for 'my' clashed..
+!
+! Contributed by Tobias Burnus  <tobias.burnus@physik.fu-berlin.de>
+!
+program main
+  implicit none
+contains
+  subroutine my
+  end subroutine my
+  subroutine bar
+    integer :: my
+    namelist /ops/ my
+  end subroutine bar
+end program main
+

gcc/testsuite/gfortran.dg/same_name_2.f90

@@ -0,0 +1,16 @@
+! ( dg-do compile }
+! Tests the fix for PR27701, in which two same name procedures
+! were not diagnosed if they had no arguments.
+!
+! Contributed by Arjen Markus  <arjen.markus@wldelft.nl>
+!
+module aha
+contains
+subroutine aa ! { dg-error "Procedure" }
+   write(*,*) 'AA'
+end subroutine aa
+subroutine aa ! { dg-error "is already defined" }
+   write(*,*) 'BB'
+end subroutine aa
+end module
+! { dg-final { cleanup-modules "aha" } }