tree offset;
tree jump_label1;
tree jump_label2;
- tree neq_size;
tree lbd;
tree class_expr2 = NULL_TREE;
int n;
elemsize1 = expr1->ts.u.cl->backend_decl;
else
elemsize1 = lss->info->string_length;
+ tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
+ elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (elemsize1), elemsize1,
+ fold_convert (TREE_TYPE (elemsize1), unit_size));
+
}
else if (expr1->ts.type == BT_CLASS)
{
/* Allocate if data is NULL. */
cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
array1, build_int_cst (TREE_TYPE (array1), 0));
-
- if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
- {
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- lss->info->string_length,
- rss->info->string_length);
- cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, tmp, cond_null);
- cond_null= gfc_evaluate_now (cond_null, &fblock);
- }
- else
- cond_null= gfc_evaluate_now (cond_null, &fblock);
+ cond_null= gfc_evaluate_now (cond_null, &fblock);
tmp = build3_v (COND_EXPR, cond_null,
build1_v (GOTO_EXPR, jump_label1),
tmp = build1_v (LABEL_EXPR, jump_label1);
gfc_add_expr_to_block (&fblock, tmp);
- /* If the lhs has not been allocated, its bounds will not have been
- initialized and so its size is set to zero. */
- size1 = gfc_create_var (gfc_array_index_type, NULL);
- gfc_init_block (&alloc_block);
- gfc_add_modify (&alloc_block, size1, gfc_index_zero_node);
- gfc_init_block (&realloc_block);
- gfc_add_modify (&realloc_block, size1,
- gfc_conv_descriptor_size (desc, expr1->rank));
- tmp = build3_v (COND_EXPR, cond_null,
- gfc_finish_block (&alloc_block),
- gfc_finish_block (&realloc_block));
- gfc_add_expr_to_block (&fblock, tmp);
-
/* Get the rhs size and fix it. */
size2 = gfc_index_one_node;
for (n = 0; n < expr2->rank; n++)
}
size2 = gfc_evaluate_now (size2, &fblock);
- cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
- size1, size2);
-
- /* If the lhs is deferred length, assume that the element size
- changes and force a reallocation. */
- if (expr1->ts.deferred)
- neq_size = gfc_evaluate_now (logical_true_node, &fblock);
- else
- neq_size = gfc_evaluate_now (cond, &fblock);
-
/* Deallocation of allocatable components will have to occur on
reallocation. Fix the old descriptor now. */
if ((expr1->ts.type == BT_DERIVED)
gfc_add_block_to_block (&realloc_block, &caf_se.post);
realloc_expr = gfc_finish_block (&realloc_block);
- /* Reallocate if sizes or dynamic types are different. */
- if (elemsize1)
- {
- tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
- elemsize1, elemsize2);
- tmp = gfc_evaluate_now (tmp, &fblock);
- neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, neq_size, tmp);
- }
- tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
- build_empty_stmt (input_location));
-
- realloc_expr = tmp;
-
/* Malloc expression. */
gfc_init_block (&alloc_block);
if (!coarray)
--- /dev/null
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! PR fortran/107508
+!
+use iso_c_binding
+implicit none
+character(len=:,kind=4), allocatable, target :: a4str(:), a4str2
+type(c_ptr) :: cptr, cptr2
+
+allocate(character(len=7,kind=4) :: a4str(-2:3))
+allocate(character(len=9,kind=4) :: a4str2)
+
+cptr = c_loc(a4str)
+cptr2 = c_loc(a4str2)
+
+if (len(a4str) /= 7) error stop
+if (lbound(a4str,1) /= -2) error stop
+if (ubound(a4str,1) /= 3) error stop
+if (len(a4str2) /= 9) error stop
+
+a4str = [4_"sf456aq", 4_"3dtzu24", 4_"_4fh7sm", 4_"=ff85s7", 4_"j=8af4d", 4_".,A%Fsz"]
+a4str2 = 4_"4f5g5f8a9"
+
+!print *, lbound(a4str), ubound(a4str) ! expected (-2:3) - actually: (1:6)
+
+if (len(a4str) /= 7) error stop
+if (lbound(a4str,1) /= -2) error stop
+if (ubound(a4str,1) /= 3) error stop
+if (len(a4str2) /= 9) error stop
+if (.not. c_associated (cptr, c_loc(a4str))) error stop
+if (.not. c_associated (cptr2, c_loc(a4str2))) error stop
+end
+
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 4 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_realloc" 2 "original" } }
+
+! { dg-final { scan-tree-dump-times "a4str.data = __builtin_malloc \\(168\\);" 2 "original" } }
+! { dg-final { scan-tree-dump-times "a4str.data = __builtin_realloc \\(a4str.data, 168\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "a4str2 = \\(character\\(kind=4\\)\\\[1:.a4str2\\\] \\*\\) __builtin_malloc \\(36\\);" 2 "original" } }
+! { dg-final { scan-tree-dump-times "a4str2 = \\(character\\(kind=4\\)\\\[1:.a4str2\\\] \\*\\) __builtin_realloc \\(\\(void \\*\\) a4str2, 36\\);" 1 "original" } }
+
+! Array: Assert, realloc-check assign string length (alloc + (realloc'ed) assignment):
+! { dg-final { scan-tree-dump-times "if \\(\[^\\n\\r\]*\\.a4str != 7\\)" 2 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(D\\.\[0-9\]+ != 28\\) goto L\\." 1 "original" } }
+! { dg-final { scan-tree-dump-times "\\.a4str = 7;" 2 "original" } }
+
+! Scalar: Assert, realloc-check assign string length (alloc + (realloc'ed) assignment):
+! { dg-final { scan-tree-dump-times "if \\(\[^\\n\\r\]*\\.a4str2 != 9\\)" 2 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\.a4str2 == 9\\) goto L\\." 1 "original" } }
+! { dg-final { scan-tree-dump-times "\\.a4str2 = 9;" 2 "original" } }