trunk/gcc/testsuite/gfortran.dg/achar_6.F90

   1 ! { dg-do run }
   2 ! { dg-options "-fbackslash" }
   3
   4 #define TEST(x,y,z) \
   5   call test (x, y, z, iachar(x), iachar(y), ichar(x), ichar(y))
   6
   7   TEST("a", 4_"a", 97)
   8   TEST("\0", 4_"\0", 0)
   9   TEST("\b", 4_"\b", 8)
  10   TEST("\x80", 4_"\x80", int(z'80'))
  11   TEST("\xFF", 4_"\xFF", int(z'FF'))
  12
  13 #define TEST2(y,z) \
  14   call test_bis (y, z, iachar(y), ichar(y))
  15
  16   TEST2(4_"\u0100", int(z'0100'))
  17   TEST2(4_"\ufe00", int(z'fe00'))
  18   TEST2(4_"\u106a", int(z'106a'))
  19   TEST2(4_"\uff00", int(z'ff00'))
  20   TEST2(4_"\uffff", int(z'ffff'))
  21
  22 contains
  23
  24 subroutine test (s1, s4, i, i1, i2, i3, i4)
  25   character(kind=1,len=1) :: s1
  26   character(kind=4,len=1) :: s4
  27   integer :: i, i1, i2, i3, i4
  28
  29   if (i /= i1) call abort
  30   if (i /= i2) call abort
  31   if (i /= i3) call abort
  32   if (i /= i4) call abort
  33
  34   if (iachar (s1) /= i) call abort
  35   if (iachar (s4) /= i) call abort
  36
  37   if (ichar (s1) /= i) call abort
  38   if (ichar (s4) /= i) call abort
  39
  40   if (achar(i, kind=1) /= s1) call abort
  41   if (achar(i, kind=4) /= s4) call abort
  42
  43   if (char(i, kind=1) /= s1) call abort
  44   if (char(i, kind=4) /= s4) call abort
  45
  46   if (iachar(achar(i, kind=1)) /= i) call abort
  47   if (iachar(achar(i, kind=4)) /= i) call abort
  48
  49   if (ichar(char(i, kind=1)) /= i) call abort
  50   if (ichar(char(i, kind=4)) /= i) call abort
  51
  52 end subroutine test
  53
  54 subroutine test_bis (s4, i, i2, i4)
  55   character(kind=4,len=1) :: s4
  56   integer :: i, i2, i4
  57
  58   if (i /= i2) call abort
  59   if (i /= i4) call abort
  60
  61   if (iachar (s4) /= i) call abort
  62   if (ichar (s4) /= i) call abort
  63   if (achar(i, kind=4) /= s4) call abort
  64   if (char(i, kind=4) /= s4) call abort
  65   if (iachar(achar(i, kind=4)) /= i) call abort
  66   if (ichar(char(i, kind=4)) /= i) call abort
  67
  68 end subroutine test_bis
  69
  70 end