re PR fortran/17144 (Not Implemented: Character string array constructors /…

re PR fortran/17144 (Not Implemented: Character string array constructors / Assignment to char array)

	PR fortran/17144
	* trans-array.c (gfc_trans_allocate_temp_array): Remove
	string_length argument.
	(gfc_trans_array_ctor_element): New function.
	(gfc_trans_array_constructor_subarray): Use it.
	(gfc_trans_array_constructor_value): Ditto.  Handle constant
	character arrays.
	(get_array_ctor_var_strlen, get_array_ctor_strlen): New functions.
	(gfc_trans_array_constructor): Use them.
	(gfc_add_loop_ss_code): Update to new gfc_ss layout.
	(gfc_conv_ss_descriptor): Remember section string length.
	(gfc_conv_scalarized_array_ref): Ditto.  Remove dead code.
	(gfc_conv_resolve_dependencies): Update to new gfc_ss layout.
	(gfc_conv_expr_descriptor): Ditto.
	(gfc_conv_loop_setup): Ditto.  Spelling fixes.
	* trans-array.h (gfc_trans_allocate_temp_array): Update prototype.
	* trans-const.c (gfc_conv_constant):  Update to new gfc_ss layout.
	* trans-expr.c (gfc_conv_component_ref): Turn error into ICE.
	(gfc_conv_variable): Set string_length from section.
	(gfc_conv_function_call): Remove extra argument.
	(gfc_conv_expr, gfc_conv_expr_reference): Update to new gfc_ss layout.
	* trans-types.c (gfc_get_character_type_len): New function.
	(gfc_get_character_type): Use it.
	(gfc_get_dtype): Return zero for internal types.
	* trans-types.h (gfc_get_character_type_len): Add prototype.
	* trans.h (struct gfc_ss): Move string_length out of union.
testsuite/
	* gfortran.dg/string_ctor_1.f90: New test.

From-SVN: r86558

gcc/fortran/ChangeLog

+2004-08-25  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/17144
+	* trans-array.c (gfc_trans_allocate_temp_array): Remove
+	string_length argument.
+	(gfc_trans_array_ctor_element): New function.
+	(gfc_trans_array_constructor_subarray): Use it.
+	(gfc_trans_array_constructor_value): Ditto.  Handle constant
+	character arrays.
+	(get_array_ctor_var_strlen, get_array_ctor_strlen): New functions.
+	(gfc_trans_array_constructor): Use them.
+	(gfc_add_loop_ss_code): Update to new gfc_ss layout.
+	(gfc_conv_ss_descriptor): Remember section string length.
+	(gfc_conv_scalarized_array_ref): Ditto.  Remove dead code.
+	(gfc_conv_resolve_dependencies): Update to new gfc_ss layout.
+	(gfc_conv_expr_descriptor): Ditto.
+	(gfc_conv_loop_setup): Ditto.  Spelling fixes.
+	* trans-array.h (gfc_trans_allocate_temp_array): Update prototype.
+	* trans-const.c (gfc_conv_constant):  Update to new gfc_ss layout.
+	* trans-expr.c (gfc_conv_component_ref): Turn error into ICE.
+	(gfc_conv_variable): Set string_length from section.
+	(gfc_conv_function_call): Remove extra argument.
+	(gfc_conv_expr, gfc_conv_expr_reference): Update to new gfc_ss layout.
+	* trans-types.c (gfc_get_character_type_len): New function.
+	(gfc_get_character_type): Use it.
+	(gfc_get_dtype): Return zero for internal types.
+	* trans-types.h (gfc_get_character_type_len): Add prototype.
+	* trans.h (struct gfc_ss): Move string_length out of union.
+
 2004-08-25  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
 
 	* trans.h (build2_v, build3_v): New macros.

gcc/fortran/trans-array.c

@@ -527,7 +527,7 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
 
 tree
 gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
-			       tree eltype, tree string_length)
+			       tree eltype)
 {
   tree type;
   tree desc;
@@ -617,10 +617,6 @@ gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
       size = gfc_evaluate_now (size, &loop->pre);
     }
 
