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.

[[json_value]] linked list (so the normal `parent`, `previous`,
`next`, etc. pointers are properly associated if necessary).

   could lead to a circular linkage. An exception is thrown if
   this is tried.

   produce a malformed JSON structure, such as moving an array
   element outside of an array. This is not checked for.

Type Bound

json_core

Arguments

Type IntentOptional Attributes Name
class(json_core), intent(inout) :: json
type(json_value), pointer :: p1

swap with p2
type(json_value), pointer :: p2

swap with p1

Calls

proc~~json_value_swap~~CallsGraph proc~json_value_swap json_core%json_value_swap none~throw_exception json_core%throw_exception proc~json_value_swap->none~throw_exception proc~json_value_is_child_of json_core%json_value_is_child_of proc~json_value_swap->proc~json_value_is_child_of proc~json_throw_exception json_core%json_throw_exception none~throw_exception->proc~json_throw_exception proc~json_traverse json_core%json_traverse proc~json_value_is_child_of->proc~json_traverse proc~json_traverse->none~throw_exception

Source Code

    subroutine json_value_swap(json,p1,p2)

    implicit none

    class(json_core),intent(inout) :: json
    type(json_value),pointer       :: p1  !! swap with `p2`
    type(json_value),pointer       :: p2  !! swap with `p1`

    logical                  :: same_parent !! if `p1` and `p2` have the same parent
    logical                  :: first_last  !! if `p1` and `p2` are the first,last or
                                            !! last,first children of a common parent
    logical                  :: adjacent    !! if `p1` and `p2` are adjacent
                                            !! elements in an array
    type(json_value),pointer :: a           !! temporary variable
    type(json_value),pointer :: b           !! temporary variable

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