json_value_clone_func_nonrecursive Subroutine

private subroutine json_value_clone_func_nonrecursive(from, to)

Non-recursive deep copy function that clones a json_value structure. This is an alternative to json_value_clone_func that uses iteration instead of recursion.

See also

Type Bound

json_core

Arguments

Type IntentOptional Attributes Name
type(json_value), pointer :: from

this is the structure to clone

type(json_value), pointer :: to

the clone is put here (it must not already be associated)


Called by

proc~~json_value_clone_func_nonrecursive~~CalledByGraph proc~json_value_clone_func_nonrecursive json_core%json_value_clone_func_nonrecursive proc~json_clone json_core%json_clone proc~json_clone->proc~json_value_clone_func_nonrecursive proc~assign_json_file json_file%assign_json_file proc~assign_json_file->proc~json_clone

Source Code

    subroutine json_value_clone_func_nonrecursive(from,to)

    implicit none

    type(json_value),pointer :: from  !! this is the structure to clone
    type(json_value),pointer :: to    !! the clone is put here (it
                                      !! must not already be associated)

    type :: clone_task
        !! Stack entry for tracking clone operations
        type(json_value),pointer :: from => null() !! from node
        type(json_value),pointer :: to => null() !! to node
        type(json_value),pointer :: parent => null() !! parent node
        type(json_value),pointer :: previous => null() !! previous node
        logical :: is_tail = .false.  !! if `to` is the tail of its parent's children
        logical :: is_allocated = .false.  !! if `to` has been allocated yet
    end type clone_task

    type(clone_task),dimension(:),allocatable :: stack  !! stack for tracking tasks
    integer(IK) :: stack_size  !! current stack size
    integer(IK) :: p  !! current stack pointer
    type(clone_task) :: c  !! current task
    type(json_value),pointer :: new  !! newly allocated node

    integer(IK),parameter :: initial_stack_size = 256_IK  !! initial stack size

    nullify(to)

    if (.not. associated(from)) return

    ! Initialize stack with a reasonable size
    stack_size = initial_stack_size
    allocate(stack(stack_size))

    ! Push the initial task onto the stack
    p = 1_IK
    stack(p)%from => from
    stack(p)%to => null()
    stack(p)%is_allocated = .false.
    stack(p)%parent => null()
    stack(p)%previous => null()
    stack(p)%is_tail = .false.

    ! Process stack iteratively
    do while (p > 0_IK)
        ! Pop from stack
        c = stack(p)
        p = p - 1_IK

        ! Allocate the to if not already done
        if (.not. c%is_allocated) then
            allocate(new)

            ! Copy over the data variables
            if (allocated(c%from%name)) new%name = c%from%name
            if (allocated(c%from%dbl_value)) allocate(new%dbl_value,source=c%from%dbl_value)
            if (allocated(c%from%log_value)) allocate(new%log_value,source=c%from%log_value)
            if (allocated(c%from%str_value)) new%str_value = c%from%str_value
            if (allocated(c%from%int_value)) allocate(new%int_value,source=c%from%int_value)
            new%var_type   = c%from%var_type
            new%n_children = c%from%n_children

            ! Set up parent/previous/tail pointers
            if (associated(c%parent)) new%parent => c%parent
            if (associated(c%previous)) new%previous => c%previous
            if (c%is_tail .and. associated(new%parent)) new%parent%tail => new

            ! Link this node to the output structure
            if (associated(c%previous)) then  ! This is a next sibling
                c%previous%next => new
            else if (associated(c%parent)) then  ! This is the first child
                c%parent%children => new
            else  ! This is the root node
                to => new
            end if

            ! Push children onto stack (if any)
            if (associated(c%from%children)) then
                call resize_stack(stack, stack_size)
                p = p + 1_IK
                stack(p)%from => c%from%children
                stack(p)%to => null()
                stack(p)%previous => null()
                stack(p)%parent => new
                stack(p)%is_tail = (.not. associated(c%from%children%next))
                stack(p)%is_allocated = .false.
            end if

            ! Push next sibling onto stack (if any and parent exists)
            if (associated(c%from%next) .and. &
                associated(c%parent)) then
                call resize_stack(stack, stack_size)
                p = p + 1_IK
                stack(p)%from => c%from%next
                stack(p)%to => null()
                stack(p)%previous => new
                stack(p)%parent => c%parent
                stack(p)%is_tail = (.not. associated(c%from%next%next))
                stack(p)%is_allocated = .false.
            end if
        end if
    end do

    deallocate(stack)  ! clean up

    contains

        subroutine resize_stack(stk, stk_size)
            !! Resize the stack if needed.
            type(clone_task),dimension(:),allocatable,intent(inout) :: stk
            integer(IK),intent(inout) :: stk_size
            type(clone_task),dimension(:),allocatable :: tmp
            integer(IK) :: new_size
            if (p + 1_IK > stack_size) then
                new_size = stk_size * 2_IK
                allocate(tmp(new_size))
                tmp(1:stk_size) = stk
                call move_alloc(tmp, stk)
                stk_size = new_size
            end if
        end subroutine resize_stack

    end subroutine json_value_clone_func_nonrecursive