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

! 解説
!	本モジュールは PSR vf90 で 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, &
	& disposable

    integer, parameter::		STRING_MAX = 508

    type VARYING_STRING
    	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 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 = STRING_MAX)::		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 = STRING_MAX)::		result
    continue
	call char_let_string(result, str)
	result(length: STRING_MAX) = ''
    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::		buflen, nowread, ios, maxsize
	integer, parameter::	BUFFERSIZE = STRING_MAX
	character(len = BUFFERSIZE)::		buffer
	character(len = 10)::			format
    continue
	! this is fake
	maxsize = BUFFERSIZE
	if (present(maxlen)) then
	    if (maxlen > 0) maxsize = min(maxlen, BUFFERSIZE)
	endif
	buffer = ''
	write(unit=format, fmt="('(A', i5, ')')") maxsize
	if (unit >= 0) then
	    read(unit=unit, fmt=format, iostat=ios) buffer
	else
	    read(unit=*, fmt=format, iostat=ios) buffer
	endif
	nowread = len_trim(buffer)
	if (nowread == 0) nowread = len(buffer)
	str = buffer(1: nowread)
	if (present(iostat)) then
	    iostat = ios
	else if (ios > 0) then
	    print *, 'get: iostat=', ios
	    stop
	endif
    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
	character(len = 10)::			format
    continue
	write(unit=format, fmt="('(A', i4, ')')") len(str)
	if (unit >= 0) then
	    write(unit=unit, fmt=format, advance='NO', iostat=ios) char(str)
	else
	    write(unit=*, fmt=format, 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
	character(len = 10)::			format
    continue
	write(unit=format, fmt="('(A', i4, ')')") len(str)
	if (unit >= 0) then
	    write(unit=unit, fmt=format, advance='YES', iostat=ios) char(str)
	else
	    write(unit=*, fmt=format, 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, optional::			back
    continue
	result = index(char(str), char(substring), back)
    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, optional::			back
    continue
	result = index(char(str), substring, back)
    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, optional::			back
    continue
	result = index(str, char(substring), back)
    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(str, set, back) result(result)
	integer::				result
	type(VARYING_STRING), intent(in)::	str, set
	logical, optional::			back
    continue
	result = verify(char(str), char(set), back)
    end function

    function string_verify_char(str, set, back) result(result)
	integer::				result
	type(VARYING_STRING), intent(in)::	str
	character(len = *), intent(in)::	set
	logical, optional::			back
    continue
	result = verify(char(str), set, back)
    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