| 1 |
694 |
jeremybenn |
! { dg-do run }
|
| 2 |
|
|
! { dg-options "-fbackslash" }
|
| 3 |
|
|
|
| 4 |
|
|
logical, parameter :: bigendian = transfer ((/1_1,0_1,0_1,0_1/), 0_4) /= 1
|
| 5 |
|
|
|
| 6 |
|
|
character(kind=1,len=3) :: s1, t1, u1
|
| 7 |
|
|
character(kind=4,len=3) :: s4, t4, u4
|
| 8 |
|
|
|
| 9 |
|
|
! Test MERGE intrinsic
|
| 10 |
|
|
|
| 11 |
|
|
call check_merge1 ("foo", "gee", .true., .false.)
|
| 12 |
|
|
call check_merge4 (4_"foo", 4_"gee", .true., .false.)
|
| 13 |
|
|
|
| 14 |
|
|
if (merge ("foo", "gee", .true.) /= "foo") call abort
|
| 15 |
|
|
if (merge ("foo", "gee", .false.) /= "gee") call abort
|
| 16 |
|
|
if (merge (4_"foo", 4_"gee", .true.) /= 4_"foo") call abort
|
| 17 |
|
|
if (merge (4_"foo", 4_"gee", .false.) /= 4_"gee") call abort
|
| 18 |
|
|
|
| 19 |
|
|
! Test TRANSFER intrinsic
|
| 20 |
|
|
|
| 21 |
|
|
if (bigendian) then
|
| 22 |
|
|
if (transfer (4_"x", " ") /= "\0\0\0x") call abort
|
| 23 |
|
|
else
|
| 24 |
|
|
if (transfer (4_"x", " ") /= "x\0\0\0") call abort
|
| 25 |
|
|
endif
|
| 26 |
|
|
if (transfer (4_"\U44444444", " ") /= "\x44\x44\x44\x44") call abort
|
| 27 |
|
|
if (transfer (4_"\U3FE91B5A", 0_4) /= int(z'3FE91B5A', 4)) call abort
|
| 28 |
|
|
|
| 29 |
|
|
call check_transfer_i (4_"\U3FE91B5A", [int(z'3FE91B5A', 4)])
|
| 30 |
|
|
call check_transfer_i (4_"\u1B5A", [int(z'1B5A', 4)])
|
| 31 |
|
|
|
| 32 |
|
|
contains
|
| 33 |
|
|
|
| 34 |
|
|
subroutine check_merge1 (s1, t1, t, f)
|
| 35 |
|
|
character(kind=1,len=*) :: s1, t1
|
| 36 |
|
|
logical :: t, f
|
| 37 |
|
|
|
| 38 |
|
|
if (merge (s1, t1, .true.) /= s1) call abort
|
| 39 |
|
|
if (merge (s1, t1, .false.) /= t1) call abort
|
| 40 |
|
|
if (len (merge (s1, t1, .true.)) /= len (s1)) call abort
|
| 41 |
|
|
if (len (merge (s1, t1, .false.)) /= len (t1)) call abort
|
| 42 |
|
|
if (len_trim (merge (s1, t1, .true.)) /= len_trim (s1)) call abort
|
| 43 |
|
|
if (len_trim (merge (s1, t1, .false.)) /= len_trim (t1)) call abort
|
| 44 |
|
|
|
| 45 |
|
|
if (merge (s1, t1, t) /= s1) call abort
|
| 46 |
|
|
if (merge (s1, t1, f) /= t1) call abort
|
| 47 |
|
|
if (len (merge (s1, t1, t)) /= len (s1)) call abort
|
| 48 |
|
|
if (len (merge (s1, t1, f)) /= len (t1)) call abort
|
| 49 |
|
|
if (len_trim (merge (s1, t1, t)) /= len_trim (s1)) call abort
|
| 50 |
|
|
if (len_trim (merge (s1, t1, f)) /= len_trim (t1)) call abort
|
| 51 |
|
|
|
| 52 |
|
|
end subroutine check_merge1
|
| 53 |
|
|
|
| 54 |
|
|
subroutine check_merge4 (s4, t4, t, f)
|
| 55 |
|
|
character(kind=4,len=*) :: s4, t4
|
| 56 |
|
|
logical :: t, f
|
| 57 |
|
|
|
| 58 |
|
|
if (merge (s4, t4, .true.) /= s4) call abort
|
| 59 |
|
|
if (merge (s4, t4, .false.) /= t4) call abort
|
| 60 |
|
|
if (len (merge (s4, t4, .true.)) /= len (s4)) call abort
|
| 61 |
|
|
if (len (merge (s4, t4, .false.)) /= len (t4)) call abort
|
| 62 |
|
|
if (len_trim (merge (s4, t4, .true.)) /= len_trim (s4)) call abort
|
| 63 |
|
|
if (len_trim (merge (s4, t4, .false.)) /= len_trim (t4)) call abort
|
| 64 |
|
|
|
| 65 |
|
|
if (merge (s4, t4, t) /= s4) call abort
|
| 66 |
|
|
if (merge (s4, t4, f) /= t4) call abort
|
| 67 |
|
|
if (len (merge (s4, t4, t)) /= len (s4)) call abort
|
| 68 |
|
|
if (len (merge (s4, t4, f)) /= len (t4)) call abort
|
| 69 |
|
|
if (len_trim (merge (s4, t4, t)) /= len_trim (s4)) call abort
|
| 70 |
|
|
if (len_trim (merge (s4, t4, f)) /= len_trim (t4)) call abort
|
| 71 |
|
|
|
| 72 |
|
|
end subroutine check_merge4
|
| 73 |
|
|
|
| 74 |
|
|
subroutine check_transfer_i (s, i)
|
| 75 |
|
|
character(kind=4,len=*) :: s
|
| 76 |
|
|
integer(kind=4), dimension(len(s)) :: i
|
| 77 |
|
|
|
| 78 |
|
|
if (transfer (s, 0_4) /= ichar (s(1:1))) call abort
|
| 79 |
|
|
if (transfer (s, 0_4) /= i(1)) call abort
|
| 80 |
|
|
if (any (transfer (s, [0_4]) /= i)) call abort
|
| 81 |
|
|
if (any (transfer (s, 0_4, len(s)) /= i)) call abort
|
| 82 |
|
|
|
| 83 |
|
|
end subroutine check_transfer_i
|
| 84 |
|
|
|
| 85 |
|
|
end
|
