re PR fortran/29699 (ICE in trans-decl.c)

2006-11-09 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/29699
	* trans-array.c (structure_alloc_comps): Detect pointers to
	arrays and use indirect reference to declaration.
	* resolve.c (resolve_fl_variable): Tidy up condition.
	(resolve_symbol): The same and only add initialization code if
	the symbol is referenced.
	* trans-decl.c (gfc_trans_deferred_vars): Call gfc_trans_
	deferred_array before gfc_trans_auto_array_allocation.

	PR fortran/21730
	* symbol.c (check_done): Remove.
	(gfc_add_attribute): Remove reference to check_done and remove
	the argument attr_intent.
	(gfc_add_allocatable, gfc_add_dimension, gfc_add_external,
	gfc_add_intrinsic, gfc_add_optional, gfc_add_pointer,
	gfc_add_cray_pointer, gfc_add_cray_pointee, gfc_add_result,
	gfc_add_target, gfc_add_in_common, gfc_add_elemental,
	gfc_add_pure, gfc_add_recursive, gfc_add_procedure,
	gfc_add_type): Remove references to check_done.
	* decl.c (attr_decl1): Eliminate third argument in call to
	gfc_add_attribute.
	* gfortran.h : Change prototype for gfc_add_attribute.



2006-11-09 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/29699
	* gfortran.dg/alloc_comp_auto_array_1.f90: New test.

	PR fortran/21730
	* gfortran.dg/change_symbol_attributes_1.f90: New test.

From-SVN: r118624

gcc/fortran/ChangeLog

+2006-11-09 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29699
+	* trans-array.c (structure_alloc_comps): Detect pointers to
+	arrays and use indirect reference to declaration.
+	* resolve.c (resolve_fl_variable): Tidy up condition.
+	(resolve_symbol): The same and only add initialization code if
+	the symbol is referenced.
+	* trans-decl.c (gfc_trans_deferred_vars): Call gfc_trans_
+	deferred_array before gfc_trans_auto_array_allocation.
+
+	PR fortran/21730
+	* symbol.c (check_done): Remove.
+	(gfc_add_attribute): Remove reference to check_done and remove
+	the argument attr_intent.
+	(gfc_add_allocatable, gfc_add_dimension, gfc_add_external,
+	gfc_add_intrinsic, gfc_add_optional, gfc_add_pointer,
+	gfc_add_cray_pointer, gfc_add_cray_pointee, gfc_add_result,
+	gfc_add_target, gfc_add_in_common, gfc_add_elemental,
+	gfc_add_pure, gfc_add_recursive, gfc_add_procedure,
+	gfc_add_type): Remove references to check_done.
+	* decl.c (attr_decl1): Eliminate third argument in call to
+	gfc_add_attribute.
+	* gfortran.h : Change prototype for gfc_add_attribute.
+
 2006-11-08  Brooks Moses  <brooks.moses@codesourcery.com>
 
 	* invoke.texi: Added documentation for -fmax-errors option.

gcc/fortran/decl.c

@@ -3330,7 +3330,7 @@ attr_decl1 (void)
 	goto cleanup;
     }
 
-  if (gfc_add_attribute (&sym->attr, &var_locus, current_attr.intent) == FAILURE)
+  if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
     {
       m = MATCH_ERROR;
       goto cleanup;

gcc/fortran/gfortran.h

@@ -1838,7 +1838,7 @@ void gfc_get_component_attr (symbol_attribute *, gfc_component *);
 
 void gfc_set_sym_referenced (gfc_symbol * sym);
 
-try gfc_add_attribute (symbol_attribute *, locus *, unsigned int);
+try gfc_add_attribute (symbol_attribute *, locus *);
 try gfc_add_allocatable (symbol_attribute *, locus *);
 try gfc_add_dimension (symbol_attribute *, const char *, locus *);
 try gfc_add_external (symbol_attribute *, locus *);

gcc/fortran/resolve.c

@@ -5497,8 +5497,11 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
     }
 
   /* Assign default initializer.  */
-  if (sym->ts.type == BT_DERIVED && !sym->value && !sym->attr.pointer
-      && !sym->attr.allocatable && (!flag || sym->attr.intent == INTENT_OUT))
+  if (sym->ts.type == BT_DERIVED
+	&& !sym->value
+	&& !sym->attr.pointer
+	&& !sym->attr.allocatable
+	&& (!flag || sym->attr.intent == INTENT_OUT))
     sym->value = gfc_default_initializer (&sym->ts);
 
   return SUCCESS;
@@ -6036,8 +6039,12 @@ resolve_symbol (gfc_symbol * sym)
   /* If we have come this far we can apply default-initializers, as
      described in 14.7.5, to those variables that have not already
      been assigned one.  */
