[gfortran] Fix PR17144 (character array constructors)

Paul Brook paul@codesourcery.com
Wed Aug 25 17:24:00 GMT 2004


The patch below implements character array constructors (PR17144).
These are much the same as other array constructors, with one exception. If 
the constructor consists entirely of constants we use an array of pointers, 
not the strings themselves.

I also fixed bits of handling of character variables in the scalarizer which I 
uncovered in the process.

It isn't entirely complete, but it should handle most things.

Tested on i686-linux.
Applied to mainline.

Paul

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.

Index: trans-array.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.21
diff -u -p -r1.21 trans-array.c
--- trans-array.c	25 Aug 2004 15:50:35 -0000	1.21
+++ trans-array.c	25 Aug 2004 16:17:59 -0000
@@ -527,7 +527,7 @@ gfc_trans_allocate_array_storage (gfc_lo
 
 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_loopi
       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 * p
 }
 
 
+/* 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 (st
   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 (stmtb
 				   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 (stmtb
 	    {
 	      /* 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 (stmtb
 		{
 		  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, g
 }
 
 
+/* 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_loopinf
   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 * loo
             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 * loo
 	  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 +1267,7 @@ gfc_conv_ss_descriptor (stmtblock_t * bl
   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 +1635,7 @@ gfc_conv_scalarized_array_ref (gfc_se * 
 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 +2382,7 @@ gfc_conv_resolve_dependencies (gfc_loopi
       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 +2430,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 +2472,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 +2568,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 +3636,10 @@ gfc_conv_expr_descriptor (gfc_se * se, g
       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);
     }
Index: trans-array.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-array.h,v
retrieving revision 1.4
diff -u -p -r1.4 trans-array.h
--- trans-array.h	10 Jul 2004 22:55:38 -0000	1.4
+++ trans-array.h	25 Aug 2004 14:42:43 -0000
@@ -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.  */
Index: trans-const.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-const.c,v
retrieving revision 1.12
diff -u -p -r1.12 trans-const.c
--- trans-const.c	25 Aug 2004 14:37:10 -0000	1.12
+++ trans-const.c	25 Aug 2004 14:42:46 -0000
@@ -353,7 +353,7 @@ gfc_conv_constant (gfc_se * se, gfc_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;
     }
Index: trans-expr.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-expr.c,v
retrieving revision 1.20
diff -u -p -r1.20 trans-expr.c
--- trans-expr.c	25 Aug 2004 15:50:35 -0000	1.20
+++ trans-expr.c	25 Aug 2004 16:17:59 -0000
@@ -231,9 +231,8 @@ gfc_conv_component_ref (gfc_se * se, gfc
   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
 
       /* 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
 	  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 * e
       /* 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, gf
       && 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;
     }
Index: trans-types.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-types.c,v
retrieving revision 1.16
diff -u -p -r1.16 trans-types.c
--- trans-types.c	25 Aug 2004 15:50:36 -0000	1.16
+++ trans-types.c	25 Aug 2004 16:17:59 -0000
@@ -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_ch
       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);
Index: trans-types.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-types.h,v
retrieving revision 1.3
diff -u -p -r1.3 trans-types.h
--- trans-types.h	14 May 2004 13:00:04 -0000	1.3
+++ trans-types.h	25 Aug 2004 14:42:43 -0000
@@ -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 *);
Index: trans.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans.h,v
retrieving revision 1.13
diff -u -p -r1.13 trans.h
--- trans.h	25 Aug 2004 15:50:36 -0000	1.13
+++ trans.h	25 Aug 2004 16:17:59 -0000
@@ -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.  */
-------------- next part --------------
! { 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



More information about the Gcc-patches mailing list