| ! { dg-do run } |
| ! PR fortran/113911 |
| ! |
| ! Test that deferred length is not lost |
| |
| module m |
| integer, parameter :: n = 100, l = 10 |
| character(l) :: a = 'a234567890', b(n) = 'bcdefghijk' |
| character(:), allocatable :: c1, c2(:) |
| end |
| |
| program p |
| use m, only : l, n, a, b, x => c1, y => c2 |
| implicit none |
| character(:), allocatable :: d, e(:) |
| allocate (d, source=a) |
| allocate (e, source=b) |
| if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 12 |
| call plain_deferred (d, e) |
| call optional_deferred (d, e) |
| call optional_deferred_ar (d, e) |
| if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 13 |
| deallocate (d, e) |
| call alloc (d, e) |
| if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 14 |
| deallocate (d, e) |
| call alloc_host_assoc () |
| if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 15 |
| deallocate (d, e) |
| call alloc_use_assoc () |
| if (len (x) /= l .or. len (y) /= l .or. size (y) /= n) stop 16 |
| call indirect (x, y) |
| if (len (x) /= l .or. len (y) /= l .or. size (y) /= n) stop 17 |
| deallocate (x, y) |
| contains |
| subroutine plain_deferred (c1, c2) |
| character(:), allocatable :: c1, c2(:) |
| if (.not. allocated (c1) .or. .not. allocated (c2)) stop 1 |
| if (len (c1) /= l) stop 2 |
| if (len (c2) /= l) stop 3 |
| if (c1(1:3) /= "a23") stop 4 |
| if (c2(5)(1:3) /= "bcd") stop 5 |
| end |
| |
| subroutine optional_deferred (c1, c2) |
| character(:), allocatable, optional :: c1, c2(:) |
| if (.not. present (c1) .or. .not. present (c2)) stop 6 |
| if (.not. allocated (c1) .or. .not. allocated (c2)) stop 7 |
| if (len (c1) /= l) stop 8 |
| if (len (c2) /= l) stop 9 |
| if (c1(1:3) /= "a23") stop 10 |
| if (c2(5)(1:3) /= "bcd") stop 11 |
| end |
| |
| ! Assumed rank |
| subroutine optional_deferred_ar (c1, c2) |
| character(:), allocatable, optional :: c1(..) |
| character(:), allocatable, optional :: c2(..) |
| if (.not. present (c1) .or. & |
| .not. present (c2)) stop 21 |
| if (.not. allocated (c1) .or. & |
| .not. allocated (c2)) stop 22 |
| |
| select rank (c1) |
| rank (0) |
| if (len (c1) /= l) stop 23 |
| if (c1(1:3) /= "a23") stop 24 |
| rank default |
| stop 25 |
| end select |
| |
| select rank (c2) |
| rank (1) |
| if (len (c2) /= l) stop 26 |
| if (c2(5)(1:3) /= "bcd") stop 27 |
| rank default |
| stop 28 |
| end select |
| end |
| |
| ! Allocate dummy arguments |
| subroutine alloc (c1, c2) |
| character(:), allocatable :: c1, c2(:) |
| allocate (c1, source=a) |
| allocate (c2, source=b) |
| end |
| |
| ! Allocate host-associated variables |
| subroutine alloc_host_assoc () |
| allocate (d, source=a) |
| allocate (e, source=b) |
| end |
| |
| ! Allocate use-associated variables |
| subroutine alloc_use_assoc () |
| allocate (x, source=a) |
| allocate (y, source=b) |
| end |
| |
| ! Pass-through deferred-length |
| subroutine indirect (c1, c2) |
| character(:), allocatable :: c1, c2(:) |
| call plain_deferred (c1, c2) |
| call optional_deferred (c1, c2) |
| call optional_deferred_ar (c1, c2) |
| end |
| end |