-  if (sym->ts.type == BT_DERIVED && sym->ns == gfc_current_ns && !sym->value
-	&& !sym->attr.allocatable && !sym->attr.alloc_comp)
+  if (sym->ts.type == BT_DERIVED
+	&& sym->attr.referenced
+	&& sym->ns == gfc_current_ns
+	&& !sym->value
+	&& !sym->attr.allocatable
+	&& !sym->attr.alloc_comp)
     {
       symbol_attribute *a = &sym->attr;
 

gcc/fortran/symbol.c

@@ -601,28 +601,6 @@ check_used (symbol_attribute * attr, const char * name, locus * where)
 }
 
 
-/* Used to prevent changing the attributes of a symbol after it has been
-   used.  This check is only done for dummy variables as only these can be
-   used in specification expressions.  Applying this to all symbols causes
-   an error when we reach the body of a contained function.  */
-
-static int
-check_done (symbol_attribute * attr, locus * where)
-{
-
-  if (!(attr->dummy && attr->referenced))
-    return 0;
-
-  if (where == NULL)
-    where = &gfc_current_locus;
-
-  gfc_error ("Cannot change attributes of symbol at %L"
-             " after it has been used", where);
-
-  return 1;
-}
-
-
 /* Generate an error because of a duplicate attribute.  */
 
 static void
@@ -638,12 +616,9 @@ duplicate_attr (const char *attr, locus * where)
 /* Called from decl.c (attr_decl1) to check attributes, when declared separately.  */
 
 try
