2005-11-06 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/24534
	* resolve.c (resolve_symbol): Exclude case of PRIVATE declared
	within derived type from error associated with PRIVATE type
	components within derived type.

	PR fortran/20838
	PR fortran/20840
	* gfortran.h: Add prototype for gfc_has_vector_index.
	* io.c (gfc_resolve_dt): Error if internal unit has a vector index.
	* expr.c (gfc_has_vector_index): New function to check if any of
	the array references of an expression have vector inidices.
	(gfc_check_pointer_assign): Error if internal unit has a vector index.

	PR fortran/17737
	* data.c (gfc_assign_data_value): Remove gcc_assert that caused the ICE
	and replace by a standard dependent warning/error if overwriting an
	existing initialization.
	* decl.c (gfc_data_variable): Remove old error for already initialized
	variable and the unused error check for common block variables.  Add
	error for hots associated variable and standard dependent error for
	common block variables, outside of blockdata.
	* symbol.c (check_conflict): Add constraints for DATA statement.

2005-11-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/24534
	gfortran.dg/private_type_2.f90: Modified to check that case with
	PRIVATE declaration within derived type is accepted.

	PR fortran/20838
	gfortran.dg/pointer_assign_1.f90: New test.

	PR fortran/20840
	* gfortran.dg/arrayio_0.f90: New test.

	PR fortran/17737
	gfortran.dg/data_initialized.f90: New test.
	gfortran.dg/data_constraints_1.f90: New test.
	gfortran.dg/data_constraints_2.f90: New test.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@106567 138bc75d-0d04-0410-961f-82ee72b054a4

15 files changed, 209 insertions, 21 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d7da455b3d4..60b20b76970 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,28 @@
+2005-11-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24534
+	* resolve.c (resolve_symbol): Exclude case of PRIVATE declared
+	within derived type from error associated with PRIVATE type
+	components within derived type.
+
+	PR fortran/20838
+	PR fortran/20840
+	* gfortran.h: Add prototype for gfc_has_vector_index.
+	* io.c (gfc_resolve_dt): Error if internal unit has a vector index.
+	* expr.c (gfc_has_vector_index): New function to check if any of
+	the array references of an expression have vector inidices.
+	(gfc_check_pointer_assign): Error if internal unit has a vector index.
+
+	PR fortran/17737
+	* data.c (gfc_assign_data_value): Remove gcc_assert that caused the ICE
+	and replace by a standard dependent warning/error if overwriting an
+	existing initialization.
+	* decl.c (gfc_data_variable): Remove old error for already initialized
+	variable and the unused error check for common block variables.  Add
+	error for hots associated variable and standard dependent error for
+	common block variables, outside of blockdata.
+	* symbol.c (check_conflict): Add constraints for DATA statement.
+
 2005-11-06  Janne Blomqvist <jb@gcc.gnu.org>
 
 	PR fortran/24174
diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index d614db4a084..fdb98569c7a 100644
--- a/gcc/fortran/data.c
+++ b/gcc/fortran/data.c
@@ -315,8 +315,19 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
     expr = create_character_intializer (init, last_ts, ref, rvalue);
   else
     {
-      /* We should never be overwriting an existing initializer.  */
-      gcc_assert (!init);
+      /* Overwriting an existing initializer is non-standard but usually only
+	 provokes a warning from other compilers.  */
+      if (init != NULL)
+	{
+	  /* Order in which the expressions arrive here depends on whether they
+	     are from data statements or F95 style declarations. Therefore,
+	     check which is the most recent.  */
+	  expr = (init->where.lb->linenum > rvalue->where.lb->linenum) ?
+		    init : rvalue;
+	  gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
+			  "of '%s' at %L",  symbol->name, &expr->where);
+	  return;
+	}
 
       expr = gfc_copy_expr (rvalue);
       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index aaad320971b..8352c527461 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -203,24 +203,19 @@ var_element (gfc_data_variable * new)
 
   sym = new->expr->symtree->n.sym;
 
-  if(sym->value != NULL)
+  if (!sym->attr.function && gfc_current_ns->parent && gfc_current_ns->parent == sym->ns)
     {
-      gfc_error ("Variable '%s' at %C already has an initialization",
-		 sym->name);
+      gfc_error ("Host associated variable '%s' may not be in the DATA "
+		 "statement at %C.", sym->name);
       return MATCH_ERROR;
     }
 
-#if 0 /* TODO: Find out where to move this message */
-  if (sym->attr.in_common)
-    /* See if sym is in the blank common block.  */
-    for (t = &sym->ns->blank_common; t; t = t->common_next)
-      if (sym == t->head)
-	{
-	  gfc_error ("DATA statement at %C may not initialize variable "
-		     "'%s' from blank COMMON", sym->name);
-	  return MATCH_ERROR;
-	}
-#endif
+  if (gfc_current_state () != COMP_BLOCK_DATA
+	&& sym->attr.in_common
+	&& gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
+			   "common block variable '%s' in DATA statement at %C",
+			   sym->name) == FAILURE)
+    return MATCH_ERROR;
 
   if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
     return MATCH_ERROR;
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 80099df5ad4..1ceec01eae0 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -311,6 +311,23 @@ copy_ref (gfc_ref * src)
 }
 
 
