! df_string.f90 - string module for Fortran90 (fake)
! Copyright (C) TOYODA Eizi, 2000.  All rights reserved.
! vi: set ts=8 sw=4:

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

module dc_string_internal

    implicit none

    private
    public VARYING_STRING, len, var_str, char, get, put, put_line, &
	& assignment(=), operator(==), operator(/=), operator(//), &
	& operator(<), operator(<=), operator(>), operator(>=), &
	& index, scan, verify, extract, split, &
	& disposable

    integer, parameter::		STRING_MAX = 508

    type VARYING_STRING
	private
    	integer::				len
	character(len = STRING_MAX)::		body
    end type

    interface disposable
	module procedure string_set_disposable
    end interface

    interface len
	module procedure string_len
    end interface

    interface var_str
	module procedure char_to_string
    end interface

    interface char
	module procedure string_to_char_all
	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 scan
	module procedure string_scan_string
	module procedure string_scan_char
    end interface

    interface verify
	module procedure string_verify_string
	module procedure string_verify_char
    end interface

    interface index
	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 char_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(==)
	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

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

    !
    ! 総称 disposable 関数の実体
    !

    subroutine string_set_disposable(str)
	type(VARYING_STRING), intent(in)::	str
    continue
	! do nothing
    end subroutine

    !
    ! 総称 len 関数の実体
    !

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

    !
    ! 総称 var_str 関数の実体
    !

    type(VARYING_STRING) function char_to_string(char) result(result)
	character(len=*), intent(in)::		char
    continue
    	if (len(char) > STRING_MAX) call warn_limit('cast')
	result%len = min(len(char), STRING_MAX)
	! 効率は無視
    	result%body = char
    end function

    !
    ! 総称 char 関数の実体
    !

    function string_to_char_all(str) result(result)
	type(VARYING_STRING), intent(in)::	str
	character(len = str%len)::		result
    continue
	call char_let_string(result, str)
    end function

    function string_to_char_length(str, length) result(result)
	type(VARYING_STRING), 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(VARYING_STRING), intent(inout)::	str
	character(len=*), intent(in)::		char
    continue
	str%len = len(char)
	str%body = char
    end subroutine

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

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

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

    type(VARYING_STRING) function string_add_char(lhs, rhs) result(result)
	type(VARYING_STRING), 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(VARYING_STRING)::				result
	character(len=*), intent(in)::			char
	type(VARYING_STRING), 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(VARYING_STRING), 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(VARYING_STRING), 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(VARYING_STRING), intent(in)::	str
    continue
	result = (char == str%body(1: str%len))
    end function

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

    logical function string_ne_string(lhs, rhs) result(result)
	type(VARYING_STRING), 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(VARYING_STRING), 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(VARYING_STRING), intent(in)::	str
    continue
	result = (char /= str%body(1: str%len))
    end function

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

    logical function string_lt_string(lhs, rhs) result(result)
	type(VARYING_STRING), 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(VARYING_STRING), 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(VARYING_STRING), intent(in)::	str
    continue
	result = (char < str%body(1: str%len))
    end function

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

    logical function string_le_string(lhs, rhs) result(result)
	type(VARYING_STRING), 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(VARYING_STRING), 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(VARYING_STRING), intent(in)::	str
    continue
	result = (char <= str%body(1: str%len))
    end function

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

    logical function string_gt_string(lhs, rhs) result(result)
	type(VARYING_STRING), 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(VARYING_STRING), 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(VARYING_STRING), intent(in)::	str
    continue
	result = (char > str%body(1: str%len))
    end function

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

    logical function string_ge_string(lhs, rhs) result(result)
	type(VARYING_STRING), 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(VARYING_STRING), 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(VARYING_STRING), intent(in)::	str
    continue
	result = (char >= str%body(1: str%len))
    end function

    !
    ! 入出力
    !

    subroutine string_get_default(str, maxlen, iostat)
	type(VARYING_STRING), 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(VARYING_STRING), 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(VARYING_STRING), 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(VARYING_STRING), intent(in)::	str
	integer, intent(out), optional::	iostat
	integer:: ios
    continue
	if (unit >= 0) then
	    write(unit=unit, fmt='(A)', advance='NO', iostat=ios) char(str)
	else
	    write(unit=*, fmt='(A)', advance='NO', iostat=ios) char(str)
	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(VARYING_STRING), 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(VARYING_STRING), intent(in)::	str
	integer, intent(out), optional::	iostat
	integer:: ios
    continue
	if (unit >= 0) then
	    write(unit=unit, fmt='(A)', advance='YES', iostat=ios) char(str)
	else
	    write(unit=*, fmt='(A)', advance='YES', iostat=ios) char(str)
	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(VARYING_STRING), intent(in)::	str, substring
	logical, intent(in), optional::		back
	logical:: backward
    continue
	backward = .FALSE.
	if (present(back)) backward = back
	result = index(char(str), char(substring), backward)
    end function

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

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

    !
    ! scan の代用
    !

    function string_scan_string(str, set, back) result(result)
	integer::				result
	type(VARYING_STRING), intent(in)::	str, set
	logical, optional::			back
    continue
	result = scan(char(str), char(set), back)
    end function

    function string_scan_char(str, set, back) result(result)
	integer::				result
	type(VARYING_STRING), intent(in)::	str
	character(len = *), intent(in)::	set
	logical, optional::			back
    continue
	result = scan(char(str), set, back)
    end function

    !
    ! verify の代用
    !

    function string_verify_string(string, set, back) result(result)
	integer::				result
	type(VARYING_STRING), intent(in)::	string, set
	logical, optional::			back
    continue
	result = verify(char(string), char(set), back)
    end function

    function string_verify_char(string, set, back) result(result)
	integer::				result
	type(VARYING_STRING), intent(in)::	string
	character(len = *), intent(in)::	set
	logical, optional::			back
    continue
	result = verify(char(string), set, back)
    end function

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

    type(VARYING_STRING) function extract_string(string, start, finish)
	type(VARYING_STRING), 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(VARYING_STRING), intent(inout):: string
	type(VARYING_STRING), intent(out):: word
	character(len = *), intent(in):: set
	type(VARYING_STRING), 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(VARYING_STRING), intent(inout):: string
	type(VARYING_STRING), intent(out):: word
	type(VARYING_STRING), intent(in):: set
	type(VARYING_STRING), intent(out), optional:: separator
	logical, intent(in), optional:: back
	logical:: backward
	integer:: is, endword
    continue
	call split_c(string, word, char(set), separator, back)
    end subroutine

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

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

    subroutine left_shift(string, width)
	type(VARYING_STRING), 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(VARYING_STRING), 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

    subroutine warn_limit(cause)
	character(len = *), intent(in)::	cause
	logical, save::				first = .TRUE.
    continue
    	if (.not. first) return
	print "(a, i4, 2a)", &
	    & 'Warning: string length exceeded limit', &
	    & STRING_MAX, ' by ', cause
    end subroutine

    ! 連結 // 演算子
    type(VARYING_STRING) function char_add_char(lhs, rhs) result(result)
	character(len = *), intent(in)::	lhs, rhs
	integer::				lhslen, first, last
    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 warn_limit('//')
	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