!== 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-20060627 $
! 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: 14,51
!
! 本モジュールはポインタが使えない環境で 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 10
module procedure split_c
module procedure split_s
end interface
interface get 32
module procedure string_get
module procedure string_get_default
end interface
interface put 11
module procedure string_put
module procedure string_put_default
module procedure char_put
module procedure char_put_default
end interface
interface put_line 1
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) 1
!
! 総称 len 関数の実体
!
type(VSTRING), intent(in):: str
continue
result = str%len
end function string_len
type(VSTRING) function char_to_string(char) result(result) 1,1
!
! 総称 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) 1,1
!
! 総称 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) 1
!
! 総称代入文の実体
!
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) 1
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) 2
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) 1
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) 2,1
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) 2,1
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) 2,1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1,1
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) 2
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) 1,1
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) 2
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) 1,1
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) 2
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) 1,1
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) 2
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) 1,1
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) 2
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 1
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) 2,6
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) 1,1
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) 1
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) 1
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) 7
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) 3,1
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