String.F90 Source File

! Primary purpose is to wrap allocatable strings and thereby
! improve usability of such strings in generic interfaces.

#include "unused_dummy.H"
module MAPL_String
   implicit none
   private

   public :: String

   type :: String
      private
      character(:), allocatable :: string
   contains
      ! ASSIGNMENT(=)
      procedure :: assign_string_from_string
      procedure :: assign_string_from_char
      procedure, pass(from) :: assign_char_from_string
      generic :: assignment(=) => assign_string_from_string
      generic :: assignment(=) => assign_string_from_char
      generic :: assignment(=) => assign_char_from_string

      ! OPERATOR(==)
      procedure :: string_is_equal_to_string
      procedure :: string_is_equal_to_char
      procedure, pass(this) :: char_is_equal_to_string
      generic :: operator(==) => string_is_equal_to_string
      generic :: operator(==) => string_is_equal_to_char
      generic :: operator(==) => char_is_equal_to_string

      ! OPERATOR(<)
      procedure :: string_is_less_than_string
      procedure :: string_is_less_than_char
      procedure, pass(this) :: char_is_less_than_string
      generic :: operator(<) => string_is_less_than_string
      generic :: operator(<) => string_is_less_than_char
      generic :: operator(<) => char_is_less_than_string

      ! OPERATOR(<=)
      procedure :: string_is_less_than_or_equal_to_string
      procedure :: string_is_less_than_or_equal_to_char
      procedure, pass(this) :: char_is_less_than_or_equal_to_string
      generic :: operator(<=) => string_is_less_than_or_equal_to_string
      generic :: operator(<=) => string_is_less_than_or_equal_to_char
      generic :: operator(<=) => char_is_less_than_or_equal_to_string

      ! OPERATOR(>)
      procedure :: string_is_greater_than_string
      procedure :: string_is_greater_than_char
      procedure, pass(this) :: char_is_greater_than_string
      generic :: operator(>) => string_is_greater_than_string
      generic :: operator(>) => string_is_greater_than_char
      generic :: operator(>) => char_is_greater_than_string

      ! OPERATOR(>=)
      procedure :: string_is_greater_than_or_equal_to_string
      procedure :: string_is_greater_than_or_equal_to_char
      procedure, pass(this) :: char_is_greater_than_or_equal_to_string
      generic :: operator(>=) => string_is_greater_than_or_equal_to_string
      generic :: operator(>=) => string_is_greater_than_or_equal_to_char
      generic :: operator(>=) => char_is_greater_than_or_equal_to_string

      ! OPERATOR(/=)
      procedure :: string_is_not_equal_to_string
      procedure :: string_is_not_equal_to_char
      procedure, pass(this) :: char_is_not_equal_to_string
      generic :: operator(/=) => string_is_not_equal_to_string
      generic :: operator(/=) => string_is_not_equal_to_char
      generic :: operator(/=) => char_is_not_equal_to_string

      ! OPERATOR(//)
      procedure :: concatenate_string_string
      procedure :: concatenate_string_char
      procedure, pass(this) :: concatenate_char_string
      generic :: operator(//) => concatenate_string_string
      generic :: operator(//) => concatenate_string_char
      generic :: operator(//) => concatenate_char_string

      ! WRITE(FORMATTED)
      procedure :: write_formatted
      generic :: write(formatted) => write_formatted

      ! INTRINSICS
      procedure :: len => len_string
      procedure :: len_trim => len_trim_string

      procedure :: index_string
      procedure :: index_char
      generic :: index => index_string
      generic :: index => index_char

      procedure :: scan_string
      procedure :: scan_char
      generic :: scan => scan_string
      generic :: scan => scan_char

      procedure :: verify_string
      procedure :: verify_char
      generic :: verify => verify_string
      generic :: verify => verify_char

      ! Supplemental
      procedure :: get => get_fixed_length_string
      procedure :: is_allocated
      procedure :: lower
      procedure :: upper
      procedure :: capitalize

   end type String

   interface String
      module procedure new_String
   end interface String

contains

   function new_String(s) result(str)
      type(String) :: str
      character(*), intent(in) :: s
      str%string = s
   end function new_String


   subroutine assign_string_from_string(to, from)
      class(String), intent(out) :: to
      class(String), intent(in) :: from
      to%string = from%string
   end subroutine assign_string_from_string

   subroutine assign_string_from_char(to, from)
      class(String), intent(out) :: to
      character(*), intent(in) :: from
      to%string = from
   end subroutine assign_string_from_char

   subroutine assign_char_from_string(to, from)
      character(:), allocatable, intent(out) :: to
      class(String), intent(in) :: from
      to = from%string
   end subroutine assign_char_from_string



   logical function string_is_equal_to_string(this, rhs) result(are_equal)
      class(String), intent(in) :: this
      class(String), intent(in) :: rhs
      are_equal = (this%string == rhs%string)
   end function string_is_equal_to_string

   logical function string_is_equal_to_char(this, rhs) result(are_equal)
      class(String), intent(in) :: this
      character(*), intent(in) :: rhs
      are_equal = (this%string == rhs)
   end function string_is_equal_to_char
   
   logical function char_is_equal_to_string(lhs, this) result(are_equal)
      character(*), intent(in) :: lhs
      class(String), intent(in) :: this
      are_equal = (lhs == this%string)
   end function char_is_equal_to_string
   

   logical function string_is_less_than_string(this, rhs) result(is_less_than)
      class(String), intent(in) :: this
      class(String), intent(in) :: rhs
      is_less_than = (this%string < rhs%string)
   end function string_is_less_than_string

   logical function string_is_less_than_char(this, rhs) result(is_less_than)
      class(String), intent(in) :: this
      character(*), intent(in) :: rhs
      is_less_than = (this%string < rhs)
   end function string_is_less_than_char
   
   logical function char_is_less_than_string(lhs, this) result(is_less_than)
      character(*), intent(in) :: lhs
      class(String), intent(in) :: this
      is_less_than = (lhs < this%string)
   end function char_is_less_than_string
   

   logical function string_is_less_than_or_equal_to_string(this, rhs) result(is_less_than_or_equal)
      class(String), intent(in) :: this
      class(String), intent(in) :: rhs
      is_less_than_or_equal = (this%string <= rhs%string)
   end function string_is_less_than_or_equal_to_string

   logical function string_is_less_than_or_equal_to_char(this, rhs) result(is_less_than_or_equal)
      class(String), intent(in) :: this
      character(*), intent(in) :: rhs
      is_less_than_or_equal = (this%string <= rhs)
   end function string_is_less_than_or_equal_to_char
   
   logical function char_is_less_than_or_equal_to_string(lhs, this) result(is_less_than_or_equal)
      character(*), intent(in) :: lhs
      class(String), intent(in) :: this
      is_less_than_or_equal = (lhs <= this%string)
   end function char_is_less_than_or_equal_to_string
   

   logical function string_is_greater_than_string(this, rhs) result(is_greater_than)
      class(String), intent(in) :: this
      class(String), intent(in) :: rhs
      is_greater_than = (this%string < rhs%string)
   end function string_is_greater_than_string

   logical function string_is_greater_than_char(this, rhs) result(is_greater_than)
      class(String), intent(in) :: this
      character(*), intent(in) :: rhs
      is_greater_than = (this%string < rhs)
   end function string_is_greater_than_char
   
   logical function char_is_greater_than_string(lhs, this) result(is_greater_than)
      character(*), intent(in) :: lhs
      class(String), intent(in) :: this
      is_greater_than = (lhs < this%string)
   end function char_is_greater_than_string
   

   logical function string_is_greater_than_or_equal_to_string(this, rhs) result(is_greater_than_or_equal)
      class(String), intent(in) :: this
      class(String), intent(in) :: rhs
      is_greater_than_or_equal = (this%string <= rhs%string)
   end function string_is_greater_than_or_equal_to_string

   logical function string_is_greater_than_or_equal_to_char(this, rhs) result(is_greater_than_or_equal)
      class(String), intent(in) :: this
      character(*), intent(in) :: rhs
      is_greater_than_or_equal = (this%string <= rhs)
   end function string_is_greater_than_or_equal_to_char
   
   logical function char_is_greater_than_or_equal_to_string(lhs, this) result(is_greater_than_or_equal)
      character(*), intent(in) :: lhs
      class(String), intent(in) :: this
      is_greater_than_or_equal = (lhs <= this%string)
   end function char_is_greater_than_or_equal_to_string
   

   logical function string_is_not_equal_to_string(this, rhs) result(are_not_equal)
      class(String), intent(in) :: this
      class(String), intent(in) :: rhs
      are_not_equal = .not. (this == rhs)
   end function string_is_not_equal_to_string
   
   logical function string_is_not_equal_to_char(this, rhs) result(are_not_equal)
      class(String), intent(in) :: this
      character(*), intent(in) :: rhs
      are_not_equal = .not. (this == rhs)
   end function string_is_not_equal_to_char
   
   logical function char_is_not_equal_to_string(lhs, this) result(are_not_equal)
      character(*), intent(in) :: lhs
      class(String), intent(in) :: this
      are_not_equal = .not. (lhs == this)
   end function char_is_not_equal_to_string
   

   subroutine write_formatted(this, unit, iotype, v_list, iostat, iomsg)
      class(String), intent(in) :: this
      integer, intent(in) :: unit
      character(*), intent(in) :: iotype
      integer, intent(in) :: v_list(:)
      integer, intent(out) :: iostat
      character(*), intent(inout) :: iomsg

      _UNUSED_DUMMY(iotype)
      _UNUSED_DUMMY(v_list)

      write(unit,'(a)') this%string
      iostat = 0
      iomsg=iomsg
   end subroutine write_formatted


   subroutine get_fixed_length_string(this, s)
      class(String), intent(in) :: this
      character(*), intent(out) :: s
      s = this%string
   end subroutine get_fixed_length_string

   logical function is_allocated(this)
      class(String), intent(in) :: this
      is_allocated = allocated(this%string)
   end function is_allocated

   function concatenate_string_string(this, rhs) result(str)
      type(String) :: str
      class(String), intent(in) :: this
      class(String), intent(in) :: rhs
      str = this%string // rhs%string
   end function concatenate_string_string

   function concatenate_string_char(this, rhs) result(str)
      type(String) :: str
      class(String), intent(in) :: this
      character(*), intent(in) :: rhs
      str = this%string // rhs
   end function concatenate_string_char

   function concatenate_char_string(lhs, this) result(str)
      type(String) :: str
      character(*), intent(in) :: lhs
      class(String), intent(in) :: this
      str = lhs //this%string
   end function concatenate_char_string


   integer function len_string(this)
      class(String), intent(in) :: this
      len_string = len(this%string)
   end function len_string


   integer function len_trim_string(this)
      class(String), intent(in) :: this
      len_trim_string = len_trim(this%string)
   end function len_trim_string


   function index_string(this, substring, back) result(idx)
      integer :: idx
      class(String), intent(in) :: this
      class(String), intent(in) :: substring
      logical, optional :: back

      idx = index(this%string, substring%string, back)
   end function index_string

   function index_char(this, substring, back) result(idx)
      integer :: idx
      class(String), intent(in) :: this
      character(*), intent(in) :: substring
      logical, optional :: back

      idx = index(this%string, substring, back)
   end function index_char

   function scan_string(this, set, back) result(idx)
      integer :: idx
      class(String), intent(in) :: this
      class(String), intent(in) :: set
      logical, optional :: back

      idx = scan(this%string, set%string, back)
   end function scan_string

   function scan_char(this, set, back) result(idx)
      integer :: idx
      class(String), intent(in) :: this
      character(*), intent(in) :: set
      logical, optional :: back

      idx = scan(this%string, set, back)
   end function scan_char

   function verify_string(this, set, back) result(idx)
      integer :: idx
      class(String), intent(in) :: this
      class(String), intent(in) :: set
      logical, optional :: back

      idx = verify(this%string, set%string, back)
   end function verify_string

   function verify_char(this, set, back) result(idx)
      integer :: idx
      class(String), intent(in) :: this
      character(*), intent(in) :: set
      logical, optional :: back

      idx = verify(this%string, set, back)
   end function verify_char


   function lower(this)
      type(String) :: lower
      class(String), intent(in) :: this

      integer :: i
      character(1) :: c

      lower = this
      do i = 1, lower%len()
         c = lower%string(i:i)
         if (c >= 'A' .and. c <= 'Z') then
            lower%string(i:i) = achar(iachar(c)+32)
         end if
      end do

   end function lower
   
   function upper(this)
      type(String) :: upper
      class(String), intent(in) :: this

      integer :: i
      character(1) :: c

      upper = this
      do i = 1, upper%len()
         c = upper%string(i:i)
         if (c >= 'a' .and. c <= 'z') then
            upper%string(i:i) = achar(iachar(c)-32)
         end if
      end do

   end function upper
   
   function capitalize(this)
      type(String) :: capitalize
      class(String), intent(in) :: this

      character(1) :: c

      capitalize = this%lower()
      c = capitalize%string(1:1)
      if (c >= 'a' .and. c <= 'z') then
         capitalize%string(1:1) = achar(iachar(c)-32)
      end if

   end function capitalize

   
end module MAPL_String