gcc/testsuite/gfortran.dg/widechar_intrinsics_8.f90

   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
  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) 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
  85 end