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

! WHAT IS THIS
!					2000-02-24
!					TOYODA Eizi <toyoda@gfd-dennou.org>
!
!	This module implements a subset of the dynamic length character
!	string facility for Fortran 90 defined in ISO/IEC 1539-2:1994.
!	The purpose of present implementation is to resolve the
!	memory leakage problem in the sample implementation in
!	Annex A of ISO/IEC 1539-2:1994.
!
!	Code in ISO/IEC 1539-2:1994 allocates memory for storing characters,
!	but does not deallocate.  This can be used for applications which
!	handles small number of string; nevertheless applications which
!	handles string for many times --- for example, large number
!	of iteration --- needs memory of non-realistic amount.
!
!	Revision of ISO/IEC 1539-2 is now in progress, and the sample
!	implementation will be rewritten in Fortran 95.  It deallocates
!	memory in TYPE(VARYING_STRING) variable when another memory is
!	allocated.   However, when the result TYPE(VARYING_STRING) value
!	of a function is passed to another function (or subroutine) as
!	an argument, memory used for function result is never deallocated.
!
!	Resultant string of function is frequently passed to another
!	function (for example, `string // ":" // string // string').
!
!	This version of ISO_VARYING_STRING maintains string table separated
!	from VARYING_STRING.

! COPYING
!	Redistribution and use in source and binary forms, with or without
!	modification, are permitted provided that the following conditions
!	are met:
!	1. Redistributions of source code must retain the above copyright
!	   notice, this list of conditions and the following disclaimer.
!	2. Redistributions in binary form must reproduce the above copyright
!	   notice, this list of conditions and the following disclaimer in
!	   the documentation and/or other materials provided with the
!	   distribution.
!	3. All advertising materials mentioning features or use of this
!	   software must display the following acknowledgement:
!		This product includes software developed by TOYODA Eizi.
!	4. Neither the name of the author and the contributors
!	   may be used to endorse or promote products derived from this
!	   software without specific prior written permission.
!
!	THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND THE CONTRIBUTORS
!	``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING,
!	BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
!	AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
!	IN NO EVENT SHALL THE AUTHOR AND THE CONTRIBUTORS BE LIABLE
!	FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
!	OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
!	PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
!	OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
!	ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
!	LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!	ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
!	ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

! HISTORY
!	2000-02-23 TOYODA Eizi	* initial version
!	2000-02-24 TOYODA Eizi  * bugfix, copying, description

! change this line to define iso_varying_string directly
module dc_string_internal

    implicit none

    !
    ! --- private/public declarations
    !

    private

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

    ! In order to lessen memory leakage, the author (TOYODA) added it.
    public set_volatile

    ! In order to avoid DVF 6.0's bug --- never use it!
    public STRING_TABLE_ENTRY

    !
    ! --- TYPE DEFINITIONS ---
    !
    ! Structured type VARYING_STRING only contains an index to
    ! `string_table'. A string_table entry may be pointed by
    ! not only one VARYING_STRING structure variable; so 
    ! a string_table entry has a link counter component `nlink'.
    !
    ! Component nlink in string_table entry may have following values:
    !
    !	NLINK_UNUSED (-1)	initially this value in string_table
    !				allocation;
    !
    !	NLINK_NOT_STORED (0)	function return value;
    !
    !	positive value		number of VARYING_STRING variables
    !				that are set value with assignment(=).
    !
    ! Assignment operation increments new entry's nlink, and decrements 
    ! old entry's nlink. If nlink is decremented to be non-positive,
    ! the entry will be disposed. NLINK_NOT_STORED is generated
    ! by string-returning function. Any string-value reference decrements
    ! nlink of value 0, and disposed after while.
    ! 

    type VARYING_STRING
	! NOTE:	If you are using strictly Fortran 90 compiler,
	!	use following line instead:
	! integer::				id 
	integer::				id = 1
    end type

	! This type is used internally.
    type STRING_TABLE_ENTRY
    	integer::				nlink
	integer::				serial
	character, pointer::			buffer(:) 
    end type

    interface set_volatile
	module procedure string_set_volatile
    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

    integer, private, parameter:: 		DEFAULT_UNIT = -1;

    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
	module procedure string_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

    !
    ! symbols internally used for string comparison
    !

    integer, private, parameter::	CMP_LESSTHAN = -1
    integer, private, parameter::	CMP_EQUIVALENT = 0
    integer, private, parameter::	CMP_GREATERTHAN = 1
    integer, private, parameter::	CMP_ERROR = -100

    !
    ! --- string_table ---
    !
    ! Characters are stored in string_table, array of STRING_TABLE_ENTRY. 
    ! Initially, string_table is in undefined status.
    ! In first access, array of size INITIAL_TABLE_SIZE is allocated.
    ! If more than size(string_table) string is stored, 
    ! string_table is reallocated with doubled size.

    integer, private, parameter:: 	INITIAL_TABLE_SIZE = 4

    type(STRING_TABLE_ENTRY), save, pointer::	string_table(:)

    integer, save::				entry_serial = 0

    integer, private, parameter::		DISPOSE_HEURISTIC_RAG = 64

    integer, private, parameter:: 		INVALID_INDEX = -1;
    integer, private, parameter:: 		NLINK_UNUSED = -1;
    integer, private, parameter:: 		NLINK_NOT_STORED = 0;

contains

    !
    ! === PUBLIC PROCEDURES ===
    !

    ! generic set_volatile
    subroutine string_set_volatile(str)
	type(VARYING_STRING), intent(in)::	str
    continue
	if (string_table(str%id)%nlink > 1) then
	    call decrement_link(str%id)
	else
	    string_table(str%id)%nlink = NLINK_NOT_STORED
	endif
    end subroutine

    ! generic len
    integer function string_len(str) result(result)
	type(VARYING_STRING), intent(in)::	str
    continue
	if (.not. associated(string_table(str%id)%buffer)) then
	    result = 0
	else
	    result = size(string_table(str%id)%buffer)
	endif
    end function

    !
    ! generic var_str
    !

    type(VARYING_STRING) function char_to_string(char) result(result)
	character(len=*), intent(in)::	char
    continue
	result = char
	call set_volatile(result)
    end function

    !
    ! generic char
    !

    function string_to_char_all(str) result(result)
	type(VARYING_STRING), intent(in)::	str
	character(len = size(string_table(str%id)%buffer))::	result
    continue
	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
	result = str
    end function

    !
    ! assignment(=) 
    !

    subroutine string_let_string(lhs, rhs)
	type(VARYING_STRING), intent(inout)::	lhs
	type(VARYING_STRING), intent(in)::	rhs
    continue
	if (lhs%id == rhs%id) return
	! At this time lhs%id may be undefined
	! and its reference is not standard-conforming strictly.
	call decrement_link(lhs%id)
	lhs%id = rhs%id
	call increment_link(rhs%id)
    end subroutine

    subroutine string_let_char(str, char)
	type(VARYING_STRING), intent(inout)::	str
	character(len=*), intent(in)::		char
    continue
	! At this time str%id may be undefined
	! and its reference is not standard-conforming strictly.
	call decrement_link(str%id)
	str%id = table_set_char(char)
	call increment_link(str%id)
    end subroutine

    subroutine char_let_string(char, str)
	character(len=*), intent(out)::		char
	type(VARYING_STRING), intent(in)::	str
	integer::				i
    continue
	! copy entity
	do, i = 1, min(len(char), len(str))
	    char(i: i) = string_table(str%id)%buffer(i)
	enddo
	char(len(str) + 1: len(char)) = ' '
	call dispose_if_defunct(str)
    end subroutine

    !
    ! operator(//)
    !

    function string_add_string(lhs, rhs) result(result)
	type(VARYING_STRING)::			result
	type(VARYING_STRING), intent(in)::	lhs, rhs
	integer::				lhslen, rhslen
	type(STRING_TABLE_ENTRY), pointer::	target
    continue
	lhslen = len(lhs)
	rhslen = len(rhs)
	if (lhslen == 0) then
	    result = rhs
	else if (rhslen == 0) then
	    result = lhs
	else
	    result%id = table_allocate(lhslen + rhslen)
	    if (result%id <= 0) then
		result = ''
		return
	    endif
	    target => string_table(result%id)
	    target%buffer(1: lhslen) = string_table(lhs%id)%buffer(1: lhslen)
	    target%buffer(lhslen+1: lhslen+rhslen) = &
		& string_table(rhs%id)%buffer(1: rhslen)
	    call dispose_if_defunct(lhs, rhs)
	endif
	call set_volatile(result)
    end function

    function string_add_char(str, char) result(result)
	type(VARYING_STRING)::			result
	type(VARYING_STRING), intent(in)::	str
	character(len=*), intent(in)::		char
    continue
	result = string_add_string(str, var_str(char))
	call set_volatile(result)
    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 = string_add_string(var_str(char), str)
	call set_volatile(result)
    end function

    !
    ! operator(==)
    !

    logical function string_eq_string(lhs, rhs) result(result)
	type(VARYING_STRING), intent(in)::	lhs, rhs
    continue
	result = string_cmp_string(lhs, rhs) == CMP_EQUIVALENT
    end function

    logical function string_eq_char(str, char) result(result)
	type(VARYING_STRING), intent(in)::	str
	character(len=*), intent(in)::		char
    continue
	if (len(char) == 0) then
	    result = (len(str) == 0)
	    call dispose_if_defunct(str)
	    return
	endif
	result = string_eq_string(str, var_str(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 = string_eq_string(var_str(char), str)
    end function

    !
    ! operator(/=)
    !

    logical function string_ne_string(lhs, rhs) result(result)
	type(VARYING_STRING), intent(in)::	lhs, rhs
    continue
	result = .not. string_eq_string(lhs, rhs)
    end function

    logical function string_ne_char(str, char) result(result)
	type(VARYING_STRING), intent(in)::	str
	character(len=*), intent(in)::		char
    continue
	result = .not. string_eq_char(str, 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 = .not. char_eq_string(char, str)
    end function

    !
    ! operator(<)
    !

    logical function string_lt_string(lhs, rhs) result(result)
	type(VARYING_STRING), intent(in)::	lhs, rhs
    continue
	result = string_cmp_string(lhs, rhs) == CMP_LESSTHAN
    end function

    logical function string_lt_char(str, char) result(result)
	type(VARYING_STRING), intent(in)::	str
	character(len=*), intent(in)::		char
    continue
	result = string_lt_string(str, var_str(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 = string_lt_string(var_str(char), str)
    end function

    !
    ! operator(<=)
    !

    logical function string_le_string(lhs, rhs) result(result)
	type(VARYING_STRING), intent(in)::	lhs, rhs
	integer::				cmp
    continue
	cmp = string_cmp_string(lhs, rhs) 
	result = (cmp == CMP_LESSTHAN) .or. (cmp == CMP_EQUIVALENT)
    end function

    logical function string_le_char(str, char) result(result)
	type(VARYING_STRING), intent(in)::	str
	character(len=*), intent(in)::		char
    continue
	result = string_le_string(str, var_str(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 = string_le_string(var_str(char), str)
    end function

    !
    ! operator(>)
    !

    logical function string_gt_string(lhs, rhs) result(result)
	type(VARYING_STRING), intent(in)::	lhs, rhs
    continue
	result = string_cmp_string(lhs, rhs) == CMP_GREATERTHAN
    end function

    logical function string_gt_char(str, char) result(result)
	type(VARYING_STRING), intent(in)::	str
	character(len=*), intent(in)::		char
    continue
	result = string_gt_string(str, var_str(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 = string_gt_string(var_str(char), str)
    end function

    !
    ! operator(>=)
    !

    logical function string_ge_string(lhs, rhs) result(result)
	type(VARYING_STRING), intent(in)::	lhs, rhs
	integer::				cmp
    continue
	cmp = string_cmp_string(lhs, rhs) 
	result = (cmp == CMP_GREATERTHAN) .or. (cmp == CMP_EQUIVALENT)
    end function

    logical function string_ge_char(str, char) result(result)
	type(VARYING_STRING), intent(in)::	str
	character(len=*), intent(in)::		char
    continue
	result = string_ge_string(str, var_str(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 = string_ge_string(var_str(char), str)
    end function

    !
    ! --- INPUT/OUTPUT
    !
    ! generic get
    !

    subroutine string_get_default(str, maxlen, iostat)
	type(VARYING_STRING), intent(inout)::	str
	integer, intent(in), optional::		maxlen
	integer, intent(out), optional::	iostat
    continue
	call string_get(DEFAULT_UNIT, str, maxlen, iostat)
    end subroutine

    subroutine string_get(unit, str, maxlen, iostat)
	integer, intent(in)::			unit
	type(VARYING_STRING), intent(inout)::	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 = maxlen
	else
	    maxsize = huge(maxsize)
	endif
	alreadyread = 0
	str = ''
	do
	    if (alreadyread >= maxsize) return
	    buflen = min(BUFFERSIZE, maxsize - alreadyread)
	    ! for SUPER-UX f90's bug
	    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
	    if (nowread == 0 .and. len_trim(buffer) /= 0) then
		! SUPER-UX SX4 Fortran 90 falls here
		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

    !
    ! generic put
    !

    subroutine char_put_default(char, iostat)
	character(len=*), intent(in)::		char
	integer, intent(out), optional::	iostat
    continue
	call char_put(DEFAULT_UNIT, 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 char_put(DEFAULT_UNIT, char(str), iostat)
	call dispose_if_defunct(str)
    end subroutine

    subroutine string_put(unit, str, iostat)
	integer, intent(in)::			unit
	type(VARYING_STRING), intent(in)::	str
	integer, intent(out), optional::	iostat
    continue
	call char_put(unit, char(str), iostat)
	call dispose_if_defunct(str)
    end subroutine

    !
    ! generic put_line
    !

    subroutine char_put_line_default(char, iostat)
	character(len=*), intent(in)::		char
	integer, intent(out), optional::	iostat
    continue
	call char_put_line(DEFAULT_UNIT, 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 char_put_line(DEFAULT_UNIT, char(str), iostat)
	call dispose_if_defunct(str)
    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
	call char_put_line(unit, char(str), iostat)
	call dispose_if_defunct(str)
    end subroutine

    !
    ! --- INTRINSIC STRING FUNCTIONS ---
    !

    !
    ! generic 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

    !
    ! generic 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

    !
    ! generic 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

    !
    ! === PRIVATE PROCEDURES ===
    !

    ! INTERNAL MULTI-PURPOSE COMPARISON
    !
    integer function string_cmp_string(lhs, rhs) result(result)
	type(VARYING_STRING), intent(in)::	lhs, rhs
	type(STRING_TABLE_ENTRY), pointer::	lhs_entry, rhs_entry
	integer::				lhs_len, rhs_len, i
	character::				lhs_char, rhs_char
    continue
	lhs_entry => string_table(lhs%id)
	rhs_entry => string_table(rhs%id)
	if (.not. associated(lhs_entry%buffer) &
	& .or. .not. associated(rhs_entry%buffer)) then
	    result = CMP_ERROR
	    return
	endif
	result = CMP_EQUIVALENT
	lhs_len = len(lhs)
	rhs_len = len(rhs)
	do, i = 1, max(lhs_len, rhs_len)
	    if (i <= lhs_len) then
		lhs_char = lhs_entry%buffer(i)
	    else
		lhs_char = ' '
	    endif
	    if (i <= rhs_len) then
		rhs_char = rhs_entry%buffer(i)
	    else
		rhs_char = ' '
	    endif
	    if (lhs_char > rhs_char) then
		result = CMP_GREATERTHAN
		exit
	    else if (lhs_char < rhs_char) then
		result = CMP_LESSTHAN
		exit
	    endif
	enddo
	call dispose_if_defunct(lhs, rhs)
    end function

    !
    ! --- OPERATION OF STRING_TABLE ---
    !

    ! FORCE STRING_TABLE INITIALIZED
    !
    function initTable()
	logical::		initTable
	integer::		status, i
    continue
	initTable = .true.
	if (entry_serial > 0) return
	allocate(string_table(INITIAL_TABLE_SIZE), stat=status)
	if (status /= 0) then
	    initTable = .false.
	    return
	endif
	entry_serial = 1

	! zero-length string entry
	string_table(1)%nlink = 0
	allocate(string_table(1)%buffer(1:0))

	! unused entries
	do, i = 2, INITIAL_TABLE_SIZE
	    string_table(i)%nlink = NLINK_UNUSED
	    nullify(string_table(i)%buffer)
	enddo
    end function

    ! lookup first unused string_table entry and return index
    ! (non-positive value means failure)
    !
    integer function firstEmptyId()
	integer::			i
    continue
	do, i = 1, size(string_table)
	    if (string_table(i)%nlink < 0) then
		firstEmptyId = i
		return
	    endif
	enddo
	firstEmptyId = INVALID_INDEX
    end function

    subroutine growTable(newsize)
	integer, intent(in)::			newsize
	integer::				copysize, status, i
	type(STRING_TABLE_ENTRY), pointer::	newtable(:)
    continue
	copysize = min(size(string_table), newsize)
	allocate(newtable(newsize), stat=status)
	if (status == 0) then
	    newtable(1:copysize) = string_table(1:copysize)
	    newtable(copysize + 1: newsize)%nlink = NLINK_UNUSED
	    do, i = copysize + 1, newsize
		nullify(newtable(i)%buffer)
	    enddo
	    deallocate(string_table)
	    string_table => newtable
	endif
    end subroutine

    ! this must be called if a reference to id-th string_table entry is 
    ! created
    !
    subroutine increment_link(id)
    	integer, intent(in)::		id
    continue
	if (.not. associated(string_table)) return
	if (id <= 1 .or. id > size(string_table)) return
	if (string_table(id)%nlink < 0) return
	string_table(id)%nlink = string_table(id)%nlink + 1
    end subroutine

    ! this must be called if a reference to id-th string_table entry is
    ! removed
    !
    subroutine decrement_link(id)
	integer, intent(in)::		id
    continue
	if (.not. associated(string_table)) return
	if (id <= 1 .or. id > size(string_table)) return
	if (string_table(id)%nlink < 0) return
	string_table(id)%nlink = string_table(id)%nlink - 1
	if (string_table(id)%nlink <= 0) call table_dispose(id)
    end subroutine

    ! dispose function return value
    !
    subroutine dispose_if_defunct(stra, strb)
	type(VARYING_STRING), intent(in)::		stra
	type(VARYING_STRING), intent(in), optional::	strb
    continue
	if (stra%id <= 1 .or. stra%id > size(string_table)) goto 100
	if (string_table(stra%id)%nlink > 0) goto 100
	call table_dispose_one(stra%id)
100	continue
	if (.not. present(strb)) return
	if (strb%id <= 1 .or. strb%id > size(string_table)) return
	if (string_table(strb%id)%nlink > 0) return
	call table_dispose_one(strb%id)
    end subroutine

    ! dispose id-th string_table entry and enough old entries
    !
    subroutine table_dispose(id)
	integer, intent(in)::			id
	integer::				i, enough_old
    continue
	if (id <= 1 .or. id > size(string_table)) return
	call table_dispose_one(id)
	enough_old = string_table(id)%serial - DISPOSE_HEURISTIC_RAG
	do, i = 2, size(string_table)
	    if (string_table(i)%nlink > 0) cycle
	    if (string_table(i)%serial < enough_old) call table_dispose_one(i)
	enddo
    end subroutine

    ! dispose exactly one string_table entry (id-th)
    !
    subroutine table_dispose_one(id)
	integer, intent(in)::			id
	type(STRING_TABLE_ENTRY), pointer::	cur
    continue
	cur => string_table(id)
	if (.not. associated(cur%buffer)) return
	deallocate(cur%buffer)
	nullify(cur%buffer)
	cur%nlink = NLINK_UNUSED
    end subroutine

    ! allocate new string_table entry and length bytes buffer
    ! returns table index (negative value means failure)
    !
    integer function table_allocate(length) result(result)
	integer, intent(in)::			length
	integer::				status
	type(STRING_TABLE_ENTRY), pointer::	cur
    continue
	! return if failure
	result = INVALID_INDEX
	if (.not. initTable()) return
	if (length < 0) return

	! zero-length string has the first entry
	if (length == 0) then
	    result = 1
	    return
	endif

	! if length positive
	result = firstEmptyId()
	if (result < 0) then
	    call growTable(size(string_table) * 2)
	    result = firstEmptyId()
	    if (result < 0) return
	endif
	cur => string_table(result)
	if (associated(cur%buffer)) deallocate(cur%buffer)
	allocate(cur%buffer(1:length), stat=status)
	if (status /= 0) then
	    result = -3
	    return
	endif
	cur%nlink = NLINK_NOT_STORED
	entry_serial = entry_serial + 1
	cur%serial = entry_serial
    end function

    ! store char and returns table index (negative if fail)
    !
    integer function table_set_char(char) result(result)
	character(len=*), intent(in)::	char
	integer::			length, i
    continue
	length = len(char)
	result = table_allocate(length)
	if (result < 0) return
	do, i = 1, length
	    string_table(result)%buffer(i) = char(i: i)
	enddo
	string_table(result)%nlink = NLINK_NOT_STORED
    end function

end module