!== Variable string module for Fortran90
!
! Authors::   Eizi TOYODA
! Version::   $Id: dcstring_base.f90,v 1.2 2005/12/22 03:17:20 morikawa Exp $
! Tag Name::  $Name: gt4f90io-20060121 $
! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved.
! License::   See COPYRIGHT[link:../../COPYRIGHT]
!
!--
! vi: set ts=8 sw=4:
!++

module dcstring_base !:nodoc:
  !
  ! 本モジュールはポインタが使えない環境で 508 字までの
  ! 可変長文字列を保持する構造体を提供する。
  !

  implicit none

  private
  public VSTRING, len, var_str, vchar, get, put, put_line, &
    & assignment(=), operator(==), operator(/=), &
    & operator(<), operator(<=), operator(>), operator(>=), &
    & vindex, vscan, vverify, extract, split, &
    & operator(.cat.)

  integer, public, parameter::                STRING_MAX = 500

  type VSTRING
    ! あえて private にはしない。
    integer::                     len
    character(len = STRING_MAX):: body
  end type VSTRING

  interface len
    module procedure string_len
  end interface

  interface var_str
    module procedure char_to_string
  end interface

  interface vchar
    module procedure string_to_char_length
  end interface

  interface extract
    module procedure extract_string
  end interface

  interface split
    module procedure split_c
    module procedure split_s
  end interface

  interface get
    module procedure string_get
    module procedure string_get_default
  end interface

  interface put
    module procedure string_put
    module procedure string_put_default
    module procedure char_put
    module procedure char_put_default
  end interface

  interface put_line
    module procedure string_put_line
    module procedure string_put_line_default
    module procedure char_put_line
    module procedure char_put_line_default
  end interface

  interface vscan
    module procedure string_scan_string
    module procedure string_scan_char
  end interface

  interface vverify
    module procedure string_verify_string
    module procedure string_verify_char
  end interface

  interface vindex
    module procedure string_index_string
    module procedure string_index_char
    module procedure char_index_string
  end interface

  interface assignment(=)
    module procedure string_let_char
    module procedure string_let_char_array
    module procedure char_let_string
    module procedure char_array_let_string
  end interface

  interface operator(//)
    module procedure string_add_string
    module procedure char_add_string
    module procedure string_add_char
  end interface

  interface operator(.cat.)
    module procedure string_add_string
    module procedure char_add_string
    module procedure string_add_char
  end interface

  interface operator(==)
    module procedure string_eq_string
    module procedure string_eq_char
    module procedure char_eq_string
  end interface

  interface operator(/=)
    module procedure string_ne_string
    module procedure string_ne_char
    module procedure char_ne_string
  end interface

  interface operator(<)
    module procedure string_lt_string
    module procedure string_lt_char
    module procedure char_lt_string
  end interface

  interface operator(<=)
    module procedure string_le_string
    module procedure string_le_char
    module procedure char_le_string
  end interface

  interface operator(>)
    module procedure string_gt_string
    module procedure string_gt_char
    module procedure char_gt_string
  end interface

  interface operator(>=)
    module procedure string_ge_string
    module procedure string_ge_char
    module procedure char_ge_string
  end interface

contains

  !
  ! === 公開手続 ===
  !

  integer function string_len(str) result(result)
    !
    ! 総称 len 関数の実体
    !
    type(VSTRING), intent(in)::        str
  continue
    result = str%len
  end function string_len

  type(VSTRING) function char_to_string(char) result(result)
    !
    ! 総称 var_str 関数の実体
    !
    character(len=*), intent(in)::                char
    interface
      subroutine dcstringbase_warnlim(cause)
        character(len = *), intent(in):: cause
      end subroutine dcstringbase_warnlim
    end interface
  continue
    if (len(char) > STRING_MAX) call dcstringbase_warnlim('cast')
    result%len = min(len(char), STRING_MAX)
    result%body = char
  end function char_to_string

  function string_to_char_length(str, length) result(result)
    !
    ! 総称 vchar 関数の実体
    !
    type(VSTRING), intent(in)::        str
    integer, intent(in)::                        length
    character(len = length)::                result
  continue
    call char_let_string(result, str)
  end function string_to_char_length

  subroutine string_let_char(str, char)
    !
    ! 総称代入文の実体
    !
    type(VSTRING), intent(inout):: str
    character(len=*), intent(in):: char
  continue
    str%len = len(char)
    str%body = char
  end subroutine string_let_char

  subroutine string_let_char_array(str, char)
    type(VSTRING), intent(inout):: str
    character, intent(in):: char(:)
    integer:: i
  continue
    str%len = min(STRING_MAX, size(char))
    do, i = 1, str%len
      str%body(i:i) = char(i)
    enddo
  end subroutine string_let_char_array

  subroutine char_let_string(char, str)
    character(len=*), intent(out):: char
    type(VSTRING), intent(in):: str
  continue
    char = str%body(1: str%len)
  end subroutine char_let_string

  subroutine char_array_let_string(char, str)
    character, intent(out):: char(:)
    type(VSTRING), intent(in):: str
    integer:: i
  continue
    do, i = 1, min(str%len, size(char))
      char(i) = str%body(i:i)
    enddo
    char(str%len + 1: size(char)) = ' '
  end subroutine char_array_let_string

  !
  ! 総称 // 演算子の実体
  !

  type(VSTRING) function string_add_string(lhs, rhs) result(result)
    type(VSTRING), intent(in)::                lhs, rhs
  continue
    result = char_add_char(lhs%body(1: lhs%len), rhs%body(1: rhs%len))
  end function string_add_string

  type(VSTRING) function string_add_char(lhs, rhs) result(result)
    type(VSTRING), intent(in)::                lhs
    character(len = *), intent(in)::                rhs
  continue
    result = char_add_char(lhs%body(1: lhs%len), rhs)
  end function string_add_char

  function char_add_string(char, str) result(result)
    type(VSTRING)::                                result
    character(len=*), intent(in)::                        char
    type(VSTRING), intent(in)::                str
  continue
    result = char_add_char(char, str%body(1: str%len))
  end function char_add_string

  !
  ! 総称演算子 == の実体
  !

  logical function string_eq_string(lhs, rhs) result(result)
    type(VSTRING), intent(in)::        lhs, rhs
  continue
    result = (lhs%body(1: lhs%len) == rhs%body(1: rhs%len))
  end function string_eq_string

  logical function string_eq_char(str, char) result(result)
    type(VSTRING), intent(in)::        str
    character(len=*), intent(in)::                char
  continue
    result = (str%body(1: str%len) == char)
  end function string_eq_char

  logical function char_eq_string(char, str) result(result)
    character(len=*), intent(in)::                char
    type(VSTRING), intent(in)::        str
  continue
    result = (char == str%body(1: str%len))
  end function char_eq_string

  !
  ! 総称演算子 /= の実体
  !

  logical function string_ne_string(lhs, rhs) result(result)
    type(VSTRING), intent(in)::        lhs, rhs
  continue
    result = (lhs%body(1: lhs%len) /= rhs%body(1: rhs%len))
  end function string_ne_string

  logical function string_ne_char(str, char) result(result)
    type(VSTRING), intent(in)::        str
    character(len=*), intent(in)::                char
  continue
    result = (str%body(1: str%len) /= char)
  end function string_ne_char

  logical function char_ne_string(char, str) result(result)
    character(len=*), intent(in)::                char
    type(VSTRING), intent(in)::        str
  continue
    result = (char /= str%body(1: str%len))
  end function char_ne_string

  !
  ! 総称演算子 < の実体
  !

  logical function string_lt_string(lhs, rhs) result(result)
    type(VSTRING), intent(in)::        lhs, rhs
  continue
    result = (lhs%body(1: lhs%len) < rhs%body(1: rhs%len))
  end function string_lt_string

  logical function string_lt_char(str, char) result(result)
    type(VSTRING), intent(in)::        str
    character(len=*), intent(in)::                char
  continue
    result = (str%body(1: str%len) < char)
  end function string_lt_char

  logical function char_lt_string(char, str) result(result)
    character(len=*), intent(in)::                char
    type(VSTRING), intent(in)::        str
  continue
    result = (char < str%body(1: str%len))
  end function char_lt_string

  !
  ! 総称演算子 <= の実体
  !

  logical function string_le_string(lhs, rhs) result(result)
    type(VSTRING), intent(in)::        lhs, rhs
  continue
    result = (lhs%body(1: lhs%len) <= rhs%body(1: rhs%len))
  end function string_le_string

  logical function string_le_char(str, char) result(result)
    type(VSTRING), intent(in)::        str
    character(len=*), intent(in)::                char
  continue
    result = (str%body(1: str%len) <= char)
  end function string_le_char

  logical function char_le_string(char, str) result(result)
    character(len=*), intent(in)::                char
    type(VSTRING), intent(in)::        str
  continue
    result = (char <= str%body(1: str%len))
  end function char_le_string

  !
  ! 総称演算子 > の実体
  !

  logical function string_gt_string(lhs, rhs) result(result)
    type(VSTRING), intent(in)::        lhs, rhs
  continue
    result = (lhs%body(1: lhs%len) > rhs%body(1: rhs%len))
  end function string_gt_string

  logical function string_gt_char(str, char) result(result)
    type(VSTRING), intent(in)::        str
    character(len=*), intent(in)::                char
  continue
    result = (str%body(1: str%len) > char)
  end function string_gt_char

  logical function char_gt_string(char, str) result(result)
    character(len=*), intent(in)::                char
    type(VSTRING), intent(in)::        str
  continue
    result = (char > str%body(1: str%len))
  end function char_gt_string

  !
  ! 総称演算子 >= の実体
  !

  logical function string_ge_string(lhs, rhs) result(result)
    type(VSTRING), intent(in)::        lhs, rhs
  continue
    result = (lhs%body(1: lhs%len) >= rhs%body(1: rhs%len))
  end function string_ge_string

  logical function string_ge_char(str, char) result(result)
    type(VSTRING), intent(in)::        str
    character(len=*), intent(in)::                char
  continue
    result = (str%body(1: str%len) >= char)
  end function string_ge_char

  logical function char_ge_string(char, str) result(result)
    character(len=*), intent(in)::                char
    type(VSTRING), intent(in)::        str
  continue
    result = (char >= str%body(1: str%len))
  end function char_ge_string

  !
  ! 入出力
  !

  subroutine string_get_default(str, maxlen, iostat)
    type(VSTRING), intent(out)::        str
    integer, intent(in), optional::                maxlen
    integer, intent(out), optional::        iostat
  continue
    call string_get(-1, str, maxlen, iostat)
  end subroutine string_get_default

  subroutine string_get(unit, str, maxlen, iostat)
    integer, intent(in)::                        unit
    type(VSTRING), intent(out)::        str
    integer, intent(in), optional::                maxlen
    integer, intent(out), optional::        iostat
    integer::                alreadyread, buflen, nowread, ios, maxsize
    integer, parameter::        BUFFERSIZE = 80
    character(len = BUFFERSIZE)::                buffer
  continue
    if (present(maxlen)) then
      maxsize = min(maxlen, STRING_MAX)
    else
      maxsize = STRING_MAX
    endif
    alreadyread = 0
    str = ''
    do
      if (alreadyread >= maxsize) return
      buflen = min(BUFFERSIZE, maxsize - alreadyread)
      ! SUPER-UX 対策
      buffer = ''                
      ! 読み取り
      if (unit >= 0) then
        read(unit=unit, fmt='(A)', advance='NO', &
          & size=nowread, eor=100, iostat=ios) buffer(1: buflen)
      else
        read(unit=*, fmt='(A)', advance='NO', &
          & size=nowread, eor=100, iostat=ios) buffer(1: buflen)
      endif
      if (ios /= 0) then
        if (present(iostat)) then
          iostat = ios
          return
        else
          print *, 'get_string: read error ', ios
          stop
        endif
      endif
      ! なぜか SUPER-UX SX4 Fortran 90 では行末でこうなる
      if (nowread == 0 .and. len_trim(buffer) /= 0) then
        nowread = len_trim(buffer)
        goto 100
      endif
      alreadyread = alreadyread + nowread
      str = str // buffer(1: nowread)
    enddo
    if (present(iostat)) iostat = 0
    return

    ! in case of EOR
100 continue
    str = str // buffer(1: nowread)
    if (present(iostat)) iostat = 0
  end subroutine string_get

  subroutine char_put_default(char, iostat)
    character(len=*), intent(in)::                char
    integer, intent(out), optional::        iostat
  continue
    call char_put(-1, char, iostat)
  end subroutine char_put_default

  subroutine char_put(unit, char, iostat)
    integer, intent(in)::                        unit
    character(len=*), intent(in)::                char
    integer, intent(out), optional::        iostat
    integer:: ios
  continue
    if (unit >= 0) then
      write(unit=unit, fmt='(A)', advance='NO', iostat=ios) char
    else
      write(unit=*, fmt='(A)', advance='NO', iostat=ios) char
    endif
    if (present(iostat)) then
      iostat = ios
    else
      if (ios /= 0) then
        print *, 'char_put: write error ', ios
      endif
    endif
  end subroutine char_put

  subroutine string_put_default(str, iostat)
    type(VSTRING), intent(in)::        str
    integer, intent(out), optional::        iostat
  continue
    call string_put(-1, str, iostat)
  end subroutine string_put_default

  subroutine string_put(unit, str, iostat)
    integer, intent(in)::                        unit
    type(VSTRING), intent(in)::        str
    integer, intent(out), optional::        iostat
    integer:: ios
  continue
    if (unit >= 0) then
      write(unit=unit, fmt='(A)', advance='NO', iostat=ios) str%body(1:str%len)
    else
      write(unit=*, fmt='(A)', advance='NO', iostat=ios) str%body(1:str%len)
    endif
    if (present(iostat)) then
      iostat = ios
    else
      if (ios /= 0) then
        print *, 'string_put: write error ', ios
      endif
    endif
  end subroutine string_put

  subroutine char_put_line_default(char, iostat)
    character(len=*), intent(in)::                char
    integer, intent(out), optional::        iostat
  continue
    call char_put_line(-1, char, iostat)
  end subroutine char_put_line_default

  subroutine char_put_line(unit, char, iostat)
    integer, intent(in)::                        unit
    character(len=*), intent(in)::                char
    integer, intent(out), optional::        iostat
    integer:: ios
  continue
    if (unit >= 0) then
      write(unit=unit, fmt='(A)', advance='YES', iostat=ios) char
    else
      write(unit=*, fmt='(A)', advance='YES', iostat=ios) char
    endif
    if (present(iostat)) then
      iostat = ios
    else
      if (ios /= 0) then
        print *, 'char_put_line: write error ', ios
      endif
    endif
  end subroutine char_put_line

  subroutine string_put_line_default(str, iostat)
    type(VSTRING), intent(in)::        str
    integer, intent(out), optional::        iostat
  continue
    call string_put_line(-1, str, iostat)
  end subroutine string_put_line_default

  subroutine string_put_line(unit, str, iostat)
    integer, intent(in)::                        unit
    type(VSTRING), intent(in)::        str
    integer, intent(out), optional::        iostat
    integer:: ios
  continue
    if (unit >= 0) then
      write(unit=unit, fmt='(A)', advance='YES', iostat=ios) str%body(1:str%len)
    else
      write(unit=*, fmt='(A)', advance='YES', iostat=ios) str%body(1:str%len)
    endif
    if (present(iostat)) then
      iostat = ios
    else
      if (ios /= 0) then
        print *, 'string_put_line: write error ', ios
      endif
    endif
  end subroutine string_put_line

  !
  ! --- 組み込み関数たちの上書き ---
  !

  !
  ! index の代用
  !

  function string_index_string(str, substring, back) result(result)
    integer::                                result
    type(VSTRING), intent(in)::        str, substring
    logical, intent(in), optional::                back
    logical:: backward
    integer:: index
    intrinsic index
  continue
    backward = .FALSE.
    if (present(back)) backward = back
    result = index(str%body(1:str%len), &
      & substring%body(1:substring%len), backward)
  end function string_index_string

  function string_index_char(str, substring, back) result(result)
    integer::                                result
    type(VSTRING), intent(in)::        str
    character(len = *), intent(in)::        substring
    logical, intent(in), optional::                back
    logical:: backward
    integer:: index
    intrinsic index
  continue
    backward = .FALSE.
    if (present(back)) backward = back
    result = index(str%body(1:str%len), substring, backward)
  end function string_index_char

  function char_index_string(str, substring, back) result(result)
    integer::                                result
    character(len = *), intent(in)::        str
    type(VSTRING), intent(in)::        substring
    logical, intent(in), optional::                back
    logical:: backward
  continue
    backward = .FALSE.
    if (present(back)) backward = back
    result = index(str, substring%body(1:substring%len), backward)
  end function char_index_string

  !
  ! scan の代用
  !

  function string_scan_string(str, set, back) result(result)
    integer::                                result
    type(VSTRING), intent(in)::        str, set
    logical, optional::                        back
    logical:: backward
  continue
    backward = .FALSE.
    if (present(back)) backward = back
    result = scan(str%body(1:str%len), set%body(1:set%len), backward)
  end function string_scan_string

  function string_scan_char(str, set, back) result(result)
    integer::                                result
    type(VSTRING), intent(in)::        str
    character(len = *), intent(in)::        set
    logical, optional::                        back
    logical:: backward
  continue
    backward = .FALSE.
    if (present(back)) backward = back
    result = scan(str%body(1:str%len), set, backward)
  end function string_scan_char

  !
  ! verify の代用
  !

  function string_verify_string(string, set, back) result(result)
    integer::                                result
    type(VSTRING), intent(in)::        string, set
    logical, optional::                        back
    logical:: b
    intrinsic verify
  continue
    b = .FALSE.
    if (present(back)) b = back
    result = verify(string%body(1:string%len), set%body(1:set%len), b)
  end function string_verify_string

  function string_verify_char(string, set, back) result(result)
    integer::                                result
    type(VSTRING), intent(in)::        string
    character(len = *), intent(in)::        set
    logical, optional::                        back
    logical:: backward
    intrinsic verify
  continue
    backward = .FALSE.
    if (present(back)) backward = back
    result = verify(string%body(1:string%len), set, backward)
  end function string_verify_char

  !
  ! --- 新設手続 ---
  !

  type(VSTRING) function extract_string(string, start, finish)
    type(VSTRING), intent(in):: string
    integer, intent(in), optional::        start, finish
    integer:: first, last
  continue
    first = 1
    if (present(start)) first = max(start, first)
    last = len(string)
    if (present(finish)) last = min(finish, last)
    extract_string = string%body(first: last)
  end function extract_string

  subroutine split_c(string, word, set, separator, back)
    type(VSTRING), intent(inout):: string
    type(VSTRING), intent(out):: word
    character(len = *), intent(in):: set
    type(VSTRING), intent(out), optional:: separator
    logical, intent(in), optional:: back
    logical:: backward
    integer:: is, endword
  continue
    backward = .FALSE.
    if (present(back)) backward = back
    if (backward) then
      find_backward: do, endword = len(string), 1, -1
        do, is = 1, len(set)
          if (element(string, endword) == set(is:is)) &
            & exit find_backward
        enddo
      enddo find_backward
      word = extract(string, endword)
      if (present(separator)) then
        if (endword == 0) then
          separator = ""
        else
          separator = element(string, endword)
        endif
      endif
      call shorten(string, len(string) - 1)
    else
      find_forward: do, endword = 1, len(string)
        do, is = 1, len(set)
          if (element(string, endword) == set(is:is)) &
            & exit find_forward
        enddo
      enddo find_forward
      word = extract(string, 1, endword-1)
      if (present(separator)) then
        if (endword > len(string)) then
          separator = ""
        else
          separator = element(string, endword)
        endif
      endif
      call left_shift(string, endword)
    endif
  end subroutine split_c

  subroutine split_s(string, word, set, separator, back)
    type(VSTRING), intent(inout):: string
    type(VSTRING), intent(out):: word
    type(VSTRING), intent(in):: set
    type(VSTRING), intent(out), optional:: separator
    logical, intent(in), optional:: back
  continue
    call split_c(string, word, vchar(set, len(set)), separator, back)
  end subroutine split_s

  !
  ! === 内部的に利用 ===
  !

  subroutine shorten(string, newlen)
    type(VSTRING), intent(inout):: string
    integer, intent(in):: newlen
  continue
    string%len = max(min(newlen, string%len), 1)
  end subroutine shorten

  subroutine left_shift(string, width)
    type(VSTRING), intent(inout):: string
    integer, intent(in):: width
    integer:: len
  continue
    len = string%len
    string%body(1: len-width) = string%body(width+1: len)
    string%len = string%len - width
  end subroutine left_shift

  ! ある位置の文字を返す。不可能ならば空白を返す。
  character(len=1) function element(string, pos) result(result)
    type(VSTRING), intent(in):: string
    integer, intent(in):: pos
  continue
    if (pos <= 0 .or. pos > string%len) then
      result = ' '
    else
      result = string%body(pos:pos)
    endif
  end function element

  ! 連結 // 演算子
  type(VSTRING) function char_add_char(lhs, rhs) result(result)
    character(len = *), intent(in)::        lhs, rhs
    integer::                                lhslen, first, last
    interface
      subroutine dcstringbase_warnlim(cause)
        character(len = *), intent(in):: cause
      end subroutine dcstringbase_warnlim
    end interface
  continue
    if (len(rhs) == 0) then
      result = lhs
      return
    else if (len(lhs) == 0) then
      result = rhs
      return
    endif
    if (len(lhs) + len(rhs) > STRING_MAX) call dcstringbase_warnlim('//')
    result%len = min(len(lhs) + len(rhs), STRING_MAX)
    lhslen = min(len(lhs), STRING_MAX)
    result%body(1: lhslen) = lhs
    first = min(lhslen + 1, STRING_MAX)
    last = min(lhslen + len(rhs), STRING_MAX)
    result%body(first: last) = rhs
  end function char_add_char

end module dcstring_base
