1module fox_m_fsys_varstr 2 implicit none 3 4 private 5 6 public :: varstr 7 public :: init_varstr 8 public :: destroy_varstr 9 public :: varstr_len 10 public :: is_varstr_empty 11 public :: set_varstr_empty 12 public :: is_varstr_null 13 public :: set_varstr_null 14 public :: vs_varstr_alloc 15 public :: move_varstr_vs 16 public :: move_varstr_varstr 17 public :: str_varstr 18 public :: append_varstr 19 public :: varstr_str 20 public :: varstr_vs 21 public :: equal_varstr_str 22 public :: equal_varstr_varstr 23 24 ! Allocation step in which the data within varstr will be allocated 25 integer, parameter :: VARSTR_INIT_SIZE=1024 26 integer, parameter :: VARSTR_ALLOC_SIZE=1024 27 28 ! Variable size string type. 29 ! It is used for token field, so that it can be grown 30 ! by one character at a time without incurring constant 31 ! penalty on allocating/deallocating vs data. 32 ! See functions and subroutines at the end of this module. 33 type varstr 34 private 35 character, dimension(:), pointer :: data 36 integer :: length 37 end type varstr 38 39contains 40 41! Initialise varstr type. The string is initialised as null (i.e. invalid) 42subroutine init_varstr(vstr) 43 type(varstr), intent(inout) :: vstr 44 allocate(vstr%data(VARSTR_INIT_SIZE)) 45 vstr%length = -1 46end subroutine init_varstr 47 48! Clean up memory (leaves varstr null, and drops the data field) 49subroutine destroy_varstr(vstr) 50 type(varstr), intent(inout) :: vstr 51 if (associated(vstr%data)) deallocate(vstr%data) 52 call set_varstr_null(vstr) 53end subroutine destroy_varstr 54 55! Return real length of varstr 56function varstr_len(vstr) result(l) 57 type(varstr), intent(in) :: vstr 58 integer :: l 59 if (vstr%length<0) print *, "WARNING: asking for length of null varstr" 60 l = vstr%length 61end function varstr_len 62 63 64! Make sure that varstr is at least size-n. 65! The data will be kept (copied) if keep is true (default) 66! This can be called on a null varstr, but should noty be called on 67! one which was destroyed. 68subroutine ensure_varstr_size(vstr,n,keep) 69 type(varstr), intent(inout) :: vstr 70 integer, intent(in) :: n 71 logical, optional, intent(in) :: keep 72 73 character, pointer, dimension(:) :: new_data 74 integer :: new_size, old_size 75 logical :: keep_flag 76 77 if (present(keep)) then 78 keep_flag = keep 79 else 80 keep_flag = .true. 81 end if 82 83 old_size = size(vstr%data) 84 if (n <= old_size ) return 85 86 new_size = old_size + ((n-old_size)/VARSTR_ALLOC_SIZE+1) * VARSTR_ALLOC_SIZE 87 allocate(new_data(new_size)) 88 89 if (keep_flag) new_data(1:old_size) = vstr%data(1:old_size) 90 91 deallocate( vstr%data ) 92 vstr%data => new_data 93end subroutine ensure_varstr_size 94 95! Returns whether varstr is empty: "" 96function is_varstr_empty(vstr) 97 type(varstr), intent(in) :: vstr 98 logical is_varstr_empty 99 is_varstr_empty = (vstr%length == 0) 100end function is_varstr_empty 101 102! Set vstr to empty string 103subroutine set_varstr_empty(vstr) 104 type(varstr), intent(inout) :: vstr 105 vstr%length = 0 106end subroutine set_varstr_empty 107 108! Returns whether varstr is null (i.e. invalid) 109function is_varstr_null(vstr) 110 type(varstr), intent(in) :: vstr 111 logical is_varstr_null 112 is_varstr_null = (vstr%length < 0) 113end function is_varstr_null 114 115! Set vstr to null 116subroutine set_varstr_null(vstr) 117 type(varstr), intent(inout) :: vstr 118 vstr%length = -1 119end subroutine set_varstr_null 120 121! Convert varstr to newly allocated array of characters 122function vs_varstr_alloc(vstr) result(vs) 123 type(varstr) :: vstr 124 character, dimension(:), pointer :: vs 125 126 if (is_varstr_null(vstr)) then 127 print *, "WARNING: Converting null varstr to string... making it empty first" 128 call set_varstr_empty(vstr) 129 end if 130 131 allocate(vs(vstr%length)) 132 vs = vstr%data(1:vstr%length) 133end function vs_varstr_alloc 134 135! This call moves data from varstr to vs (i.e. vs is overwritten and vstr is made null) 136subroutine move_varstr_vs(vstr,vs) 137 type(varstr), intent(inout) :: vstr 138 character, dimension(:), pointer, intent(inout) :: vs 139 140 if (associated(vs)) deallocate(vs) 141 vs => vs_varstr_alloc(vstr) 142 call set_varstr_null(vstr) 143end subroutine move_varstr_vs 144 145! This call moves data from varstr to varstr (src becomes null) 146subroutine move_varstr_varstr(src,dst) 147 type(varstr), intent(inout) :: src 148 type(varstr), intent(inout) :: dst 149 character, dimension(:), pointer :: tmpdata 150 151 tmpdata => dst%data 152 dst%data => src%data 153 src%data => tmpdata 154 dst%length = src%length 155 156 call set_varstr_null(src) 157end subroutine move_varstr_varstr 158 159 160! Convert varstr to string type 161function str_varstr(vstr) result(s) 162 type(varstr), intent(in) :: vstr 163 character(len=vstr%length) :: s 164 integer :: i 165 166 if (is_varstr_null(vstr)) then 167 ! Can we really end-up here? Or will it blow on allocation with len=-1 ? 168 print *, "WARNING: Trying to convert null varstr to str... returning empty string" 169 s = "" 170 end if 171 172 do i = 1, vstr%length 173 s(i:i) = vstr%data(i) 174 enddo 175end function str_varstr 176 177! Append string to varstr 178subroutine append_varstr(vstr,str) 179 type(varstr), intent(inout) :: vstr 180 character(len=*), intent(in) :: str 181 character, dimension(:), pointer :: tmp 182 integer :: i 183 184 if (is_varstr_null(vstr)) then 185 print *, "WARNING: Trying to append to null varstr... making it empty first" 186 call set_varstr_empty(vstr) 187 end if 188 189 call ensure_varstr_size(vstr,vstr%length+len(str)) 190 191 ! Note: on a XML file with very large tokens, this loop 192 ! is consistently faster than equivalent 'transfer' intrinsic 193 do i=1,len(str) 194 vstr%data(vstr%length+i) = str(i:i) 195 end do 196 vstr%length = vstr%length + len(str) 197end subroutine append_varstr 198 199! Convert string to varstr in place 200subroutine varstr_str(vstr,str) 201 type(varstr), intent(inout) :: vstr 202 character(len=*), intent(in) :: str 203 integer :: i 204 205 call ensure_varstr_size(vstr,len(str),.false.) 206 do i=1,len(str) 207 vstr%data(i) = str(i:i) 208 end do 209 vstr%length = len(str) 210end subroutine varstr_str 211 212! Convert character array to varstr in place 213subroutine varstr_vs(vstr,vs) 214 type(varstr), intent(inout) :: vstr 215 character, dimension(:), intent(in) :: vs 216 217 call ensure_varstr_size(vstr,size(vs),.false.) 218 219 vstr%length = size(vs) 220 vstr%data(1:size(vs)) = vs 221end subroutine varstr_vs 222 223! Compare varstr to str (true if equal) 224function equal_varstr_str(vstr,str) result(r) 225 type(varstr), intent(in) :: vstr 226 character(len=*) :: str 227 logical :: r 228 229 integer :: i 230 231 r = .false. 232 if ( len(str) /= varstr_len(vstr) ) return 233 do i=1,len(str) 234 if ( str(i:i) /= vstr%data(i) ) return 235 end do 236 r = .true. 237end function equal_varstr_str 238 239! Compare varstr to varstr (true if equal) 240function equal_varstr_varstr(vstr1,vstr2) result(r) 241 type(varstr), intent(in) :: vstr1, vstr2 242 logical :: r 243 244 integer :: i 245 246 r = .false. 247 if ( varstr_len(vstr1) /= varstr_len(vstr2) ) return 248 do i=1,varstr_len(vstr1) 249 if ( vstr1%data(i) /= vstr2%data(i) ) return 250 end do 251 r = .true. 252end function equal_varstr_varstr 253 254end module fox_m_fsys_varstr 255