! dcstring_main.f90 - string module for Fortran90
! Copyright (C) GFD Dennou Club, 2000.  All rights reserved
! vi: set ts=8 sw=4:

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

module dcstring_base

    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

    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

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

    !
    ! 総称 len 関数の実体
    !

    integer function string_len(str) result(result)
        type(VSTRING), intent(in)::        str
    continue
        result = str%len
    end function

    !
    ! 総称 var_str 関数の実体
    !

    type(VSTRING) function char_to_string(char) result(result)
        character(len=*), intent(in)::                char
        interface
            subroutine dcstringbase_warnlim(cause)
                character(len = *), intent(in):: cause
            end subroutine
        end interface
    continue
        if (len(char) > STRING_MAX) call dcstringbase_warnlim('cast')
        result%len = min(len(char), STRING_MAX)
        result%body = char
    end function

    !
    ! 総称 vchar 関数の実体
    !

    function string_to_char_length(str, length) result(result)
        type(VSTRING), intent(in)::        str
        integer, intent(in)::                        length
        character(len = length)::                result
    continue
        call char_let_string(result, str)
    end function

    !
    ! 総称代入文の実体
    !

    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

    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

    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

    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

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

    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

    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

    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

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

    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

    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

    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

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

    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

    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

    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

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

    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

    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

    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

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

    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

    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

    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

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

    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

    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

    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

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

    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

    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

    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

    !
    ! 入出力
    !

    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

    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

    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

    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

    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

    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

    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

    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

    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

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

    !
    ! 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

    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

    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

    !
    ! 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

    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

    !
    ! 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

    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

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

    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

    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

    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

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

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

    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

    ! ある位置の文字を返す。不可能ならば空白を返す。
    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

    ! 連結 // 演算子
    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
        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

end module