-  /* TODO: Where does the string length go?  */
-  if (string_length)
-    gfc_todo_error ("temporary arrays of strings");
-
   /* Get the size of the array.  */
   nelem = size;
   if (size)
@@ -651,6 +647,55 @@ gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
 }
 
 
+/* Assign an element of an array constructor.  */
+
+static void
+gfc_trans_array_ctor_element (stmtblock_t * pblock, tree pointer,
+			      tree offset, gfc_se * se, gfc_expr * expr)
+{
+  tree tmp;
+  tree args;
+
+  gfc_conv_expr (se, expr);
+
+  /* Store the value.  */
+  tmp = gfc_build_indirect_ref (pointer);
+  tmp = gfc_build_array_ref (tmp, offset);
+  if (expr->ts.type == BT_CHARACTER)
+    {
+      gfc_conv_string_parameter (se);
+      if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+	{
+	  /* The temporary is an array of pointers.  */
+	  se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
+	  gfc_add_modify_expr (&se->pre, tmp, se->expr);
+	}
+      else
+	{
+	  /* The temporary is an array of string values.  */
+	  tmp = gfc_build_addr_expr (pchar_type_node, tmp);
+	  /* We know the temporary and the value will be the same length,
+	     so can use memcpy.  */
+	  args = gfc_chainon_list (NULL_TREE, tmp);
+	  args = gfc_chainon_list (args, se->expr);
+	  args = gfc_chainon_list (args, se->string_length);
+	  tmp = built_in_decls[BUILT_IN_MEMCPY];
+	  tmp = gfc_build_function_call (tmp, args);
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	}
+    }
+  else
+    {
+      /* TODO: Should the frontend already have done this conversion?  */
+      se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
+      gfc_add_modify_expr (&se->pre, tmp, se->expr);
+    }
+
+  gfc_add_block_to_block (pblock, &se->pre);
+  gfc_add_block_to_block (pblock, &se->post);
+}
+
+
 /* Add the contents of an array to the constructor.  */
 
 static void
@@ -688,21 +733,17 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
   gfc_copy_loopinfo_to_se (&se, &loop);
   se.ss = ss;
 
-  gfc_conv_expr (&se, expr);
-  gfc_add_block_to_block (&body, &se.pre);
+  if (expr->ts.type == BT_CHARACTER)
+    gfc_todo_error ("character arrays in constructors");
 
-  /* Store the value.  */
-  tmp = gfc_build_indirect_ref (pointer);
-  tmp = gfc_build_array_ref (tmp, *poffset);
-  gfc_add_modify_expr (&body, tmp, se.expr);
+  gfc_trans_array_ctor_element (&body, pointer, *poffset, &se, expr);
+  assert (se.ss == gfc_ss_terminator);
 
   /* Increment the offset.  */
   tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
   gfc_add_modify_expr (&body, *poffset, tmp);
 
   /* Finish the loop.  */
-  gfc_add_block_to_block (&body, &se.post);
-  assert (se.ss == gfc_ss_terminator);
   gfc_trans_scalarizing_loops (&loop, &body);
   gfc_add_block_to_block (&loop.pre, &loop.post);
   tmp = gfc_finish_block (&loop.pre);
