json_value_swap Subroutine

private subroutine json_value_swap(json, p1, p2)

Swap two elements in a JSON structure. All of the children are carried along as well.

Arguments

Type IntentOptional AttributesName
class(json_core), intent(inout) :: json
type(json_value), pointer:: p1
type(json_value), pointer:: p2

Contents

Source Code


Source Code

    subroutine json_value_swap(json,p1,p2)

    implicit none

    class(json_core),intent(inout) :: json
    type(json_value),pointer       :: p1
    type(json_value),pointer       :: p2

    logical :: same_parent,first_last,adjacent
    type(json_value),pointer :: a,b

    if (json%exception_thrown) return

    !both have to be associated:
    if (associated(p1) .and. associated(p2)) then

        !simple check to make sure that they both
        !aren't pointing to the same thing:
        if (.not. associated(p1,p2)) then

            !we will not allow swapping an item with one of its descendants:
            if (json%is_child_of(p1,p2) .or. json%is_child_of(p2,p1)) then
                call json%throw_exception('Error in json_value_swap: '//&
                                          'cannot swap an item with one of its descendants')
            else

                same_parent = ( associated(p1%parent) .and. &
                                associated(p2%parent) .and. &
                                associated(p1%parent,p2%parent) )
                if (same_parent) then
                    !if p1,p2 are the first,last or last,first
                    !children of a common parent
                    first_last = (associated(p1%parent%children,p1) .and. &
                                  associated(p2%parent%tail,p2)) .or. &
                                 (associated(p1%parent%tail,p1) .and. &
                                  associated(p2%parent%children,p2))
                else
                    first_last = .false.
                end if

                !first, we fix children,tail pointers:

                if (same_parent .and. first_last) then

                    !this is all we have to do for the parent in this case:
                    call swap_pointers(p1%parent%children,p2%parent%tail)

                else if (same_parent .and. .not. first_last) then

                    if (associated(p1%parent%children,p1)) then
                        p1%parent%children => p2 ! p1 is the first child of the parent
                    else if (associated(p1%parent%children,p2)) then
                        p1%parent%children => p1 ! p2 is the first child of the parent
                    end if
                    if (associated(p1%parent%tail,p1)) then
                        p1%parent%tail => p2 ! p1 is the last child of the parent
                    else if (associated(p1%parent%tail,p2)) then
                        p1%parent%tail => p1 ! p2 is the last child of the parent
                    end if

                else ! general case: different parents

                    if (associated(p1%parent)) then
                        if (associated(p1%parent%children,p1)) p1%parent%children => p2
                        if (associated(p1%parent%tail,p1))     p1%parent%tail     => p2
                    end if
                    if (associated(p2%parent)) then
                        if (associated(p2%parent%children,p2)) p2%parent%children => p1
                        if (associated(p2%parent%tail,p2))     p2%parent%tail     => p1
                    end if
                    call swap_pointers(p1%parent, p2%parent)

                end if

                !now, have to fix previous,next pointers:

                !first, see if they are adjacent:
                adjacent = associated(p1%next,p2) .or. &
                           associated(p2%next,p1)
                if (associated(p2%next,p1)) then    !p2,p1
                    a => p2
                    b => p1
                else    !p1,p2 (or not adjacent)
                    a => p1
                    b => p2
                end if
                if (associated(a%previous)) a%previous%next => b
                if (associated(b%next))     b%next%previous => a

                if (adjacent) then
                    !a comes before b in the original list
                    b%previous => a%previous
                    a%next     => b%next
                    a%previous => b
                    b%next     => a
                else
                    if (associated(a%next))       a%next%previous => b
                    if (associated(b%previous))   b%previous%next => a
                    call swap_pointers(a%previous,b%previous)
                    call swap_pointers(a%next,    b%next)
                end if

            end if

        else
            call json%throw_exception('Error in json_value_swap: '//&
                                      'both pointers must be associated')
        end if

    end if

    contains

        pure subroutine swap_pointers(s1,s2)

        implicit none

        type(json_value),pointer,intent(inout) :: s1
        type(json_value),pointer,intent(inout) :: s2

        type(json_value),pointer :: tmp  !! temporary pointer

        if (.not. associated(s1,s2)) then
            tmp => s1
            s1  => s2
            s2  => tmp
        end if

        end subroutine swap_pointers

    end subroutine json_value_swap