1! { 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") STOP 1 15 if (merge ("foo", "gee", .false.) /= "gee") STOP 2 16 if (merge (4_"foo", 4_"gee", .true.) /= 4_"foo") STOP 3 17 if (merge (4_"foo", 4_"gee", .false.) /= 4_"gee") STOP 4 18 19 ! Test TRANSFER intrinsic 20 21 if (bigendian) then 22 if (transfer (4_"x", " ") /= "\0\0\0x") STOP 5 23 else 24 if (transfer (4_"x", " ") /= "x\0\0\0") STOP 6 25 endif 26 if (transfer (4_"\U44444444", " ") /= "\x44\x44\x44\x44") STOP 7 27 if (transfer (4_"\U3FE91B5A", 0_4) /= int(z'3FE91B5A', 4)) STOP 8 28 29 call check_transfer_i (4_"\U3FE91B5A", [int(z'3FE91B5A', 4)]) 30 call check_transfer_i (4_"\u1B5A", [int(z'1B5A', 4)]) 31 32contains 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) STOP 9 39 if (merge (s1, t1, .false.) /= t1) STOP 10 40 if (len (merge (s1, t1, .true.)) /= len (s1)) STOP 11 41 if (len (merge (s1, t1, .false.)) /= len (t1)) STOP 12 42 if (len_trim (merge (s1, t1, .true.)) /= len_trim (s1)) STOP 13 43 if (len_trim (merge (s1, t1, .false.)) /= len_trim (t1)) STOP 14 44 45 if (merge (s1, t1, t) /= s1) STOP 15 46 if (merge (s1, t1, f) /= t1) STOP 16 47 if (len (merge (s1, t1, t)) /= len (s1)) STOP 17 48 if (len (merge (s1, t1, f)) /= len (t1)) STOP 18 49 if (len_trim (merge (s1, t1, t)) /= len_trim (s1)) STOP 19 50 if (len_trim (merge (s1, t1, f)) /= len_trim (t1)) STOP 20 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) STOP 21 59 if (merge (s4, t4, .false.) /= t4) STOP 22 60 if (len (merge (s4, t4, .true.)) /= len (s4)) STOP 23 61 if (len (merge (s4, t4, .false.)) /= len (t4)) STOP 24 62 if (len_trim (merge (s4, t4, .true.)) /= len_trim (s4)) STOP 25 63 if (len_trim (merge (s4, t4, .false.)) /= len_trim (t4)) STOP 26 64 65 if (merge (s4, t4, t) /= s4) STOP 27 66 if (merge (s4, t4, f) /= t4) STOP 28 67 if (len (merge (s4, t4, t)) /= len (s4)) STOP 29 68 if (len (merge (s4, t4, f)) /= len (t4)) STOP 30 69 if (len_trim (merge (s4, t4, t)) /= len_trim (s4)) STOP 31 70 if (len_trim (merge (s4, t4, f)) /= len_trim (t4)) STOP 32 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))) STOP 33 79 if (transfer (s, 0_4) /= i(1)) STOP 34 80 if (any (transfer (s, [0_4]) /= i)) STOP 35 81 if (any (transfer (s, 0_4, len(s)) /= i)) STOP 36 82 83 end subroutine check_transfer_i 84 85end 86