@@ -720,7 +761,6 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
 				   tree * poffset, tree * offsetvar)
 {
   tree tmp;
-  tree ref;
   stmtblock_t body;
   tree loopbody;
   gfc_se se;
@@ -763,14 +803,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
 	    {
 	      /* Scalar values.  */
 	      gfc_init_se (&se, NULL);
-	      gfc_conv_expr (&se, c->expr);
-	      gfc_add_block_to_block (&body, &se.pre);
-
-	      ref = gfc_build_indirect_ref (pointer);
-	      ref = gfc_build_array_ref (ref, *poffset);
-	      gfc_add_modify_expr (&body, ref,
-				   fold_convert (TREE_TYPE (ref), se.expr));
-	      gfc_add_block_to_block (&body, &se.post);
+	      gfc_trans_array_ctor_element (&body, pointer, *poffset, &se,
+					    c->expr);
 
 	      *poffset = fold (build2 (PLUS_EXPR, gfc_array_index_type,
 				       *poffset, gfc_index_one_node));
@@ -791,6 +825,16 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
 		{
 		  gfc_init_se (&se, NULL);
 		  gfc_conv_constant (&se, p->expr);
+		  if (p->expr->ts.type == BT_CHARACTER
+		      && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE
+			  (TREE_TYPE (pointer)))))
+		    {
+		      /* For constant character array constructors we build
+			 an array of pointers.  */
+		      se.expr = gfc_build_addr_expr (pchar_type_node,
+						      se.expr);
+		    }
+		    
 		  list = tree_cons (NULL_TREE, se.expr, list);
 		  c = p;
 		  p = p->next;
@@ -974,6 +1018,86 @@ gfc_get_array_cons_size (mpz_t * size, gfc_constructor * c)
 }
 
 
