| !> |
| !! Definition of a string class for Fortran. |
| !! |
| !! Jeff Overbey (1/29/09) |
| !< |
| module string_module |
| implicit none |
| private |
| |
| public :: new_string |
| |
| interface new_string |
| module procedure & |
| new_string_string, & |
| new_string_integer, & |
| new_string_logical |
| end interface |
| |
| type, public :: string |
| private |
| character, dimension(:), allocatable :: data |
| integer :: length = 0 |
| contains |
| procedure :: initialize |
| generic :: operator(+) => concat1, concat2 |
| generic :: concat => concat1, concat2 ! Photran doesn't parse - R1207 |
| procedure :: substring |
| procedure :: char_at |
| procedure :: map |
| procedure :: to_uppercase |
| procedure :: to_lowercase |
| generic :: write(formatted) => write_formatted ! Photran doesn't parse |
| generic :: write(unformatted) => write_unformatted |
| procedure :: value |
| generic :: operator(==) => equals |
| generic :: operator(.eqic.) => equals_ignore_case |
| final :: destructor |
| |
| procedure, private :: concat1 |
| procedure, private :: concat2 |
| procedure, private :: write_formatted |
| procedure, private :: write_unformatted |
| procedure, private :: all_satisfy |
| procedure, private :: equals |
| procedure, private :: equals_ignore_case |
| end type string |
| |
| contains |
| |
| type(string) function new_string_string(string) result(return) |
| character(len=*), intent(in) :: string |
| call return%initialize(string) |
| end function |
| |
| type(string) function new_string_integer(integer) result(return) |
| integer, intent(in) :: integer |
| return = new_string_nat(abs(integer)) |
| if (integer < 0) return = new_string("-") + return |
| end function |
| |
| type(string) function new_string_logical(logical) result(return) |
| logical, intent(in) :: logical |
| if (logical) then |
| return = new_string('.true.') |
| else |
| return = new_string('.false.') |
| end if |
| end function |
| |
| type(string) recursive function new_string_nat(absval) result(return) |
| integer, intent(in) :: absval |
| |
| if (0 <= absval .and. absval <= 9) then |
| call return%initialize(digit_string(absval)) |
| else |
| return = new_string_nat(absval / 10) + digit_string(mod(absval, 10)) |
| end if |
| end function |
| |
| character(len=1) function digit_string(digit) |
| integer, intent(in) :: digit |
| select case (digit) |
| case (0); digit_string = '0' |
| case (1); digit_string = '1' |
| case (2); digit_string = '2' |
| case (3); digit_string = '3' |
| case (4); digit_string = '4' |
| case (5); digit_string = '5' |
| case (6); digit_string = '6' |
| case (7); digit_string = '7' |
| case (8); digit_string = '8' |
| case (9); digit_string = '9' |
| end select |
| end function |
| |
| subroutine initialize(self, data) |
| class(string), intent(inout) :: self |
| character(len=*), intent(in) :: data |
| integer :: i |
| |
| self%length = len(data) |
| allocate(self%data(self%length)) |
| do i = 1, len(data) |
| self%data(i) = data(i:i) |
| end do |
| end subroutine |
| |
| ! XLF parses class(string) but gives semantic error; Photran doesn't parse |
| type(string) function concat1(self, other) result(return) |
| class(string), intent(in) :: self |
| class(string), intent(in) :: other |
| |
| return = concat2(self, other%value()) |
| end function |
| |
| type(string) function concat2(self, other) result(return) |
| class(string), intent(in) :: self |
| character(len=*), intent(in) :: other |
| integer :: i |
| |
| return%length = self%length + len(other) |
| allocate(return%data(return%length)) |
| return%data(1:self%length) = self%data |
| do i = 1, len(other); return%data(i + self%length) = other(i:i); end do |
| end function |
| |
| type(string) function substring(self, start, thru) result(return) |
| class(string), intent(in) :: self |
| integer, intent(in) :: start, thru |
| |
| if (thru < start) return |
| |
| return%length = thru - start + 1 |
| allocate(return%data(return%length)) |
| return%data(1:self%length) = self%data(start:thru) |
| end function |
| |
| character(len=1) function char_at(self, index) result(return) |
| class(string), intent(in) :: self |
| integer, intent(in) :: index |
| return = self%data(index) |
| end function |
| |
| type(string) function map(self, function) result(return) |
| class(string), intent(in) :: self |
| interface |
| character(len=1) function function(string) |
| character(len=1), intent(in) :: string |
| end function |
| end interface |
| integer :: i |
| |
| return%length = self%length |
| allocate(return%data(return%length)) |
| do i = 1, self%length |
| return%data(i) = function(self%data(i)) |
| end do |
| end function |
| |
| type(string) function to_uppercase(self) result(return) |
| class(string), intent(in) :: self |
| return = self%map(to_upper) |
| !contains ! Causes XLF compiler bug -- see xlf-bug.f03 |
| end function |
| character(len=1) function to_upper(ch) result(return) |
| character(len=1), intent(in) :: ch |
| integer, parameter :: diff = iachar('a') - iachar('A') |
| |
| if (lle('a', ch) .and. lle(ch, 'z')) then |
| return = achar(iachar(ch) - diff) |
| else |
| return = ch |
| end if |
| end function |
| !end function |
| |
| type(string) function to_lowercase(self) result(return) |
| class(string), intent(in) :: self |
| return = self%map(to_lower) |
| !contains ! Causes XLF compiler bug -- see xlf-bug.f03 |
| end function |
| character(len=1) function to_lower(ch) result(return) |
| character(len=1), intent(in) :: ch |
| integer, parameter :: diff = iachar('a') - iachar('A') |
| |
| if (lle('A', ch) .and. lle(ch, 'Z')) then |
| return = achar(iachar(ch) + diff) |
| else |
| return = ch |
| end if |
| end function |
| !end function |
| |
| subroutine write_formatted(self, unit, iotype, v_list, iostat, iomsg) |
| class(string), intent(in) :: self |
| integer, intent(in) :: unit |
| character(*), intent(in) :: iotype |
| integer, dimension(:), intent(in) :: v_list |
| integer, intent(out) :: iostat |
| character(*), intent(inout) :: iomsg |
| ! TODO Incomplete |
| write (unit=unit, fmt=*, iostat=iostat, iomsg=iomsg) self%value() |
| end subroutine |
| |
| subroutine write_unformatted(self, unit, iostat, iomsg) |
| class(string), intent(in) :: self |
| integer, intent(in) :: unit |
| integer, intent(out) :: iostat |
| character(*), intent(inout) :: iomsg |
| ! TODO Incomplete |
| write (unit=unit, fmt=*, iostat=iostat, iomsg=iomsg) self%value() |
| end subroutine |
| |
| character(len=self%length) function value(self) result(result) |
| class(string), intent(in) :: self |
| integer :: i |
| |
| do i = 1, ubound(self%data, 1) |
| result(i:i) = self%data(i) |
| end do |
| end function |
| |
| logical function all_satisfy(self, function, other) result(return) |
| class(string), intent(in) :: self |
| interface |
| logical function function(ch1, ch2) |
| character(len=1), intent(in) :: ch1, ch2 |
| end function |
| end interface |
| class(string), intent(in) :: other |
| integer :: i |
| |
| if (self%length <> other%length) then |
| return = .false. |
| else |
| return = .true. |
| do i = 1, self%length |
| if (function(self%data(i), other%data(i)) .eqv. .false.) then |
| return = .false. |
| return |
| end if |
| end do |
| end if |
| end function |
| |
| logical function equals(self, other) result(return) |
| class(string), intent(in) :: self |
| class(string), intent(in) :: other |
| return = self%all_satisfy(ch_eq, other) |
| end function |
| |
| logical function ch_eq(ch1, ch2) result(return) |
| character(len=1), intent(in) :: ch1, ch2 |
| return = ch1 .eq. ch2 |
| end function |
| |
| logical function equals_ignore_case(self, other) result(return) |
| class(string), intent(in) :: self |
| class(string), intent(in) :: other |
| return = self%all_satisfy(ch_eqic, other) |
| end function |
| |
| logical function ch_eqic(ch1, ch2) result(return) |
| character(len=1), intent(in) :: ch1, ch2 |
| return = to_upper(ch1) .eq. to_upper(ch2) |
| end function |
| |
| subroutine destructor(self) |
| type(string), intent(inout) :: self |
| end subroutine |
| |
| end module string_module |
| |
| module test_util |
| implicit none |
| contains |
| character(len=1) function identity(string) result(return) |
| character(len=1), intent(in) :: string |
| return = string |
| end function |
| |
| character(len=1) function always_a(string) result(return) |
| character(len=1), intent(in) :: string |
| return = 'a' |
| end function |
| end module test_util |
| |
| program string_test |
| use string_module |
| use test_util |
| implicit none |
| |
| type(string) :: s1, s2 |
| |
| print *, "Expected: " |
| print *, "Actual: ", s1%value() |
| |
| call s1%initialize('Hello') |
| call s2%initialize('!') |
| |
| print *, "Expected: Hello" |
| print *, "Actual: ", s1%value() |
| |
| s1 = new_string("HeLlOoO!") |
| print *, "Expected: HeLlOoO!" |
| print *, "Actual: ", s1%value() |
| s1 = new_string("Hello") |
| |
| s1 = s1%concat(', world') |
| print *, "Expected: Hello, world" |
| print *, "Actual: ", s1%value() |
| |
| s1 = s1%concat(s2) |
| print *, "Expected: Hello, world!" |
| print *, "Actual: ", s1%value() |
| |
| s1 = s1 + '!' |
| !print *, (s1 + '!')%value() |
| print *, "Expected: Hello, world!!" |
| print *, "Actual: ", s1%value() |
| |
| print *, "Expected: -9876x" |
| print *, "Actual: ", new_string("-") + new_string("9876x") |
| |
| print *, "Expected: ell" |
| print *, "Actual: ", "Hello, world!!"(2:4) |
| print *, "Expected: ell" |
| print *, "Actual: ", s1%substring(2, 4) |
| |
| print *, "Expected: He" |
| print *, "Actual: ", s1%substring(0, 2) |
| |
| print *, "Expected: " |
| print *, "Actual: ", "Hello, world!!"(5:1) |
| print *, "Expected: " |
| print *, "Actual: ", s1%substring(5, 1) |
| |
| print *, "Expected: e" |
| print *, "Actual: ", s1%char_at(2) |
| |
| print *, "Expected: ", "Hello, world!!" |
| print *, "Actual: ", s1%map(identity) |
| |
| print *, "Expected: ", "aaaaaaaaaaaaaa" |
| print *, "Actual: ", s1%map(always_a) |
| |
| print *, "Expected: HELLO, WORLD!!" |
| print *, "Actual: ", s1%to_uppercase() |
| |
| print *, "Expected: hello, world!!" |
| print *, "Actual: ", s1%to_lowercase() |
| |
| print *, "Expected: Hello, world!!" |
| print *, "Actual: ", s1 |
| |
| print *, "Expected: 0" |
| print *, "Actual: ", new_string(0) |
| |
| print *, "Expected: 5" |
| print *, "Actual: ", new_string(5) |
| |
| print *, "Expected: 12345" |
| print *, "Actual: ", new_string(12345) |
| |
| print *, "Expected: -8" |
| print *, "Actual: ", new_string(-8) |
| |
| print *, "Expected: -98765" |
| print *, "Actual: ", new_string(-98765) |
| |
| print *, "Expected: .true." |
| print *, "Actual: ", new_string(.true.) |
| |
| print *, "Expected: .false." |
| print *, "Actual: ", new_string(.false.) |
| |
| print *, "Expected: T" |
| print *, "Actual: ", new_string(.false.) == new_string(".false.") |
| |
| print *, "Expected: T" |
| print *, "Actual: ", new_string("") == new_string("") |
| |
| print *, "Expected: F" |
| print *, "Actual: ", new_string("") == new_string("true") |
| |
| print *, "Expected: F" |
| print *, "Actual: ", new_string("true") == new_string("") |
| |
| print *, "Expected: F" |
| print *, "Actual: ", new_string("true") == new_string("truE") |
| |
| print *, "Expected: T" |
| print *, "Actual: ", new_string(.false.) .eqic. new_string(".false.") |
| |
| print *, "Expected: T" |
| print *, "Actual: ", new_string("") .eqic. new_string("") |
| |
| print *, "Expected: F" |
| print *, "Actual: ", new_string("") .eqic. new_string("true") |
| |
| print *, "Expected: F" |
| print *, "Actual: ", new_string("true") .eqic. new_string("") |
| |
| print *, "Expected: T" |
| print *, "Actual: ", new_string("true") .eqic. new_string("truE") |
| |
| print *, "Expected: T" |
| print *, "Actual: ", new_string("tRUe") .eqic. new_string("TrUe") |
| |
| print *, "Done" |
| end program string_test |
