| 1 | !=============================================================================== |
| 2 | ! fortsh_c_strings.f90 - Fortran wrapper for C string buffer library |
| 3 | ! |
| 4 | ! Purpose: Provide safe string operations that bypass flang-new ARM64 bugs |
| 5 | ! |
| 6 | ! Usage: |
| 7 | ! use fortsh_c_strings |
| 8 | ! type(c_string_buffer) :: buf |
| 9 | ! character(len=1024) :: fortran_str |
| 10 | ! |
| 11 | ! buf = c_string_create(1024) |
| 12 | ! call c_string_set(buf, "Hello, World!") |
| 13 | ! call c_string_to_fortran(buf, fortran_str) |
| 14 | ! call c_string_destroy(buf) |
| 15 | ! |
| 16 | !=============================================================================== |
| 17 | module fortsh_c_strings |
| 18 | use, intrinsic :: iso_c_binding |
| 19 | implicit none |
| 20 | private |
| 21 | |
| 22 | ! Public types |
| 23 | public :: c_string_buffer |
| 24 | |
| 25 | ! Public functions |
| 26 | public :: c_string_create, c_string_destroy, c_string_clear |
| 27 | public :: c_string_length, c_string_capacity |
| 28 | public :: c_string_set, c_string_copy, c_string_substring |
| 29 | public :: c_string_get_char, c_string_set_char |
| 30 | public :: c_string_insert, c_string_delete, c_string_append |
| 31 | public :: c_string_trim, c_string_find, c_string_compare |
| 32 | public :: c_string_to_fortran, c_string_from_fortran |
| 33 | public :: c_string_c_str |
| 34 | |
| 35 | !----------------------------------------------------------------------------- |
| 36 | ! Opaque handle to C buffer |
| 37 | !----------------------------------------------------------------------------- |
| 38 | type :: c_string_buffer |
| 39 | type(c_ptr) :: handle = c_null_ptr |
| 40 | end type c_string_buffer |
| 41 | |
| 42 | !----------------------------------------------------------------------------- |
| 43 | ! C function interfaces |
| 44 | !----------------------------------------------------------------------------- |
| 45 | interface |
| 46 | |
| 47 | ! Buffer management |
| 48 | function fortsh_buffer_create_c(capacity) bind(C, name='fortsh_buffer_create') |
| 49 | import :: c_ptr, c_size_t |
| 50 | integer(c_size_t), value :: capacity |
| 51 | type(c_ptr) :: fortsh_buffer_create_c |
| 52 | end function |
| 53 | |
| 54 | subroutine fortsh_buffer_destroy_c(buf) bind(C, name='fortsh_buffer_destroy') |
| 55 | import :: c_ptr |
| 56 | type(c_ptr), value :: buf |
| 57 | end subroutine |
| 58 | |
| 59 | subroutine fortsh_buffer_clear_c(buf) bind(C, name='fortsh_buffer_clear') |
| 60 | import :: c_ptr |
| 61 | type(c_ptr), value :: buf |
| 62 | end subroutine |
| 63 | |
| 64 | function fortsh_buffer_length_c(buf) bind(C, name='fortsh_buffer_length') |
| 65 | import :: c_ptr, c_size_t |
| 66 | type(c_ptr), value :: buf |
| 67 | integer(c_size_t) :: fortsh_buffer_length_c |
| 68 | end function |
| 69 | |
| 70 | function fortsh_buffer_capacity_c(buf) bind(C, name='fortsh_buffer_capacity') |
| 71 | import :: c_ptr, c_size_t |
| 72 | type(c_ptr), value :: buf |
| 73 | integer(c_size_t) :: fortsh_buffer_capacity_c |
| 74 | end function |
| 75 | |
| 76 | ! String operations |
| 77 | function fortsh_buffer_set_c(buf, str) bind(C, name='fortsh_buffer_set') |
| 78 | import :: c_ptr, c_int, c_char |
| 79 | type(c_ptr), value :: buf |
| 80 | character(kind=c_char), dimension(*) :: str |
| 81 | integer(c_int) :: fortsh_buffer_set_c |
| 82 | end function |
| 83 | |
| 84 | function fortsh_buffer_copy_c(dest, src) bind(C, name='fortsh_buffer_copy') |
| 85 | import :: c_ptr, c_int |
| 86 | type(c_ptr), value :: dest, src |
| 87 | integer(c_int) :: fortsh_buffer_copy_c |
| 88 | end function |
| 89 | |
| 90 | function fortsh_buffer_substring_c(dest, src, start, end) bind(C, name='fortsh_buffer_substring') |
| 91 | import :: c_ptr, c_int, c_size_t |
| 92 | type(c_ptr), value :: dest, src |
| 93 | integer(c_size_t), value :: start, end |
| 94 | integer(c_int) :: fortsh_buffer_substring_c |
| 95 | end function |
| 96 | |
| 97 | function fortsh_buffer_get_char_c(buf, pos) bind(C, name='fortsh_buffer_get_char') |
| 98 | import :: c_ptr, c_size_t, c_char |
| 99 | type(c_ptr), value :: buf |
| 100 | integer(c_size_t), value :: pos |
| 101 | character(kind=c_char) :: fortsh_buffer_get_char_c |
| 102 | end function |
| 103 | |
| 104 | function fortsh_buffer_set_char_c(buf, pos, ch) bind(C, name='fortsh_buffer_set_char') |
| 105 | import :: c_ptr, c_int, c_size_t, c_char |
| 106 | type(c_ptr), value :: buf |
| 107 | integer(c_size_t), value :: pos |
| 108 | character(kind=c_char), value :: ch |
| 109 | integer(c_int) :: fortsh_buffer_set_char_c |
| 110 | end function |
| 111 | |
| 112 | ! Buffer manipulation |
| 113 | function fortsh_buffer_insert_c(buf, pos, str) bind(C, name='fortsh_buffer_insert') |
| 114 | import :: c_ptr, c_int, c_size_t, c_char |
| 115 | type(c_ptr), value :: buf |
| 116 | integer(c_size_t), value :: pos |
| 117 | character(kind=c_char), dimension(*) :: str |
| 118 | integer(c_int) :: fortsh_buffer_insert_c |
| 119 | end function |
| 120 | |
| 121 | function fortsh_buffer_delete_c(buf, start, count) bind(C, name='fortsh_buffer_delete') |
| 122 | import :: c_ptr, c_int, c_size_t |
| 123 | type(c_ptr), value :: buf |
| 124 | integer(c_size_t), value :: start, count |
| 125 | integer(c_int) :: fortsh_buffer_delete_c |
| 126 | end function |
| 127 | |
| 128 | function fortsh_buffer_append_c(buf, str) bind(C, name='fortsh_buffer_append') |
| 129 | import :: c_ptr, c_int, c_char |
| 130 | type(c_ptr), value :: buf |
| 131 | character(kind=c_char), dimension(*) :: str |
| 132 | integer(c_int) :: fortsh_buffer_append_c |
| 133 | end function |
| 134 | |
| 135 | subroutine fortsh_buffer_trim_c(buf) bind(C, name='fortsh_buffer_trim') |
| 136 | import :: c_ptr |
| 137 | type(c_ptr), value :: buf |
| 138 | end subroutine |
| 139 | |
| 140 | ! Fortran interop |
| 141 | function fortsh_buffer_to_fortran_c(buf, fortran_str, fortran_len) & |
| 142 | bind(C, name='fortsh_buffer_to_fortran') |
| 143 | import :: c_ptr, c_size_t, c_char |
| 144 | type(c_ptr), value :: buf |
| 145 | character(kind=c_char), dimension(*) :: fortran_str |
| 146 | integer(c_size_t), value :: fortran_len |
| 147 | integer(c_size_t) :: fortsh_buffer_to_fortran_c |
| 148 | end function |
| 149 | |
| 150 | function fortsh_buffer_from_fortran_c(buf, fortran_str, fortran_len) & |
| 151 | bind(C, name='fortsh_buffer_from_fortran') |
| 152 | import :: c_ptr, c_int, c_size_t, c_char |
| 153 | type(c_ptr), value :: buf |
| 154 | character(kind=c_char), dimension(*) :: fortran_str |
| 155 | integer(c_size_t), value :: fortran_len |
| 156 | integer(c_int) :: fortsh_buffer_from_fortran_c |
| 157 | end function |
| 158 | |
| 159 | function fortsh_buffer_c_str_c(buf) bind(C, name='fortsh_buffer_c_str') |
| 160 | import :: c_ptr |
| 161 | type(c_ptr), value :: buf |
| 162 | type(c_ptr) :: fortsh_buffer_c_str_c |
| 163 | end function |
| 164 | |
| 165 | ! Utility |
| 166 | function fortsh_buffer_find_c(buf, pattern) bind(C, name='fortsh_buffer_find') |
| 167 | import :: c_ptr, c_int, c_char |
| 168 | type(c_ptr), value :: buf |
| 169 | character(kind=c_char), dimension(*) :: pattern |
| 170 | integer(c_int) :: fortsh_buffer_find_c |
| 171 | end function |
| 172 | |
| 173 | function fortsh_buffer_compare_c(buf, str) bind(C, name='fortsh_buffer_compare') |
| 174 | import :: c_ptr, c_int, c_char |
| 175 | type(c_ptr), value :: buf |
| 176 | character(kind=c_char), dimension(*) :: str |
| 177 | integer(c_int) :: fortsh_buffer_compare_c |
| 178 | end function |
| 179 | |
| 180 | end interface |
| 181 | |
| 182 | contains |
| 183 | |
| 184 | !----------------------------------------------------------------------------- |
| 185 | ! Fortran-friendly wrappers |
| 186 | !----------------------------------------------------------------------------- |
| 187 | |
| 188 | function c_string_create(capacity) result(buf) |
| 189 | integer, intent(in) :: capacity |
| 190 | type(c_string_buffer) :: buf |
| 191 | |
| 192 | buf%handle = fortsh_buffer_create_c(int(capacity, c_size_t)) |
| 193 | end function c_string_create |
| 194 | |
| 195 | subroutine c_string_destroy(buf) |
| 196 | type(c_string_buffer), intent(inout) :: buf |
| 197 | |
| 198 | if (c_associated(buf%handle)) then |
| 199 | call fortsh_buffer_destroy_c(buf%handle) |
| 200 | buf%handle = c_null_ptr |
| 201 | end if |
| 202 | end subroutine c_string_destroy |
| 203 | |
| 204 | subroutine c_string_clear(buf) |
| 205 | type(c_string_buffer), intent(in) :: buf |
| 206 | |
| 207 | if (c_associated(buf%handle)) then |
| 208 | call fortsh_buffer_clear_c(buf%handle) |
| 209 | end if |
| 210 | end subroutine c_string_clear |
| 211 | |
| 212 | function c_string_length(buf) result(len) |
| 213 | type(c_string_buffer), intent(in) :: buf |
| 214 | integer :: len |
| 215 | |
| 216 | if (c_associated(buf%handle)) then |
| 217 | len = int(fortsh_buffer_length_c(buf%handle)) |
| 218 | else |
| 219 | len = 0 |
| 220 | end if |
| 221 | end function c_string_length |
| 222 | |
| 223 | function c_string_capacity(buf) result(cap) |
| 224 | type(c_string_buffer), intent(in) :: buf |
| 225 | integer :: cap |
| 226 | |
| 227 | if (c_associated(buf%handle)) then |
| 228 | cap = int(fortsh_buffer_capacity_c(buf%handle)) |
| 229 | else |
| 230 | cap = 0 |
| 231 | end if |
| 232 | end function c_string_capacity |
| 233 | |
| 234 | function c_string_set(buf, str) result(status) |
| 235 | type(c_string_buffer), intent(in) :: buf |
| 236 | character(len=*), intent(in) :: str |
| 237 | logical :: status |
| 238 | integer(c_int) :: ret |
| 239 | |
| 240 | if (.not. c_associated(buf%handle)) then |
| 241 | status = .false. |
| 242 | return |
| 243 | end if |
| 244 | |
| 245 | ! Convert to null-terminated C string |
| 246 | ret = fortsh_buffer_set_c(buf%handle, trim(str) // c_null_char) |
| 247 | status = (ret == 0) |
| 248 | end function c_string_set |
| 249 | |
| 250 | function c_string_copy(dest, src) result(status) |
| 251 | type(c_string_buffer), intent(in) :: dest, src |
| 252 | logical :: status |
| 253 | integer(c_int) :: ret |
| 254 | |
| 255 | if (.not. c_associated(dest%handle) .or. .not. c_associated(src%handle)) then |
| 256 | status = .false. |
| 257 | return |
| 258 | end if |
| 259 | |
| 260 | ret = fortsh_buffer_copy_c(dest%handle, src%handle) |
| 261 | status = (ret == 0) |
| 262 | end function c_string_copy |
| 263 | |
| 264 | function c_string_substring(dest, src, start_pos, end_pos) result(status) |
| 265 | type(c_string_buffer), intent(in) :: dest, src |
| 266 | integer, intent(in) :: start_pos, end_pos |
| 267 | logical :: status |
| 268 | integer(c_int) :: ret |
| 269 | |
| 270 | if (.not. c_associated(dest%handle) .or. .not. c_associated(src%handle)) then |
| 271 | status = .false. |
| 272 | return |
| 273 | end if |
| 274 | |
| 275 | ! Convert from Fortran 1-based to C 0-based indexing |
| 276 | ret = fortsh_buffer_substring_c(dest%handle, src%handle, & |
| 277 | int(start_pos - 1, c_size_t), & |
| 278 | int(end_pos - 1, c_size_t)) |
| 279 | status = (ret == 0) |
| 280 | end function c_string_substring |
| 281 | |
| 282 | function c_string_get_char(buf, pos) result(ch) |
| 283 | type(c_string_buffer), intent(in) :: buf |
| 284 | integer, intent(in) :: pos |
| 285 | character(len=1) :: ch |
| 286 | |
| 287 | if (.not. c_associated(buf%handle)) then |
| 288 | ch = ' ' |
| 289 | return |
| 290 | end if |
| 291 | |
| 292 | ! Convert from Fortran 1-based to C 0-based indexing |
| 293 | ch = fortsh_buffer_get_char_c(buf%handle, int(pos - 1, c_size_t)) |
| 294 | end function c_string_get_char |
| 295 | |
| 296 | function c_string_set_char(buf, pos, ch) result(status) |
| 297 | type(c_string_buffer), intent(in) :: buf |
| 298 | integer, intent(in) :: pos |
| 299 | character(len=1), intent(in) :: ch |
| 300 | logical :: status |
| 301 | integer(c_int) :: ret |
| 302 | character(kind=c_char) :: c_ch |
| 303 | |
| 304 | if (.not. c_associated(buf%handle)) then |
| 305 | status = .false. |
| 306 | return |
| 307 | end if |
| 308 | |
| 309 | ! Explicitly convert to c_char for proper C interop |
| 310 | c_ch = ch |
| 311 | |
| 312 | ! Convert from Fortran 1-based to C 0-based indexing |
| 313 | ret = fortsh_buffer_set_char_c(buf%handle, int(pos - 1, c_size_t), c_ch) |
| 314 | status = (ret == 0) |
| 315 | end function c_string_set_char |
| 316 | |
| 317 | function c_string_insert(buf, pos, str) result(status) |
| 318 | type(c_string_buffer), intent(in) :: buf |
| 319 | integer, intent(in) :: pos |
| 320 | character(len=*), intent(in) :: str |
| 321 | logical :: status |
| 322 | integer(c_int) :: ret |
| 323 | |
| 324 | if (.not. c_associated(buf%handle)) then |
| 325 | status = .false. |
| 326 | return |
| 327 | end if |
| 328 | |
| 329 | ! Convert from Fortran 1-based to C 0-based indexing |
| 330 | ! Don't trim - preserve exact string content including trailing spaces |
| 331 | ret = fortsh_buffer_insert_c(buf%handle, int(pos - 1, c_size_t), & |
| 332 | str // c_null_char) |
| 333 | status = (ret == 0) |
| 334 | end function c_string_insert |
| 335 | |
| 336 | function c_string_delete(buf, start_pos, count) result(status) |
| 337 | type(c_string_buffer), intent(in) :: buf |
| 338 | integer, intent(in) :: start_pos, count |
| 339 | logical :: status |
| 340 | integer(c_int) :: ret |
| 341 | |
| 342 | if (.not. c_associated(buf%handle)) then |
| 343 | status = .false. |
| 344 | return |
| 345 | end if |
| 346 | |
| 347 | ! Convert from Fortran 1-based to C 0-based indexing |
| 348 | ret = fortsh_buffer_delete_c(buf%handle, int(start_pos - 1, c_size_t), & |
| 349 | int(count, c_size_t)) |
| 350 | status = (ret == 0) |
| 351 | end function c_string_delete |
| 352 | |
| 353 | function c_string_append(buf, str) result(status) |
| 354 | type(c_string_buffer), intent(in) :: buf |
| 355 | character(len=*), intent(in) :: str |
| 356 | logical :: status |
| 357 | integer(c_int) :: ret |
| 358 | |
| 359 | if (.not. c_associated(buf%handle)) then |
| 360 | status = .false. |
| 361 | return |
| 362 | end if |
| 363 | |
| 364 | ret = fortsh_buffer_append_c(buf%handle, trim(str) // c_null_char) |
| 365 | status = (ret == 0) |
| 366 | end function c_string_append |
| 367 | |
| 368 | subroutine c_string_trim(buf) |
| 369 | type(c_string_buffer), intent(in) :: buf |
| 370 | |
| 371 | if (c_associated(buf%handle)) then |
| 372 | call fortsh_buffer_trim_c(buf%handle) |
| 373 | end if |
| 374 | end subroutine c_string_trim |
| 375 | |
| 376 | subroutine c_string_to_fortran(buf, fortran_str, actual_len) |
| 377 | type(c_string_buffer), intent(in) :: buf |
| 378 | character(len=*), intent(out) :: fortran_str |
| 379 | integer, intent(out), optional :: actual_len |
| 380 | integer(c_size_t) :: len_copied |
| 381 | |
| 382 | fortran_str = '' ! Initialize |
| 383 | |
| 384 | if (.not. c_associated(buf%handle)) then |
| 385 | if (present(actual_len)) actual_len = 0 |
| 386 | return |
| 387 | end if |
| 388 | |
| 389 | len_copied = fortsh_buffer_to_fortran_c(buf%handle, fortran_str, & |
| 390 | int(len(fortran_str), c_size_t)) |
| 391 | |
| 392 | if (present(actual_len)) actual_len = int(len_copied) |
| 393 | end subroutine c_string_to_fortran |
| 394 | |
| 395 | function c_string_from_fortran(buf, fortran_str) result(status) |
| 396 | type(c_string_buffer), intent(in) :: buf |
| 397 | character(len=*), intent(in) :: fortran_str |
| 398 | logical :: status |
| 399 | integer(c_int) :: ret |
| 400 | integer :: actual_len |
| 401 | |
| 402 | if (.not. c_associated(buf%handle)) then |
| 403 | status = .false. |
| 404 | return |
| 405 | end if |
| 406 | |
| 407 | ! Find actual length (trim trailing spaces manually to get exact length) |
| 408 | actual_len = len_trim(fortran_str) |
| 409 | |
| 410 | ret = fortsh_buffer_from_fortran_c(buf%handle, fortran_str, & |
| 411 | int(actual_len, c_size_t)) |
| 412 | status = (ret == 0) |
| 413 | end function c_string_from_fortran |
| 414 | |
| 415 | function c_string_find(buf, pattern) result(pos) |
| 416 | type(c_string_buffer), intent(in) :: buf |
| 417 | character(len=*), intent(in) :: pattern |
| 418 | integer :: pos |
| 419 | |
| 420 | if (.not. c_associated(buf%handle)) then |
| 421 | pos = 0 ! Not found (Fortran 1-based convention) |
| 422 | return |
| 423 | end if |
| 424 | |
| 425 | pos = int(fortsh_buffer_find_c(buf%handle, trim(pattern) // c_null_char)) |
| 426 | |
| 427 | ! Convert from C 0-based to Fortran 1-based, with -1 meaning not found |
| 428 | if (pos >= 0) then |
| 429 | pos = pos + 1 ! Convert to 1-based |
| 430 | else |
| 431 | pos = 0 ! Fortran convention for not found |
| 432 | end if |
| 433 | end function c_string_find |
| 434 | |
| 435 | function c_string_compare(buf, str) result(cmp) |
| 436 | type(c_string_buffer), intent(in) :: buf |
| 437 | character(len=*), intent(in) :: str |
| 438 | integer :: cmp |
| 439 | |
| 440 | if (.not. c_associated(buf%handle)) then |
| 441 | cmp = -1 |
| 442 | return |
| 443 | end if |
| 444 | |
| 445 | cmp = int(fortsh_buffer_compare_c(buf%handle, trim(str) // c_null_char)) |
| 446 | end function c_string_compare |
| 447 | |
| 448 | function c_string_c_str(buf) result(ptr) |
| 449 | type(c_string_buffer), intent(in) :: buf |
| 450 | type(c_ptr) :: ptr |
| 451 | |
| 452 | if (c_associated(buf%handle)) then |
| 453 | ptr = fortsh_buffer_c_str_c(buf%handle) |
| 454 | else |
| 455 | ptr = c_null_ptr |
| 456 | end if |
| 457 | end function c_string_c_str |
| 458 | |
| 459 | end module fortsh_c_strings |
| 460 |