+/* Figure out the string length of a variable reference expression.
+   Used by get_array_ctor_strlen.  */
+
+static void
+get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
+{
+  gfc_ref *ref;
+  gfc_typespec *ts;
+
+  /* Don't bother if we already know the length is a constant.  */
+  if (*len && INTEGER_CST_P (*len))
+    return;
+
+  ts = &expr->symtree->n.sym->ts;
+  for (ref = expr->ref; ref; ref = ref->next)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  /* Array references don't change teh sting length.  */
+	  break;
+
+	case COMPONENT_REF:
+	  /* Use the length of the component. */
+	  ts = &ref->u.c.component->ts;
+	  break;
+
+	default:
+	  /* TODO: Substrings are tricky because we can't evaluate the
+	     expression more than once.  For now we just give up, and hope
+	     we can figure it out elsewhere.  */
+	  return;
+	}
+    }
+
+  *len = ts->cl->backend_decl;
+}
+
+
+/* Figure out the string length of a character array constructor.
+   Returns TRUE if all elements are character constants.  */
+
+static bool
+get_array_ctor_strlen (gfc_constructor * c, tree * len)
+{
+  bool is_const;
+  
+  is_const = TRUE;
+  for (; c; c = c->next)
+    {
+      switch (c->expr->expr_type)
+	{
+	case EXPR_CONSTANT:
+	  if (!(*len && INTEGER_CST_P (*len)))
+	    *len = build_int_cstu (gfc_strlen_type_node,
+				   c->expr->value.character.length);
+	  break;
+
+	case EXPR_ARRAY:
+	  if (!get_array_ctor_strlen (c->expr->value.constructor, len))
+	    is_const = FALSE;
+	  break;
+
+	case EXPR_VARIABLE:
+	  is_const = false;
+	  get_array_ctor_var_strlen (c->expr, len);
+	  break;
+
+	default:
+	  is_const = FALSE;
+	  /* 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;
+	}
+    }
+
+  return is_const;
+}
+
+
 /* Array constructors are handled by constructing a temporary, then using that
    within the scalarization loop.  This is not optimal, but seems by far the
    simplest method.  */
@@ -986,13 +1110,28 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
   tree desc;
   tree size;
   tree type;
+  bool const_string;
 
-  if (ss->expr->ts.type == BT_CHARACTER)
-    gfc_todo_error ("Character string array constructors");
-  type = gfc_typenode_for_spec (&ss->expr->ts);
   ss->data.info.dimen = loop->dimen;
-  size =
-    gfc_trans_allocate_temp_array (loop, &ss->data.info, type, NULL_TREE);
+
+  if (ss->expr->ts.type == BT_CHARACTER)
+    {
+      const_string = get_array_ctor_strlen (ss->expr->value.constructor,
+					    &ss->string_length);
+      if (!ss->string_length)
+	gfc_todo_error ("complex character array constructors");
+
+      type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
+      if (const_string)
+	type = build_pointer_type (type);
+    }
+  else
+    {
+      const_string = TRUE;
+      type = gfc_typenode_for_spec (&ss->expr->ts);
+    }
+
+  size = gfc_trans_allocate_temp_array (loop, &ss->data.info, type);
 
   desc = ss->data.info.descriptor;
   offset = gfc_index_zero_node;
@@ -1057,7 +1196,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
             gfc_add_block_to_block (&loop->post, &se.post);
 
 	  ss->data.scalar.expr = se.expr;
-	  ss->data.scalar.string_length = se.string_length;
+	  ss->string_length = se.string_length;
 	  break;
 
 	case GFC_SS_REFERENCE:
@@ -1068,7 +1207,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
 	  gfc_add_block_to_block (&loop->post, &se.post);
 
 	  ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
-	  ss->data.scalar.string_length = se.string_length;
+	  ss->string_length = se.string_length;
 	  break;
 
 	case GFC_SS_SECTION:
@@ -1129,6 +1268,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
   gfc_conv_expr_lhs (&se, ss->expr);
   gfc_add_block_to_block (block, &se.pre);
   ss->data.info.descriptor = se.expr;
+  ss->string_length = se.string_length;
 
   if (base)
     {
@@ -1496,11 +1636,7 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
 void
 gfc_conv_tmp_array_ref (gfc_se * se)
 {
-  tree desc;
-
-  desc = se->ss->data.info.descriptor;
-  /* TODO: We need the string length for string variables.  */
-
+  se->string_length = se->ss->string_length;
   gfc_conv_scalarized_array_ref (se, NULL);
 }
 
@@ -2247,7 +2383,7 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
       loop->temp_ss->type = GFC_SS_TEMP;
       loop->temp_ss->data.temp.type =
 	gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
-      loop->temp_ss->data.temp.string_length = NULL_TREE;
+      loop->temp_ss->string_length = NULL_TREE;
       loop->temp_ss->data.temp.dimen = loop->dimen;
       loop->temp_ss->next = gfc_ss_terminator;
       gfc_add_ss_to_loop (loop, loop->temp_ss);
@@ -2295,7 +2431,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
 	  if (ss->type == GFC_SS_CONSTRUCTOR)
 	    {
 	      /* An unknown size constructor will always be rank one.
-		 Higher rank constructors will wither have known shape,
+		 Higher rank constructors will either have known shape,
 		 or still be wrapped in a call to reshape.  */
 	      assert (loop->dimen == 1);
 	      /* Try to figure out the size of the constructor.  */
@@ -2337,7 +2473,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
 	   */
 	  if (!specinfo)
 	    loopspec[n] = ss;
-	  /* TODO: Is != contructor correct?  */
+	  /* TODO: Is != constructor correct?  */
 	  else if (loopspec[n]->type != GFC_SS_CONSTRUCTOR)
 	    {
 	      if (integer_onep (info->stride[n])
@@ -2433,13 +2569,12 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
     {
       assert (loop->temp_ss->type == GFC_SS_TEMP);
       tmp = loop->temp_ss->data.temp.type;
-      len = loop->temp_ss->data.temp.string_length;
+      len = loop->temp_ss->string_length;
       n = loop->temp_ss->data.temp.dimen;
       memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
       loop->temp_ss->type = GFC_SS_SECTION;
       loop->temp_ss->data.info.dimen = n;
-      gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info,
-				     tmp, len);
+      gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info, tmp);
     }
 
   for (n = 0; n < loop->temp_dim; n++)
@@ -3502,10 +3637,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
       /* Which can hold our string, if present.  */
       if (expr->ts.type == BT_CHARACTER)
-	se->string_length = loop.temp_ss->data.temp.string_length
+	se->string_length = loop.temp_ss->string_length
 	  = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
       else
-	loop.temp_ss->data.temp.string_length = NULL;
+	loop.temp_ss->string_length = NULL;
       loop.temp_ss->data.temp.dimen = loop.dimen;
       gfc_add_ss_to_loop (&loop, loop.temp_ss);
     }

gcc/fortran/trans-array.h

@@ -27,8 +27,7 @@ tree gfc_array_deallocate (tree);
 void gfc_array_allocate (gfc_se *, gfc_ref *, tree);
 
 /* Generate code to allocate a temporary array.  */
-tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree,
-				    tree);
+tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree);
 
 /* Generate function entry code for allocation of compiler allocated array
    variables.  */

gcc/fortran/trans-const.c

@@ -353,7 +353,7 @@ gfc_conv_constant (gfc_se * se, gfc_expr * expr)
       assert (se->ss->expr == expr);
 
       se->expr = se->ss->data.scalar.expr;
-      se->string_length = se->ss->data.scalar.string_length;
+      se->string_length = se->ss->string_length;
       gfc_advance_se_ss_chain (se);
       return;
     }

gcc/fortran/trans-expr.c

@@ -231,9 +231,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
   if (c->ts.type == BT_CHARACTER)
     {
       tmp = c->ts.cl->backend_decl;
-      assert (tmp);
-      if (!INTEGER_CST_P (tmp))
-	gfc_todo_error ("Unknown length character component");
+      /* Components must always be constant length.  */
+      assert (tmp && INTEGER_CST_P (tmp));
       se->string_length = tmp;
     }
 
@@ -260,6 +259,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 
       /* A scalarized term.  We already know the descriptor.  */
       se->expr = se->ss->data.info.descriptor;
+      se->string_length = se->ss->string_length;
       ref = se->ss->data.info.ref;
     }
   else
