!== Stack in which arbitrary number of strings are stored ! ! Authors:: Eizi TOYODA ! Version:: $Id: dcstring_list.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_list !:nodoc: 4,3 ! ! 任意個の文字列を収納するスタック ! use dcstring_base implicit none private public:: STRING_LIST, init, clear, dispose, assignment(=) public:: push, pop, shift, unshift public:: len, extract, element, split type STRING_NODE type(VSTRING):: body type(STRING_NODE), pointer:: next end type STRING_NODE type STRING_LIST private type(STRING_NODE), pointer:: head end type STRING_LIST interface init; module procedure init_vs; end interface interface clear; module procedure clear_vs; end interface interface dispose; module procedure dispose_vs; end interface interface len; module procedure len_vs; end interface interface push; module procedure push_vs, push_vc; end interface interface pop; module procedure pop_vs; end interface interface shift; module procedure shift_vs; end interface interface unshift; module procedure unshift_vs; end interface interface extract; module procedure extract_vs; end interface interface element; module procedure element_vs; end interface interface copy; module procedure copy_vs; end interface interface split 10 module procedure CharSplit module procedure VstSplit end interface contains subroutine init_vs(vs) type(STRING_LIST), intent(out):: vs continue nullify(vs%head) end subroutine init_vs subroutine copy_vs(lhs, rhs, items) 1 type(STRING_LIST), intent(inout):: lhs type(STRING_LIST), intent(in):: rhs integer, intent(in), optional:: items type(STRING_NODE), pointer:: rhs_cursor type(STRING_NODE), pointer:: lhs_cursor integer:: c, ncopy continue ncopy = huge(ncopy) if (present(items)) ncopy = items rhs_cursor => rhs%head if (.not. associated(rhs_cursor)) then nullify(lhs%head) return endif allocate(lhs%head) lhs_cursor => lhs%head c = 0 do c = c + 1 lhs_cursor%body = rhs_cursor%body if (c == ncopy .or. .not. associated(rhs_cursor%next)) then nullify(lhs_cursor%next) return endif rhs_cursor => rhs_cursor%next allocate(lhs_cursor%next) lhs_cursor => lhs_cursor%next enddo end subroutine copy_vs subroutine clear_vs(vs) type(STRING_LIST), intent(inout):: vs continue nullify(vs%head) end subroutine clear_vs subroutine dispose_vs(vs) type(STRING_LIST), intent(inout):: vs type(STRING_NODE), pointer:: cursor type(STRING_NODE), pointer:: nextp continue cursor => vs%head do if (.not. associated(cursor)) exit nextp => cursor%next cursor%body = "" deallocate(cursor) cursor => nextp enddo end subroutine dispose_vs integer function len_vs(vs) result(result) type(STRING_LIST), intent(in):: vs type(STRING_NODE), pointer:: cursor continue result = 0 cursor => vs%head do if (.not. associated(cursor)) exit result = result + 1 cursor => cursor%next enddo end function len_vs type(VSTRING) function element_vs(vs, pos) result(result) type(STRING_LIST), intent(in):: vs type(STRING_NODE), pointer:: cursor integer, intent(in):: pos integer:: c continue c = 0 cursor => vs%head do if (.not. associated(cursor)) exit c = c + 1 if (c == pos) then result = cursor%body return endif cursor => cursor%next enddo result = "" end function element_vs function extract_vs(vs, start, finish) result(result),1 ! deep copy を作る ! type(STRING_LIST):: result type(STRING_LIST), intent(in):: vs integer, intent(in), optional:: start, finish type(STRING_LIST):: shallow_copy type(STRING_NODE), pointer:: cursor integer:: c, first, items continue first = 1 if (present(start)) first = max(start, first) c = 0 cursor = vs%head do if (.not. associated(cursor)) then nullify(result%head) return endif c = c + 1 if (c == first) then shallow_copy%head => cursor exit endif cursor => cursor%next enddo items = HUGE(1) if (present(finish)) items = finish - first call copy_vs(result, shallow_copy, items) end function extract_vs subroutine push_vs(vs, string) type(STRING_LIST), intent(inout):: vs type(VSTRING), intent(in):: string type(STRING_NODE), pointer:: cursor continue if (.not. associated(vs%head)) then allocate(vs%head) vs%head%body = string nullify(vs%head%next) return endif cursor => vs%head do if (.not. associated(cursor%next)) exit cursor => cursor%next enddo allocate(cursor%next) cursor%next%body = string nullify(cursor%next%next) end subroutine push_vs subroutine push_vc(vs, string) type(STRING_LIST), intent(inout):: vs character(len = *), intent(in):: string type(STRING_NODE), pointer:: cursor continue cursor => vs%head if (.not. associated(cursor)) then allocate(vs%head) nullify(vs%head%next) vs%head%body = string return endif do if (.not. associated(cursor%next)) exit cursor => cursor%next enddo allocate(cursor%next) cursor => cursor%next cursor%body = string nullify(cursor%next) end subroutine push_vc type(VSTRING) function pop_vs(vs) result(result) type(STRING_LIST), intent(inout):: vs type(STRING_NODE), pointer:: cursor continue cursor => vs%head if (.not. associated(cursor)) then result = "" else if (.not. associated(cursor%next)) then result = cursor%body deallocate(cursor) nullify(vs%head) else do if (.not. associated(cursor%next%next)) exit cursor => cursor%next enddo result = cursor%next%body deallocate(cursor%next) endif end function pop_vs type(VSTRING) function shift_vs(vs) result(result) type(STRING_LIST), intent(inout):: vs type(STRING_NODE), pointer:: cursor continue if (associated(vs%head)) then result = vs%head%body else result = "" return endif cursor => vs%head%next deallocate(vs%head) vs%head => cursor end function shift_vs subroutine unshift_vs(vs, string) type(STRING_LIST), intent(inout):: vs type(VSTRING), intent(in):: string type(STRING_NODE), pointer:: cursor continue cursor => vs%head allocate(vs%head) vs%head%body = string vs%head%next => cursor end subroutine unshift_vs ! ! --- Split --- ! subroutine VstSplit(LIST, string, fs) 1 ! ! fs で文字列を分解して STRING_LIST に格納する。 ! このとき分解された語の先頭の空白は無視される。 ! type(STRING_LIST), intent(out):: LIST type(VSTRING), intent(in):: string character(len = *), intent(in):: FS integer:: ifind type(VSTRING):: watch continue call init(LIST) watch = string do ! watch に空白文字があるなら除去 ifind = vverify(watch, " ") if (ifind == 0) exit watch = extract(watch, ifind) ! FS に含まれる最初の文字の直前か、それがなければ文末を取り出す ifind = vscan(watch, FS) if (ifind == 0) then call push(LIST, watch) exit endif call push(LIST, extract(watch, 1, ifind - 1)) watch = extract(watch, ifind + 1) enddo end subroutine VstSplit subroutine CharSplit(list, string, fs) 1 ! ! fs で文字列を分解して STRING_LIST に格納する。 ! このとき分解された語の先頭の空白は無視される。 ! type(STRING_LIST), intent(out):: list character(len = *), intent(in):: string character(len = *), intent(in):: FS integer:: istart, iend, ifind continue call init(list) istart = 1 do ! istart 以降に空白でない文字があるか? ifind = verify(string(istart: ), " ") if (ifind == 0) exit istart = istart + ifind - 1 ! FS に含まれる最初の文字の直前か、それがなければ文末を取り出す ifind = scan(string(istart: ), FS) if (ifind == 0) then iend = len(string) else iend = istart + ifind - 1 endif call push(list, string(istart:iend)) ! もし文字が残っていれば継続 istart = iend + 2 if (istart > len(string)) exit enddo end subroutine CharSplit end module