+/* Detect whether an expression has any vector index array
+   references.  */
+
+int
+gfc_has_vector_index (gfc_expr *e)
+{
+  gfc_ref * ref;
+  int i;
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY)
+      for (i = 0; i < ref->u.ar.dimen; i++)
+	if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+	  return 1;
+  return 0;
+}
+
+
 /* Copy a shape array.  */
 
 mpz_t *
@@ -1962,6 +1979,13 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
       return FAILURE;
     }
 
+  if (gfc_has_vector_index (rvalue))
+    {
+      gfc_error ("Pointer assignment with vector subscript "
+		 "on rhs at %L", &rvalue->where);
+      return FAILURE;
+    }
+
   return SUCCESS;
 }
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 96bd38666ba..5626cc986a7 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1790,6 +1790,7 @@ void gfc_free_ref_list (gfc_ref *);
 void gfc_type_convert_binary (gfc_expr *);
 int gfc_is_constant_expr (gfc_expr *);
 try gfc_simplify_expr (gfc_expr *, int);
+int gfc_has_vector_index (gfc_expr *);
 
 gfc_expr *gfc_get_expr (void);
 void gfc_free_expr (gfc_expr *);
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 9f459c68363..183948e5788 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -1787,6 +1787,13 @@ gfc_resolve_dt (gfc_dt * dt)
   /* Sanity checks on data transfer statements.  */
   if (e->ts.type == BT_CHARACTER)
     {
+      if (gfc_has_vector_index (e))
+	{
+	  gfc_error ("Internal unit with vector subscript at %L",
+		     &e->where);
+	  return FAILURE;
+	}
+
       if (dt->rec != NULL)
 	{
 	  gfc_error ("REC tag at %L is incompatible with internal file",
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6db0f1e6a44..50d22b0ea83 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4358,9 +4358,11 @@ resolve_symbol (gfc_symbol * sym)
       return;
     }
 
-  /* Ensure that derived type components of a public derived type
-     are not of a private type.  */
+  /* If a component of a derived type is of a type declared to be private,
+     either the derived type definition must contain the PRIVATE statement,
+     or the derived type must be private.  (4.4.1 just after R427) */
   if (sym->attr.flavor == FL_DERIVED
+	&& sym->component_access != ACCESS_PRIVATE
 	&& gfc_check_access(sym->attr.access, sym->ns->default_access))
     {
       for (c = sym->components; c; c = c->next)
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 43209e4ccae..20fb7470dff 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -264,7 +264,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
     *function = "FUNCTION", *subroutine = "SUBROUTINE",
     *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
     *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
-    *cray_pointee = "CRAY POINTEE";
+    *cray_pointee = "CRAY POINTEE", *data = "DATA";
 
   const char *a1, *a2;
 
@@ -373,6 +373,12 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
   conf (cray_pointee, in_common);
   conf (cray_pointee, in_equivalence);
 
+  conf (data, dummy);
+  conf (data, function);
+  conf (data, result);
+  conf (data, allocatable);
+  conf (data, use_assoc);
+
   a1 = gfc_code2string (flavors, attr->flavor);
 
   if (attr->in_namelist
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 212f2328295..0dca65ba811 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,20 @@
+2005-11-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24534
+	gfortran.dg/private_type_2.f90: Modified to check that case with
+	PRIVATE declaration within derived type is accepted.
+
+	PR fortran/20838
+	gfortran.dg/pointer_assign_1.f90: New test.
+
+	PR fortran/20840
+	* gfortran.dg/arrayio_0.f90: New test.
+
+	PR fortran/17737
+	gfortran.dg/data_initialized.f90: New test.
+	gfortran.dg/data_constraints_1.f90: New test.
+	gfortran.dg/data_constraints_2.f90: New test.
+
 2005-11-06  Janne Blomqvist <jb@gcc.gnu.org>
 
 	PR fortran/24174
diff --git a/gcc/testsuite/gfortran.dg/arrayio_0.f90 b/gcc/testsuite/gfortran.dg/arrayio_0.f90
new file mode 100755
index 00000000000..1331cf2edda
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/arrayio_0.f90
@@ -0,0 +1,19 @@
+! { dg-do compile }
+! Tests fix for PR20840 - would ICE with vector subscript in 
+! internal unit.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+  character(len=12), dimension(4) :: iu, buff
+  character(len=48), dimension(2) :: iue
+  equivalence (iu, iue)
+  integer, dimension(4) :: v = (/2,1,4,3/)
+  iu = (/"Vector","subscripts","not","allowed!"/)
+  read (iu, '(a12/)') buff
+  read (iue(1), '(4a12)') buff
+  read (iu(4:1:-1), '(a12/)') buff
+  read (iu(v), '(a12/)') buff           ! { dg-error "with vector subscript" }
+  read (iu((/2,4,3,1/)), '(a12/)') buff ! { dg-error "with vector subscript" }
+  print *, buff
+  end
+
diff --git a/gcc/testsuite/gfortran.dg/data_constraints_1.f90 b/gcc/testsuite/gfortran.dg/data_constraints_1.f90
new file mode 100644
index 00000000000..5f11ffdbaea
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_constraints_1.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! Tests standard indepedendent constraints for variables in a data statement
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+  module global
+   integer n
+  end module global
+
+  use global
+  integer q
+  data n /0/            ! { dg-error "Cannot change attributes" }
+  n = 1
+  n = foo (n)
+contains
+  function foo (m) result (bar)
+  integer p (m), bar
+  integer, allocatable :: l(:)
+  allocate (l(1))
+  data l /42/           ! { dg-error "conflicts with ALLOCATABLE" }
+  data p(1) /1/         ! { dg-error "non-constant array in DATA" }
+  data q /1/            ! { dg-error "Host associated variable" }
+  data m /1/            ! { dg-error "conflicts with DUMMY attribute" }
+  data bar /99/         ! { dg-error "conflicts with RESULT" }
+  end function foo
+  function foobar ()
+  integer foobar
+  data foobar /0/       ! { dg-error "conflicts with FUNCTION" }
+  end function foobar
+end
diff --git a/gcc/testsuite/gfortran.dg/data_constraints_2.f90 b/gcc/testsuite/gfortran.dg/data_constraints_2.f90
new file mode 100644
index 00000000000..46de3c81434
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_constraints_2.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+! Tests constraints for variables in a data statement that are commonly
+! relaxed.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+  common // a
+  common /b/ c
+  integer d
+  data a /1/            ! { dg-error "common block variable" }
+  data c /2/            ! { dg-error "common block variable" }
+  data d /3/
+  data d /4/            ! { dg-error " re-initialization" }
+end
diff --git a/gcc/testsuite/gfortran.dg/data_initialized.f90 b/gcc/testsuite/gfortran.dg/data_initialized.f90
new file mode 100644
index 00000000000..56cf059ae36
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_initialized.f90
@@ -0,0 +1,10 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+! Tests fix for PR17737 - already initialized variable cannot appear
+! in data statement
+      integer :: i, j = 1
+      data i/0/
+      data i/0/   ! { dg-error "Extension: re-initialization" }
+      data j/2/   ! { dg-error "Extension: re-initialization" }
+      end
+
diff --git a/gcc/testsuite/gfortran.dg/pointer_assign_1.f90 b/gcc/testsuite/gfortran.dg/pointer_assign_1.f90
new file mode 100755
index 00000000000..cfe8ad17006
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_assign_1.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+! Tests fix for PR20838 - would ICE with vector subscript in 
+! pointer assignment.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+  integer, parameter, dimension(3) :: i = (/2,1,3/)
+  integer, dimension(3), target   :: tar
+  integer, dimension(2, 3), target   :: tar2
+  integer, dimension(:), pointer  :: ptr
+  ptr => tar
+  ptr => tar(3:1:-1)
+  ptr => tar(i)     ! { dg-error "with vector subscript" }
+  ptr => tar2(1, :)
+  ptr => tar2(2, i) ! { dg-error "with vector subscript" }
+  end
+
diff --git a/gcc/testsuite/gfortran.dg/private_type_2.f90 b/gcc/testsuite/gfortran.dg/private_type_2.f90
index 6078293743f..9cb0b380703 100644
--- a/gcc/testsuite/gfortran.dg/private_type_2.f90
+++ b/gcc/testsuite/gfortran.dg/private_type_2.f90
@@ -1,5 +1,9 @@
 ! { dg-do compile }
-! PR16404 test 6 - A public type cannot have private-type components.
+! PR16404 test 6 - If a component of a derived type is of a type declared to
+! be private, either the derived type definition must contain the PRIVATE
+! statement, or the derived type must be private.
+! Modified on 20051105 to test PR24534.
+!
 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
 MODULE TEST
   PRIVATE
@@ -9,7 +13,12 @@ MODULE TEST
   TYPE :: all_type! { dg-error "PRIVATE type and cannot be a component" }
     TYPE(info_type) :: info
   END TYPE
-  public  all_type
+  TYPE :: any_type! This is OK because of the PRIVATE statement.
+    PRIVATE
+    TYPE(info_type) :: info
+  END TYPE
+  public  all_type, any_type
 END MODULE
 END
 
+