@@ -1040,7 +1040,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	  tmp = gfc_typenode_for_spec (&sym->ts);
 	  info->dimen = se->loop->dimen;
 	  /* Allocate a temporary to store the result.  */
-	  gfc_trans_allocate_temp_array (se->loop, info, tmp, NULL_TREE);
+	  gfc_trans_allocate_temp_array (se->loop, info, tmp);
 
 	  /* Zero the first stride to indicate a temporary.  */
 	  tmp =
@@ -1711,7 +1711,7 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
       /* Substitute a scalar expression evaluated outside the scalarization
          loop.  */
       se->expr = se->ss->data.scalar.expr;
-      se->string_length = se->ss->data.scalar.string_length;
+      se->string_length = se->ss->string_length;
       gfc_advance_se_ss_chain (se);
       return;
     }
@@ -1799,7 +1799,7 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
       && se->ss->type == GFC_SS_REFERENCE)
     {
       se->expr = se->ss->data.scalar.expr;
-      se->string_length = se->ss->data.scalar.string_length;
+      se->string_length = se->ss->string_length;
       gfc_advance_se_ss_chain (se);
       return;
     }

gcc/fortran/trans-types.c

@@ -267,15 +267,14 @@ gfc_get_logical_type (int kind)
     }
 }
 
-/* Get a type node for a character kind.  */
+/* Create a character type with the given kind and length.  */
 
 tree
-gfc_get_character_type (int kind, gfc_charlen * cl)
+gfc_get_character_type_len (int kind, tree len)
 {
   tree base;
-  tree type;
-  tree len;
   tree bounds;
+  tree type;
 
   switch (kind)
     {
@@ -287,14 +286,25 @@ gfc_get_character_type (int kind, gfc_charlen * cl)
       fatal_error ("character kind=%d not available", kind);
     }
 
-  len = (cl == 0) ? NULL_TREE : cl->backend_decl;
-
   bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len);
   type = build_array_type (base, bounds);
   TYPE_STRING_FLAG (type) = 1;
 
   return type;
 }
