! 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