Correction régression deferred_character_37.f90

gcc/fortran/frontend-passes.cc

@@ -801,6 +801,7 @@ create_var (gfc_expr * e, const char *vname)
 	     allocatable.  */
 	  symbol->as->type = AS_DEFERRED;
 	  symbol->attr.allocatable = 1;
+	  symbol->ts.deferred = true;
 	}
       else
 	{
@@ -823,7 +824,7 @@ create_var (gfc_expr * e, const char *vname)
 	}
     }
 
-  deferred = 0;
+  deferred = false;
   if (e->ts.type == BT_CHARACTER)
     {
       gfc_expr *length;
@@ -840,11 +841,11 @@ create_var (gfc_expr * e, const char *vname)
 	{
 	  symbol->attr.allocatable = 1;
 	  symbol->ts.u.cl->length = NULL;
-	  symbol->ts.deferred = 1;
 	  deferred = 1;
 	}
     }
 
+  symbol->ts.deferred = deferred;
   symbol->attr.flavor = FL_VARIABLE;
   symbol->attr.referenced = 1;
   symbol->attr.dimension = e->rank > 0;

gcc/fortran/trans-array.cc

@@ -1025,9 +1025,15 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
   if (eltype && GFC_CLASS_TYPE_P (eltype))
     eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
 
-  if (class_expr == NULL_TREE)
+  if (class_expr == NULL_TREE
+      && TYPE_SIZE_UNIT (eltype) != NULL_TREE)
     elemsize = fold_convert (gfc_array_index_type,
 			     TYPE_SIZE_UNIT (eltype));
+  else if (class_expr == NULL_TREE)
+    {
+      gcc_assert (callee_alloc);
+      elemsize = NULL_TREE;
+    }
   else
     {
       /* Unlimited polymorphic entities are initialised with NULL vptr. They

gcc/fortran/trans-descriptor.cc

@@ -791,6 +791,56 @@ get_attr_constructor (bool bytes_counted_strides)
 }
 
 
+/* Return the DTYPE for an array.  This describes the type and type parameters
+   of the array.  */
+/* TODO: Only call this when the value is actually used, and make all the
+   unknown cases abort.  */
+
+tree
+get_dtype_rank_type_size (int rank, bt n, bool bytes_counted_strides,
+			      tree size)
+{
+  tree dtype;
+  tree field;
+  vec<constructor_elt, va_gc> *v = NULL;
+
+  tree dtype_type_node = get_dtype_type_node ();
+  if (size)
+    {
+      STRIP_NOPS (size);
+      size = fold_convert (size_type_node, size);
+      field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
+				 GFC_DTYPE_ELEM_LEN);
+      CONSTRUCTOR_APPEND_ELT (v, field,
+			      fold_convert (TREE_TYPE (field), size));
+    }
+  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
+			     GFC_DTYPE_VERSION);
+  CONSTRUCTOR_APPEND_ELT (v, field,
+			  build_zero_cst (TREE_TYPE (field)));
+
+  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
+			     GFC_DTYPE_RANK);
+  if (rank >= 0)
+    CONSTRUCTOR_APPEND_ELT (v, field,
+			    build_int_cst (TREE_TYPE (field), rank));
+
+  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
+			     GFC_DTYPE_TYPE);
+  CONSTRUCTOR_APPEND_ELT (v, field,
+			  build_int_cst (TREE_TYPE (field), n));
+
+  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
+			     GFC_DTYPE_ATTR);
+  CONSTRUCTOR_APPEND_ELT (v, field,
+			  get_attr_constructor (bytes_counted_strides));
+
+  dtype = build_constructor (dtype_type_node, v);
+
+  return dtype;
+}
+
+
 /* Return the DTYPE for an array.  This describes the type and type parameters
    of the array.  */
 /* TODO: Only call this when the value is actually used, and make all the
@@ -801,10 +851,7 @@ gfc_get_dtype_rank_type_slen (int rank, tree etype, bool bytes_counted_strides,
 			      tree length)
 {
   tree ptype;
-  int n;
+  bt n;
-  tree dtype;
-  tree field;
-  vec<constructor_elt, va_gc> *v = NULL;
 
   ptype = etype;
   while (TREE_CODE (etype) == POINTER_TYPE
@@ -877,40 +924,7 @@ gfc_get_dtype_rank_type_slen (int rank, tree etype, bool bytes_counted_strides,
       break;
     }
 
-  tree dtype_type_node = get_dtype_type_node ();
+  return get_dtype_rank_type_size (rank, n, bytes_counted_strides, size);
-  if (size)
-    {
-      STRIP_NOPS (size);
-      size = fold_convert (size_type_node, size);
-      field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
-				 GFC_DTYPE_ELEM_LEN);
-      CONSTRUCTOR_APPEND_ELT (v, field,
-			      fold_convert (TREE_TYPE (field), size));
-    }
-  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
-			     GFC_DTYPE_VERSION);
-  CONSTRUCTOR_APPEND_ELT (v, field,
-			  build_zero_cst (TREE_TYPE (field)));
-
-  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
-			     GFC_DTYPE_RANK);
-  if (rank >= 0)
-    CONSTRUCTOR_APPEND_ELT (v, field,
-			    build_int_cst (TREE_TYPE (field), rank));
-
-  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
-			     GFC_DTYPE_TYPE);
-  CONSTRUCTOR_APPEND_ELT (v, field,
-			  build_int_cst (TREE_TYPE (field), n));
-
-  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
-			     GFC_DTYPE_ATTR);
-  CONSTRUCTOR_APPEND_ELT (v, field,
-			  get_attr_constructor (bytes_counted_strides));
-
-  dtype = build_constructor (dtype_type_node, v);
-
-  return dtype;
 }
 
 
@@ -2233,6 +2247,20 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, int dest_rank,
 }
 
 
+static bool
+element_size_known (tree desc)
+{
+  tree type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)
+	      || GFC_ARRAY_TYPE_P (type));
+
+  tree elt_type = gfc_get_element_type (TREE_TYPE (desc));
+  tree size = TYPE_SIZE_UNIT (elt_type);
+
+  return size && TREE_CODE (size) == INTEGER_CST;
+}
+
+
 void
 gfc_set_descriptor (stmtblock_t *block, tree dest, tree src, gfc_expr *src_expr,
 		    int rank, int corank, gfc_ss *ss, gfc_array_info *info,
@@ -2298,12 +2326,29 @@ gfc_set_descriptor (stmtblock_t *block, tree dest, tree src, gfc_expr *src_expr,
 	tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
       dtype = gfc_conv_descriptor_dtype_get (tmp2);
     }
+  else if (src_expr->rank != -1
+	   && src_expr->ts.type == BT_CHARACTER
+	   && src_expr->ts.deferred
+	   && !element_size_known (dest))
+    {
+      bool bytes_strides = GFC_BYTES_STRIDES_ARRAY_TYPE_P (TREE_TYPE (dest));
+      dtype = get_dtype_rank_type_size (src_expr->rank, BT_CHARACTER,
+					bytes_strides, NULL_TREE);
+    }
   else
     dtype = gfc_get_dtype (TREE_TYPE (dest));
   gfc_conv_descriptor_dtype_set (block, dest, dtype);
 
   if (src_expr->ts.type == BT_CLASS)
     gfc_conv_descriptor_elem_len_set (block, dest, span);
+  else if (src_expr->rank != -1
+	   && src_expr->ts.type == BT_CHARACTER
+	   && src_expr->ts.deferred
+	   && !element_size_known (dest))
+    {
+      tree elem_len = gfc_conv_descriptor_elem_len_get (src);
+      gfc_conv_descriptor_elem_len_set (block, dest, elem_len);
+    }
 
   /* The 1st element in the section.  */
   tree base = gfc_index_zero_node;