+
+
+/* Get a type node for a character kind.  */
+
+tree
+gfc_get_character_type (int kind, gfc_charlen * cl)
+{
+  tree len;
+
+  len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
+
+  return gfc_get_character_type_len (kind, len);
+}
 
 /* Covert a basic type.  This will be an array for character types.  */
 
@@ -480,6 +490,9 @@ gfc_is_nodesc_array (gfc_symbol * sym)
   return 1;
 }
 
+
+/* Create an array descriptor type.  */
+
 static tree
 gfc_build_array_type (tree type, gfc_array_spec * as)
 {
@@ -584,7 +597,9 @@ gfc_get_dtype (tree type, int rank)
       break;
 
     default:
-      abort ();
+      /* TODO: Don't do dtype for temporary descriptorless arrays.  */
+      /* We can strange array types for temporary arrays.  */
+      return gfc_index_zero_node;
     }
 
   assert (rank <= GFC_DTYPE_RANK_MASK);

gcc/fortran/trans-types.h

@@ -112,6 +112,7 @@ tree gfc_get_real_type (int);
 tree gfc_get_complex_type (int);
 tree gfc_get_logical_type (int);
 tree gfc_get_character_type (int, gfc_charlen *);
+tree gfc_get_character_type_len (int, tree);
 
 tree gfc_sym_type (gfc_symbol *);
 tree gfc_typenode_for_spec (gfc_typespec *);

gcc/fortran/trans.h

@@ -162,13 +162,13 @@ typedef struct gfc_ss
   gfc_ss_type type;
   gfc_expr *expr;
   mpz_t *shape;
+  tree string_length;
   union
   {
     /* If type is GFC_SS_SCALAR or GFC_SS_REFERENCE.  */
     struct
     {
       tree expr;
-      tree string_length;
     }
     scalar;
 
@@ -179,7 +179,6 @@ typedef struct gfc_ss
          assigned expression.  */
       int dimen;
       tree type;
-      tree string_length;
     }
     temp;
     /* All other types.  */

gcc/testsuite/ChangeLog

+2004-08-25  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/17144
+	* gfortran.dg/string_ctor_1.f90: New test.
+
 2004-08-25  Kriang Lerdsuwanakij  <lerdsuwa@users.sourceforge.net>
 
 	PR c++/14428

gcc/testsuite/gfortran.dg/string_ctor_1.f90

+! { dg-do run }
+! Program to test character array constructors.
+! PR17144
+subroutine test1 (n, t, u)
+  integer n
+  character(len=n) :: s(2)
+  character(len=*) :: t
+  character(len=*) :: u
+
+  ! A variable array constructor.
+  s = (/t, u/)
+  ! An array constructor as part of an expression.
+  if (any (s .ne. (/"Hell", "Worl"/))) call abort
+end subroutine
+
+subroutine test2
+  character*5 :: s(2)
+
+  ! A constant array constructor
+  s = (/"Hello", "World"/)
+  if ((s(1) .ne. "Hello") .or. (s(2) .ne. "World")) call abort
+end subroutine
+
+subroutine test3
+  character*1 s(26)
+  character*26 t
+  integer i
+
+  ! A large array constructor
+  s = (/'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', &
+        'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z'/)
+  do i=1, 26
+    t(i:i) = s(i)
+  end do
+
+  ! Assignment with dependency
+  s = (/(s(27-i), i=1, 26)/)
+  do i=1, 26
+    t(i:i) = s(i)
+  end do
+  if (t .ne. "zyxwvutsrqponmlkjihgfedcba") call abort
+end subroutine
+
+program string_ctor_1
+  call test1 (4, "Hello", "World")
+  call test2
+  call test3
+end program
+