gcc/testsuite/gfortran.dg/optional_deferred_char_1.f90

   1 ! { dg-do run }
   2 ! PR fortran/93762
   3 ! PR fortran/100651 - deferred-length character as optional dummy argument
   4
   5 program main
   6   implicit none
   7   character(:), allocatable :: err_msg, msg3(:)
   8   character(:), pointer     :: err_msg2 => NULL()
   9
  10   ! Subroutines with optional arguments
  11   call to_int ()
  12   call to_int_p ()
  13   call test_rank1 ()
  14   call assert_code ()
  15   call assert_p ()
  16   call assert_rank1 ()
  17
  18   ! Test passing of optional arguments
  19   call to_int (err_msg)
  20   if (.not. allocated (err_msg)) stop 1
  21   if (len (err_msg) /= 7)        stop 2
  22   if (err_msg(1:7) /= "foo bar") stop 3
  23
  24   call to_int2 (err_msg)
  25   if (.not. allocated (err_msg)) stop 4
  26   if (len (err_msg) /= 7)        stop 5
  27   if (err_msg(1:7) /= "foo bar") stop 6
  28   deallocate (err_msg)
  29
  30   call to_int_p (err_msg2)
  31   if (.not. associated (err_msg2)) stop 11
  32   if (len (err_msg2) /= 8)         stop 12
  33   if (err_msg2(1:8) /= "poo bla ") stop 13
  34   deallocate (err_msg2)
  35
  36   call to_int2_p (err_msg2)
  37   if (.not. associated (err_msg2)) stop 14
  38   if (len (err_msg2) /= 8)         stop 15
  39   if (err_msg2(1:8) /= "poo bla ") stop 16
  40   deallocate (err_msg2)
  41
  42   call test_rank1 (msg3)
  43   if (.not. allocated (msg3)) stop 21
  44   if (len (msg3) /= 2)        stop 22
  45   if (size (msg3) /= 42)      stop 23
  46   if (any (msg3 /= "ok"))     stop 24
  47   deallocate (msg3)
  48
  49 contains
  50
  51   ! Deferred-length character, allocatable:
  52   subroutine assert_code (err_msg0)
  53     character(:), optional, allocatable :: err_msg0
  54     if (present (err_msg0)) err_msg0 = 'foo bar'
  55   end
  56   ! Test: optional argument
  57   subroutine to_int (err_msg1)
  58     character(:), optional, allocatable :: err_msg1
  59     call assert_code (err_msg1)
  60   end
  61   ! Control: non-optional argument
  62   subroutine to_int2 (err_msg2)
  63     character(:), allocatable :: err_msg2
  64     call assert_code (err_msg2)
  65   end
  66
  67   ! Rank-1:
  68   subroutine assert_rank1 (msg)
  69     character(:), optional, allocatable, intent(out) :: msg(:)
  70     if (present (msg)) then
  71        allocate (character(2) :: msg(42))
  72        msg(:) = "ok"
  73     end if
  74   end
  75
  76   subroutine test_rank1 (msg1)
  77     character(:), optional, allocatable, intent(out) :: msg1(:)
  78     call assert_rank1 (msg1)
  79   end
  80
  81   ! Deferred-length character, pointer:
  82   subroutine assert_p (err_msg0)
  83     character(:), optional, pointer :: err_msg0
  84     if (present (err_msg0)) then
  85        if (associated (err_msg0)) deallocate (err_msg0)
  86        allocate (character(8) :: err_msg0)
  87        err_msg0 = 'poo bla'
  88     end if
  89   end
  90
  91   subroutine to_int_p (err_msg1)
  92     character(:), optional, pointer :: err_msg1
  93     call assert_p (err_msg1)
  94   end
  95
  96   subroutine to_int2_p (err_msg2)
  97     character(:), pointer :: err_msg2
  98     call assert_p (err_msg2)
  99   end
 100 end