-gfc_add_attribute (symbol_attribute * attr, locus * where,
-		   unsigned int attr_intent)
+gfc_add_attribute (symbol_attribute * attr, locus * where)
 {
-
-  if (check_used (attr, NULL, where)
-	|| (attr_intent == 0 && check_done (attr, where)))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   return check_conflict (attr, NULL, where);
@@ -653,7 +628,7 @@ try
 gfc_add_allocatable (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   if (attr->allocatable)
@@ -671,7 +646,7 @@ try
 gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where)
 {
 
-  if (check_used (attr, name, where) || check_done (attr, where))
+  if (check_used (attr, name, where))
     return FAILURE;
 
   if (attr->dimension)
@@ -689,7 +664,7 @@ try
 gfc_add_external (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   if (attr->external)
@@ -708,7 +683,7 @@ try
 gfc_add_intrinsic (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   if (attr->intrinsic)
@@ -727,7 +702,7 @@ try
 gfc_add_optional (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   if (attr->optional)
@@ -745,7 +720,7 @@ try
 gfc_add_pointer (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   attr->pointer = 1;
@@ -757,7 +732,7 @@ try
 gfc_add_cray_pointer (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   attr->cray_pointer = 1;
@@ -769,7 +744,7 @@ try
 gfc_add_cray_pointee (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   if (attr->cray_pointee)
@@ -788,7 +763,7 @@ try
 gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
 {
 
-  if (check_used (attr, name, where) || check_done (attr, where))
+  if (check_used (attr, name, where))
     return FAILURE;
 
   attr->result = 1;
@@ -866,7 +841,7 @@ try
 gfc_add_target (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   if (attr->target)
@@ -897,7 +872,7 @@ try
 gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where)
 {
 
-  if (check_used (attr, name, where) || check_done (attr, where))
+  if (check_used (attr, name, where))
     return FAILURE;
 
   /* Duplicate attribute already checked for.  */
@@ -965,7 +940,7 @@ try
 gfc_add_elemental (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   attr->elemental = 1;
@@ -977,7 +952,7 @@ try
 gfc_add_pure (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   attr->pure = 1;
@@ -989,7 +964,7 @@ try
 gfc_add_recursive (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   attr->recursive = 1;
@@ -1093,7 +1068,7 @@ gfc_add_procedure (symbol_attribute * attr, procedure_type t,
 		   const char *name, locus * where)
 {
 
-  if (check_used (attr, name, where) || check_done (attr, where))
+  if (check_used (attr, name, where))
     return FAILURE;
 
   if (attr->flavor != FL_PROCEDURE
@@ -1202,10 +1177,6 @@ gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
 {
   sym_flavor flavor;
 
-/* TODO: This is legal if it is reaffirming an implicit type.
-  if (check_done (&sym->attr, where))
-    return FAILURE;*/
-
   if (where == NULL)
     where = &gfc_current_locus;
 

gcc/fortran/trans-array.c

@@ -4744,6 +4744,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
   gfc_init_block (&fnblock);
 
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref (decl);
+
   /* If this an array of derived types with allocatable components
      build a loop and recursively call this function.  */
   if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE

gcc/fortran/trans-decl.c

@@ -2591,6 +2591,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
   gfc_symbol *sym;
   gfc_formal_arglist *f;
   stmtblock_t body;
+  bool seen_trans_deferred_array = false;
 
   /* Deal with implicit return variables.  Explicit return variables will
      already have been added.  */
@@ -2647,10 +2648,19 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 		  if (TREE_STATIC (sym->backend_decl))
 		    gfc_trans_static_array_pointer (sym);
 		  else
-		    fnbody = gfc_trans_deferred_array (sym, fnbody);
+		    {
+		      seen_trans_deferred_array = true;
+		      fnbody = gfc_trans_deferred_array (sym, fnbody);
+		    }
 		}
 	      else
 		{
+		  if (sym_has_alloc_comp)
+		    {
+		      seen_trans_deferred_array = true;
+		      fnbody = gfc_trans_deferred_array (sym, fnbody);
+		    }
+
 		  gfc_get_backend_locus (&loc);
 		  gfc_set_backend_locus (&sym->declared_at);
 		  fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
@@ -2676,14 +2686,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	      break;
 
 	    case AS_DEFERRED:
-	      if (!sym_has_alloc_comp)
-		fnbody = gfc_trans_deferred_array (sym, fnbody);
+	      seen_trans_deferred_array = true;
+	      fnbody = gfc_trans_deferred_array (sym, fnbody);
 	      break;
 
 	    default:
 	      gcc_unreachable ();
 	    }
-	  if (sym_has_alloc_comp)
+	  if (sym_has_alloc_comp && !seen_trans_deferred_array)
 	    fnbody = gfc_trans_deferred_array (sym, fnbody);
 	}
       else if (sym_has_alloc_comp)

gcc/testsuite/ChangeLog

+2006-11-09 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/29699
+	* gfortran.dg/alloc_comp_auto_array_1.f90: New test.
+
+	PR fortran/21730
+	* gfortran.dg/change_symbol_attributes_1.f90: New test.
+
 2006-11-09  Andreas Krebbel  <krebbel1@de.ibm.com>
 
 	* gcc.dg/20061109-1.c: New testcase.

gcc/testsuite/gfortran.dg/alloc_comp_auto_array_1.f90

+! { dg-do run }
+! Fix for PR29699 - see below for details.
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+PROGRAM vocabulary_word_count
+
+  IMPLICIT NONE
+  TYPE VARYING_STRING
+    CHARACTER,DIMENSION(:),ALLOCATABLE :: chars
+  ENDTYPE VARYING_STRING
+
+  INTEGER :: list_size=200
+
+  call extend_lists2
+
+CONTAINS
+
+! First the original problem: vocab_swap not being referenced caused
+! an ICE because default initialization is used, which results in a
+! call to gfc_conv_variable, which calls gfc_get_symbol_decl.
+
+  SUBROUTINE extend_lists1
+    type(VARYING_STRING),DIMENSION(list_size) :: vocab_swap
+  ENDSUBROUTINE extend_lists1
+
+! Curing this then uncovered two more problems: If vocab_swap were
+! actually referenced, an ICE occurred in the gimplifier because
+! the declaration for this automatic array is presented as a
+! pointer to the array, rather than the array. Curing this allows
+! the code to compile but it bombed out at run time because the
+! malloc/free occurred in the wrong order with respect to the
+! nullify/deallocate of the allocatable components.
+
+  SUBROUTINE extend_lists2
+    type(VARYING_STRING),DIMENSION(list_size) :: vocab_swap
+    allocate (vocab_swap(1)%chars(10))
+    if (.not.allocated(vocab_swap(1)%chars)) call abort ()
+    if (allocated(vocab_swap(10)%chars)) call abort ()
+  ENDSUBROUTINE extend_lists2
+  
+ENDPROGRAM vocabulary_word_count

gcc/testsuite/gfortran.dg/change_symbol_attributes_1.f90

+! { dg-do compile }
+! Fix for PR21730 - declarations used to produce the error:
+!   target        :: x                ! these 2 lines interchanged
+!                    1
+! Error: Cannot change attributes of symbol at (1) after it has been used.
+!
+! Contributed by Harald Anlauf <anlauf@gmx.de>
+!
+subroutine gfcbug27 (x)
+  real, intent(inout) :: x(:)
+
+  real          :: tmp(size (x,1))  ! gfc produces an error unless
+  target        :: x                ! these 2 lines interchanged
+  real, pointer :: p(:)
+
+  p => x(:)
+end subroutine gfcbug27