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

2006-11-12 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. PR fortran/29431 * trans-array.c (get_array_ctor_strlen): If we fall through to default, use a constant character length if it is available. PR fortran/29758 * check.c (gfc_check_reshape): Check that there are enough elements in the source array as to be able to fill an array defined by shape, when pad is absent. PR fortran/29315 * trans-expr.c (is_aliased_array): Treat correctly the case where the component is itself and array or array reference. 2006-11-12 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. PR fortran/29431 * gfortran.dg/array_constructor_13.f90: New test. PR fortran/29758 * gfortran.dg/reshape_source_size_1.f90: New test. PR fortran/29315 * gfortran.dg/aliasing_dummy_4.f90: New test. From-SVN: r118719
2026-02-22 03:46:53 -05:00 · 2006-11-12 07:40:26 +00:00
parent 1bea4dc3e5
commit 0f1ae23bc4
15 changed files with 286 additions and 61 deletions
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,41 @@
+2006-11-12 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.
+
+	PR fortran/29431
+	* trans-array.c    (get_array_ctor_strlen): If we fall through to
+	default, use a constant character length if it is available.
+
+	PR fortran/29758
+	* check.c (gfc_check_reshape): Check that there are enough
+	elements in the source array as to be able to fill an array
+	defined by shape, when pad is absent.
+
+	PR fortran/29315
+	* trans-expr.c (is_aliased_array): Treat correctly the case where the
+	component is itself and array or array reference.
+
 2006-11-10  Tobias Burnus  <burnus@net-b.de>

 	PR fortran/29454
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2110,6 +2110,7 @@ gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
 		   gfc_expr * pad, gfc_expr * order)
 {
  mpz_t size;
+  mpz_t nelems;
  int m;

  if (array_check (source, 0) == FAILURE)
@@ -2149,6 +2150,38 @@ gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
  if (order != NULL && array_check (order, 3) == FAILURE)
    return FAILURE;

+  if (pad == NULL
+	&& shape->expr_type == EXPR_ARRAY
+	&& gfc_is_constant_expr (shape)
+	&& !(source->expr_type == EXPR_VARIABLE
+	       && source->symtree->n.sym->as
+	       && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
+    {
+      /* Check the match in size between source and destination.  */
+      if (gfc_array_size (source, &nelems) == SUCCESS)
+	{
+	  gfc_constructor *c;
+	  bool test;
+
+	  c = shape->value.constructor;
+	  mpz_init_set_ui (size, 1);
+	  for (; c; c = c->next)
+	    mpz_mul (size, size, c->expr->value.integer);
+
+	  test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
+	  mpz_clear (nelems);
+	  mpz_clear (size);
+
+	  if (test)
+	    {
+	      gfc_error ("Without padding, there are not enough elements in the "
+			 "intrinsic RESHAPE source at %L to match the shape",
+			 &source->where);
+	      return FAILURE;
+	    }
+	}
+    }
+
  return SUCCESS;
 }

--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -3297,7 +3297,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;
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1839,7 +1839,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 *);
--- a/gcc/fortran/resolve.c
+++ b/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;

--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -589,28 +589,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
@@ -626,12 +604,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);
@@ -641,7 +616,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)
@@ -659,7 +634,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)
@@ -677,7 +652,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)
@@ -696,7 +671,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)
@@ -715,7 +690,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)
@@ -733,7 +708,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;
@@ -745,7 +720,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;
@@ -757,7 +732,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)
@@ -776,7 +751,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;
@@ -834,7 +809,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)
@@ -865,7 +840,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.  */
@@ -933,7 +908,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;
@@ -945,7 +920,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;
@@ -957,7 +932,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;
@@ -1061,7 +1036,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
@@ -1170,10 +1145,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;

--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1416,7 +1416,7 @@ get_array_ctor_strlen (gfc_constructor * c, tree * len)

 	case EXPR_ARRAY:
 	  if (!get_array_ctor_strlen (c->expr->value.constructor, len))
-	    is_const = FALSE;
+	    is_const = false;
 	  break;

 	case EXPR_VARIABLE:
@@ -1425,7 +1425,15 @@ get_array_ctor_strlen (gfc_constructor * c, tree * len)
 	  break;

 	default:
-	  is_const = FALSE;
+	  is_const = false;
+
+	  /* Hope that whatever we have possesses a constant character
+	     length!  */
+	  if (!(*len && INTEGER_CST_P (*len)) && c->expr->ts.cl)
+	    {
+	      gfc_conv_const_charlen (c->expr->ts.cl);
+	      *len = c->expr->ts.cl->backend_decl;
+	    }
 	  /* TODO: For now we just ignore anything we don't know how to
 	     handle, and hope we can figure it out a different way.  */
 	  break;
@@ -4744,6 +4752,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
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2534,6 +2534,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.  */
@@ -2590,10 +2591,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,
@@ -2619,14 +2629,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)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1838,7 +1838,8 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
  return;
 }

