gcc/testsuite/gfortran.dg/deferred_character_29.f90

   1 ! { dg-do compile }
   2 !
   3 ! Test the fix for PR83196 comment #4 (there by mistake)
   4 !
   5 ! Contributed by Arjen Markus  <arjen.markus895@gmail.com>
   6 !____________________________________________________________
   7 ! keyindex.f90 --
   8 !     Class implementing a straightforward keyword/index list
   9 !     The idea is to have a very simple implementation to
  10 !     store keywords (strings) and return the position in the
  11 !     list or vice versa.
  12 !____________________________________________________________
  13 module keyindices
  14     implicit none
  15
  16     private
  17
  18     integer, parameter                              :: default_keylength = 40
  19
  20     type keyindex
  21         integer                                     :: keylength
  22         integer                                     :: lastindex = 0
  23         character(len=:), dimension(:), allocatable :: keyword
  24     contains
  25         procedure                                   :: init      => init_keyindex
  26         procedure                                   :: get_index => get_index_from_list
  27         procedure                                   :: get_key   => get_keyword_from_list
  28         procedure                                   :: has_key   => has_keyword_in_list
  29     end type keyindex
  30
  31     public :: keyindex
  32 contains
  33
  34 ! init_keyindex --
  35 !     Initialise the object
  36 !
  37 ! Arguments:
  38 !     this                     Keyindex object
  39 !     initial_size             Initial size of the list (optimisation)
  40 !     keylength                Maximum length of a keyword (optional)
  41 !
  42 subroutine init_keyindex( this, initial_size, keylength )
  43     class(keyindex), intent(inout) :: this
  44     integer, intent(in)           :: initial_size
  45     integer, intent(in), optional :: keylength
  46
  47     integer                       :: keylength_
  48
  49     if ( present(keylength) ) then
  50         keylength_ = keylength
  51     else
  52         keylength_ = default_keylength
  53     endif
  54
  55     !
  56     ! Allocate the list of keywords
  57     !
  58     if ( allocated(this%keyword) ) then
  59         deallocate( this%keyword )
  60     endif
  61
  62
  63     allocate( character(len=keylength_):: this%keyword(initial_size) )
  64
  65     this%lastindex = 0
  66     this%keylength = keylength_
  67 end subroutine init_keyindex
  68
  69 ! get_index_from_list --
  70 !     Look up the keyword in the list and return its index
  71 !
  72 ! Arguments:
  73 !     this                     Keyindex object
  74 !     keyword                  Keyword to be looked up
  75 !
  76 ! Returns:
  77 !     Index in the list
  78 !
  79 ! Note:
  80 !     If the keyword does not yet exist, add it to the list
  81 !
  82 integer function get_index_from_list( this, keyword )
  83     class(keyindex), intent(inout) :: this
  84     character(len=*), intent(in)  :: keyword
  85
  86     integer                       :: i
  87     character(len=this%keylength), dimension(:), allocatable :: newlist
  88
  89     if ( .not. allocated(this%keyword) ) then
  90         call this%init( 50 )
  91     endif
  92
  93     get_index_from_list = 0
  94
  95     do i = 1,this%lastindex
  96         if ( this%keyword(i) == keyword ) then
  97             get_index_from_list = i
  98             exit
  99         endif
 100     enddo
 101
 102     !
 103     ! Do we need to add it?
 104     !
 105     if ( get_index_from_list == 0 ) then
 106         if ( size(this%keyword) <= this%lastindex ) then
 107             !
 108             ! Allocate a larger list
 109             !
 110             allocate( character(len=this%keylength):: newlist(2*size(this%keyword)) )
 111
 112             newlist(1:size(this%keyword)) = this%keyword
 113             call move_alloc( newlist, this%keyword )
 114         endif
 115
 116         get_index_from_list = this%lastindex + 1
 117         this%lastindex      = get_index_from_list
 118         this%keyword(get_index_from_list) = keyword
 119     endif
 120 end function get_index_from_list
 121
 122 ! get_keyword_from_list --
 123 !     Look up the keyword in the list by the given index
 124 !
 125 ! Arguments:
 126 !     this                     Keyindex object
 127 !     idx                      Index of the keyword
 128 !
 129 ! Returns:
 130 !     Keyword as stored in the list
 131 !
 132 ! Note:
 133 !     If the index does not exist, an empty string is returned
 134 !
 135 function get_keyword_from_list( this, idx )
 136     class(keyindex), intent(inout) :: this
 137     integer, intent(in)            :: idx
 138
 139     character(len=this%keylength)  :: get_keyword_from_list
 140
 141     get_keyword_from_list = ' '
 142
 143     if ( idx >= 1 .and. idx <= this%lastindex ) then
 144         get_keyword_from_list = this%keyword(idx)
 145     endif
 146 end function get_keyword_from_list
 147
 148 ! has_keyword_in_list --
 149 !     Look up whether the keyword is stored in the list or not
 150 !
 151 ! Arguments:
 152 !     this                     Keyindex object
 153 !     keyword                  Keyword to be looked up
 154 !
 155 ! Returns:
 156 !     True if the keyword is in the list or false if not
 157 !
 158 logical function has_keyword_in_list( this, keyword )
 159     class(keyindex), intent(inout) :: this
 160     character(len=*), intent(in)  :: keyword
 161
 162     integer                       :: i
 163
 164     has_keyword_in_list = .false.
 165
 166     do i = 1,this%lastindex
 167         if ( this%keyword(i) == keyword ) then
 168             has_keyword_in_list = .true.
 169             exit
 170         endif
 171     enddo
 172 end function has_keyword_in_list
 173
 174 end module keyindices
 175
 176     use keyindices
 177     type(keyindex) :: idx
 178
 179     call idx%init (3, 8)
 180
 181     if (idx%get_index ("one") .ne. 1) stop 1
 182     if (idx%get_index ("two") .ne. 2) stop 2
 183     if (idx%get_index ("three") .ne. 3) stop 3
 184
 185 ! Check that new span is generated as list is extended.
 186     if (idx%get_index ("four") .ne. 4) stop 4
 187     if (idx%get_index ("five") .ne. 5) stop 5
 188     if (idx%get_index ("six") .ne. 6) stop 6
 189
 190 ! Search by keyword
 191     if (.not.idx%has_key ("four")) stop 7
 192     if (idx%has_key ("seven")) stop 8
 193
 194 ! Search by index
 195     if (idx%get_key (4) .ne. "four") stop 9
 196     if (idx%get_key (10) .ne. "") stop 10
 197 end