goto failure;
}
+ /* Check F2008:C639: "Corresponding kind type parameters of
+ allocate-object and source-expr shall have the same values." */
+ if (e->ts.type == BT_CHARACTER
+ && !e->ts.deferred
+ && e->ts.u.cl->length
+ && code->expr3->ts.type == BT_CHARACTER
+ && !gfc_check_same_strlen (e, code->expr3, "ALLOCATE with "
+ "SOURCE= or MOLD= specifier"))
+ goto failure;
+
/* Check TS18508, C702/C703. */
if (code->expr3->ts.type == BT_DERIVED
&& ((codimension && gfc_expr_attr (code->expr3).event_comp)
in the array is needed, which is the product of the len and
esize for char arrays. For unlimited polymorphics len can be
zero, therefore take the maximum of len and one. */
+ tree lhs_len;
+
+ /* If an allocatable character variable has fixed length, use it.
+ Otherwise use source length. As different lengths are not
+ allowed by the standard, generate a runtime check. */
+ if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred)
+ {
+ gfc_trans_same_strlen_check ("ALLOCATE with SOURCE= or MOLD=",
+ &code->expr3->where,
+ se.string_length, expr3_len,
+ &block);
+ lhs_len = fold_convert (TREE_TYPE (expr3_len), se.string_length);
+ }
+ else
+ lhs_len = expr3_len;
+
tmp = fold_build2_loc (input_location, MAX_EXPR,
TREE_TYPE (expr3_len),
- expr3_len, fold_convert (TREE_TYPE (expr3_len),
- integer_one_node));
+ lhs_len, fold_convert (TREE_TYPE (expr3_len),
+ integer_one_node));
tmp = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (expr3_esize), expr3_esize,
fold_convert (TREE_TYPE (expr3_esize), tmp));
allocate.
expr3_len is set when expr3 is an unlimited polymorphic
- object or a deferred length string. */
+ object or a deferred length string.
+
+ If an allocatable character variable has fixed length, use it.
+ Otherwise use source length. As different lengths are not
+ allowed by the standard, a runtime check was inserted
+ above. */
if (expr3_len != NULL_TREE)
{
- tmp = fold_convert (TREE_TYPE (expr3_esize), expr3_len);
+ tree lhs_len;
+ if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred)
+ lhs_len = fold_convert (TREE_TYPE (expr3_len),
+ se.string_length);
+ else
+ lhs_len = expr3_len;
+
+ tmp = fold_convert (TREE_TYPE (expr3_esize), lhs_len);
tmp = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (expr3_esize),
expr3_esize, tmp);
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+! PR fortran/113793
+!
+! Static checks of string length for ALLOCATE with SOURCE= or MOLD=
+
+program p
+ implicit none
+ character(kind=1,len=8), allocatable :: a(:), d, b(:,:)
+ character(kind=4,len=6), allocatable :: c(:), e, f(:,:)
+ character(kind=1,len=2) :: c1 = "xx"
+ character(kind=1,len=8) :: c2 = "yy"
+ character(kind=4,len=6) :: c3 = 4_"ww"
+ character(kind=4,len=3) :: c4 = 4_"zz"
+
+ ALLOCATE (a(1),source= "a") ! { dg-error "Unequal character lengths .8/1. " }
+ ALLOCATE (a(2),mold = "bb") ! { dg-error "Unequal character lengths .8/2. " }
+ ALLOCATE (c(3),source=4_"yyy") ! { dg-error "Unequal character lengths .6/3. " }
+ ALLOCATE (c(4),mold =4_"zzzz") ! { dg-error "Unequal character lengths .6/4. " }
+ ALLOCATE (d, source= "12345") ! { dg-error "Unequal character lengths .8/5. " }
+ ALLOCATE (d, source= "12345678")
+ ALLOCATE (d, mold = "123456") ! { dg-error "Unequal character lengths .8/6. " }
+ ALLOCATE (e, source=4_"654321")
+ ALLOCATE (e, mold =4_"7654321") ! { dg-error "Unequal character lengths .6/7. " }
+ ALLOCATE (a(5),source=c1) ! { dg-error "Unequal character lengths .8/2. " }
+ ALLOCATE (a(6),mold =c1) ! { dg-error "Unequal character lengths .8/2. " }
+ ALLOCATE (c(7),source=c4) ! { dg-error "Unequal character lengths .6/3. " }
+ ALLOCATE (c(8),mold =c4) ! { dg-error "Unequal character lengths .6/3. " }
+ ALLOCATE (a,source=[c1,c1,c1]) ! { dg-error "Unequal character lengths .8/2. " }
+ ALLOCATE (a,source=[c2,c2,c2])
+ ALLOCATE (c,source=[c3,c3])
+ ALLOCATE (c,source=[c4,c4]) ! { dg-error "Unequal character lengths .6/3. " }
+ ALLOCATE (d,source=c1) ! { dg-error "Unequal character lengths .8/2. " }
+ ALLOCATE (e,source=c4) ! { dg-error "Unequal character lengths .6/3. " }
+ ALLOCATE (b,source=reshape([c1],[1,1])) ! { dg-error "Unequal character lengths .8/2. " }
+ ALLOCATE (b,source=reshape([c2],[1,1]))
+ ALLOCATE (f,source=reshape([c3],[1,1]))
+ ALLOCATE (f,source=reshape([c4],[1,1])) ! { dg-error "Unequal character lengths .6/3. " }
+contains
+ subroutine foo (s)
+ character(*), intent(in) :: s
+ character(len=8), allocatable :: f(:), g
+ ALLOCATE (f(3), source=s)
+ ALLOCATE (d, source=s)
+ ALLOCATE (f(3), mold=s)
+ ALLOCATE (d, mold=s)
+ end
+end
--- /dev/null
+! { dg-do run }
+! { dg-additional-options "-std=f2008 -fcheck=bounds -g -fdump-tree-original" }
+! { dg-output "At line 43 .*" }
+! { dg-shouldfail "Unequal character lengths .3/2. in ALLOCATE with SOURCE= or MOLD=" }
+!
+! PR fortran/113793
+!
+! Test runtime checks of string length for ALLOCATE with SOURCE= or MOLD=
+
+program p
+ implicit none
+ character(kind=1,len=2) :: c1 = "xx"
+ character(kind=1,len=8) :: c2 = "yy"
+ character(kind=4,len=6) :: c3 = 4_"ww"
+ call sub1 (len (c2), c2)
+ call sub4 (len (c3), c3)
+ call test (len (c1) + 1, c1)
+contains
+ subroutine sub1 (n, s)
+ integer, intent(in) :: n
+ character(*), intent(in) :: s
+ character(len=8), allocatable :: f(:), g
+ character(len=n), allocatable :: h(:), j
+ ALLOCATE (f(7), source=s)
+ ALLOCATE (g, source=s)
+ ALLOCATE (h(5), mold=s)
+ ALLOCATE (j, mold=s)
+ end
+ subroutine sub4 (n, s)
+ integer, intent(in) :: n
+ character(kind=4,len=*), intent(in) :: s
+ character(kind=4,len=6), allocatable :: f(:), g
+ character(kind=4,len=n), allocatable :: h(:), j
+ ALLOCATE (f(3), source=s)
+ ALLOCATE (g, source=s)
+ ALLOCATE (h(5), mold=s)
+ ALLOCATE (j, mold=s)
+ end
+ subroutine test (n, s)
+ integer, intent(in) :: n
+ character(*), intent(in) :: s
+ character(len=n), allocatable :: str
+ ALLOCATE (str, source=s)
+ end
+end
+
+! { dg-final { scan-tree-dump-times "__builtin_malloc .72.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_malloc .24.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_malloc .56.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_malloc .8.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "ALLOCATE with SOURCE= or MOLD=" 9 "original" } }
--- /dev/null
+! { dg-do run }
+! { dg-additional-options "-std=gnu -fcheck=no-bounds" }
+!
+! PR fortran/113793
+!
+! Test extension for ALLOCATE with SOURCE= or MOLD= that strings
+! are truncated or padded and no memory corruption occurs
+
+program p
+ implicit none
+ call test_pad (8, "12345")
+ call test_trunc (6, "123456789")
+contains
+ subroutine test_pad (n, s)
+ integer, intent(in) :: n
+ character(*), intent(in) :: s
+ character(len=n), allocatable :: a(:), b(:,:)
+ if (len (s) >= n) stop 111
+ ALLOCATE (a(100),source=s)
+ ALLOCATE (b(5,6),source=s)
+! print *, ">", a(42), "<"
+! print *, ">", b(3,4), "<"
+ if (a(42) /= s) stop 1
+ if (b(3,4) /= s) stop 2
+ end
+ subroutine test_trunc (n, s)
+ integer, intent(in) :: n
+ character(*), intent(in) :: s
+ character(len=n), allocatable :: a(:), b(:,:)
+ if (len (s) <= n) stop 222
+ ALLOCATE (a(100),source=s)
+ ALLOCATE (b(5,6),source=s)
+! print *, ">", a(42), "<"
+! print *, ">", b(3,4), "<"
+ if (a(42) /= s(1:n)) stop 3
+ if (b(3,4) /= s(1:n)) stop 4
+ end
+end