-/* Is true if the last array reference is followed by a component reference.  */
+/* Is true if an array reference is followed by a component or substring
+   reference.  */

 static bool
 is_aliased_array (gfc_expr * e)
@@ -1849,10 +1850,11 @@ is_aliased_array (gfc_expr * e)
  seen_array = false;	
  for (ref = e->ref; ref; ref = ref->next)
    {
-      if (ref->type == REF_ARRAY)
+      if (ref->type == REF_ARRAY
+	    && ref->u.ar.type != AR_ELEMENT)
 	seen_array = true;

-      if (ref->next == NULL
+      if (seen_array
 	    && ref->type != REF_ARRAY)
 	return seen_array;
    }
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,20 @@
+2006-11-12 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.
+
+	PR fortran/29431
+	* gfortran.dg/array_constructor_13.f90: New test.
+
+	PR fortran/29758
+	* gfortran.dg/reshape_source_size_1.f90: New test.
+
+	PR fortran/29315
+	* gfortran.dg/aliasing_dummy_4.f90: New test.
+
 2006-11-11  Richard Sandiford  <richard@codesourcery.com>

 	PR middle-end/27528
--- a/gcc/testsuite/gfortran.dg/aliasing_dummy_4.f90
+++ b/gcc/testsuite/gfortran.dg/aliasing_dummy_4.f90
@@ -0,0 +1,42 @@
+! { dg-do run }
+! This tests the fix for PR29315, in which array components of derived type arrays were
+! not correctly passed to procedures because of a fault in the function that detects
+! these references that do not have the span of a natural type.
+!
+! Contributed by Stephen Jeffrey  <stephen.jeffrey@nrm.qld.gov.au>
+!
+program  test_f90
+
+    integer, parameter :: N = 2
+
+    type test_type
+        integer a(N, N)
+    end type
+
+    type (test_type) s(N, N)
+
+    forall (l = 1:N, m = 1:N) &
+        s(l, m)%a(:, :) = reshape ([((i*l + 10*j*m +100, i = 1, N), j = 1, N)], [N, N])
+
+    call test_sub(s%a(1, 1), 1000) ! Test the original problem.
+
+    if ( any (s(1, 1)%a(:, :) /= reshape ([1111, 112, 121, 122], [2, 2]))) call abort ()
+    if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) call abort ()
+    if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) call abort ()
+    if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) call abort ()
+
+    call test_sub(s(1, 1)%a(:, :), 1000)  ! Check "normal" references.
+
+    if ( any (s(1, 1)%a(:, :) /= reshape ([2111,1112,1121,1122], [2, 2]))) call abort ()
+    if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) call abort ()
+    if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) call abort ()
+    if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) call abort ()
+contains
+  subroutine test_sub(array, offset)
+    integer array(:, :), offset
+
+    forall (i = 1:N, j = 1:N) &
+        array(i, j) = array(i, j) + offset
+  end subroutine
+end program
+
--- a/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_1.f90
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_1.f90
@@ -0,0 +1,42 @@
+! { 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
--- a/gcc/testsuite/gfortran.dg/array_constructor_13.f90
+++ b/gcc/testsuite/gfortran.dg/array_constructor_13.f90
@@ -0,0 +1,24 @@
+! { dg-do compile }
+! Tests patch for PR29431, which arose from PR29373.
+!
+! Contributed by Tobias Schlueter  <tobi@gcc.gnu.org>
+!
+  implicit none
+  CHARACTER(len=6), DIMENSION(2,2)  :: a
+
+! Reporters original triggered another error:
+! gfc_todo: Not Implemented: complex character array
+! constructors.
+
+  a = reshape([to_string(1.0), trim("abcdef"), &
+               to_string(7.0), trim("hijklm")], &
+               [2, 2])
+  print *, a
+
+  CONTAINS
+    FUNCTION to_string(x)
+      character*6 to_string
+      REAL, INTENT(in) :: x
+      WRITE(to_string, FMT="(F6.3)") x
+    END FUNCTION
+end
--- a/gcc/testsuite/gfortran.dg/change_symbol_attributes_1.f90
+++ b/gcc/testsuite/gfortran.dg/change_symbol_attributes_1.f90
@@ -0,0 +1,17 @@
+! { 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
--- a/gcc/testsuite/gfortran.dg/reshape_source_size_1.f90
+++ b/gcc/testsuite/gfortran.dg/reshape_source_size_1.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! Tests patch for PR29758, which arose from PR29431.  There was no check that there
+! were enough elements in the source to match the shape.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+   real :: a(2,2), b = 1.0, c(3), d(4)
+   a = reshape ([b], [2,2]) ! { dg-error "not enough elements" }
+   a = reshape (c, [2,2])   ! { dg-error "not enough elements" }
+   a = reshape (d, [2,2])
+end