@@ -2386,20 +2431,6 @@ gfc_set_descriptor (stmtblock_t *block, tree dest, tree src, gfc_expr *src_expr,
 			    &offset);
     }
 
-  /* For deferred-length character we need to take the dynamic length
-     into account for the dataptr offset.  */
-  if (src_expr->ts.type == BT_CHARACTER
-      && src_expr->ts.deferred
-      && src_expr->ts.u.cl->backend_decl
-      && VAR_P (src_expr->ts.u.cl->backend_decl)
-      && !GFC_BYTES_STRIDES_ARRAY_TYPE_P (TREE_TYPE (src)))
-    {
-      tree base_type = TREE_TYPE (base);
-      base = fold_build2_loc (input_location, MULT_EXPR, base_type, base,
-			      fold_convert (base_type,
-					    src_expr->ts.u.cl->backend_decl));
-    }
-
   for (int n = rank; n < rank + corank; n++)
     {
       tree from = lowers[n];
@@ -2907,7 +2938,8 @@ gfc_set_temporary_descriptor (stmtblock_t *block, tree descr, tree class_src,
 				ubound[n], stride[n], &offset);
       }
 
-  gfc_conv_descriptor_span_set (block, descr, elemsize);
+  if (elemsize != NULL_TREE)
+    gfc_conv_descriptor_span_set (block, descr, elemsize);
 
   gfc_conv_descriptor_offset_set (block, descr, offset);
 
@@ -3069,6 +3101,7 @@ gfc_set_descriptor_for_assign_realloc (stmtblock_t *block, gfc_loopinfo *loop,
       tree tmp = gfc_get_dtype_rank_type (expr1->rank, type,
 					  bytes_counted_strides);
       gfc_conv_descriptor_dtype_set (block, desc, tmp);
+      gfc_conv_descriptor_elem_len_set (block, desc, elemsize2);
     }
   else if (expr1->ts.type == BT_CLASS)
     {
@@ -3289,9 +3322,21 @@ gfc_descriptor_init_count (tree descriptor, int rank, int corank,
       && expr->ts.deferred
       && VAR_P (expr->ts.u.cl->backend_decl))
     {
-      type = gfc_typenode_for_spec (&expr->ts);
+      tree dtype;
-      tree dtype = gfc_get_dtype_rank_type (rank, type, bytes_counted_strides);
+      if (expr3_elem_size
+	  && TREE_CODE (expr3_elem_size) == INTEGER_CST)
+	dtype = get_dtype_rank_type_size (rank, BT_CHARACTER,
+					  bytes_counted_strides,
+					  expr3_elem_size);
+      else
+	{
+	  type = gfc_typenode_for_spec (&expr->ts);
+	  dtype = gfc_get_dtype_rank_type (rank, type, bytes_counted_strides);
+	}
       gfc_conv_descriptor_dtype_set (pblock, descriptor, dtype);
+      if (expr3_elem_size
+	  && TREE_CODE (expr3_elem_size) != INTEGER_CST)
+	gfc_conv_descriptor_elem_len_set (pblock, descriptor, expr3_elem_size);
     }
   else if (expr->ts.type == BT_CHARACTER
 	   && expr->ts.deferred

gcc/fortran/trans-expr.cc

@@ -57,7 +57,8 @@ gfc_get_character_len (tree type)
 	      && TYPE_STRING_FLAG (type));
 
   len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
-  len = (len) ? (len) : (integer_zero_node);
+  if (!len)
+    return NULL_TREE;
   return fold_convert (gfc_charlen_type_node, len);
 }