Fix bug in split

Split some times did not nullified parent pointers of root nodes
on return.  Traversing such trees led to memory access violation
due unvalid pointers. This problem should be fixed now.

src/rbnode_mod.f90

@@ -122,14 +122,15 @@ end function rbnode_new
 
 
  function rbnode_newroot(left, dat, colour, right) result(new)
+ !! Allocate new node, fill it with given data and colour, and make
+ !! it a root of two given sub-trees
  type(rbnode_t), intent(in), pointer :: left, right
  integer(DATA_KIND), intent(in) :: dat(:)
  logical(int8), intent(in) :: colour
  type(rbnode_t), pointer :: new
 
  integer :: ierr
 
- ! Either allocate new memory or re-use the existing one 
 allocation_counter=allocation_counter+1
  allocate(new, stat=ierr)
  if (ierr /= 0) &
@@ -145,7 +146,6 @@ function rbnode_newroot(left, dat, colour, right) result(new)
  if (associated(new%left)) new%left%parent => new
  new%right => right
  if (associated(new%right)) new%right%parent => new
-
  end function rbnode_newroot
 
 
@@ -739,7 +739,6 @@ recursive subroutine insert_repair(n, tree)
  end if
 
  end if MAIN
-
  end subroutine insert_repair
 
 
@@ -1028,6 +1027,9 @@ end subroutine delete_case6
  ! =============================
 
  recursive function re_root(left,root,right) result(newroot)
+ !* Same job as "rbnode_newroot" but here we do not allocate any new memory.
+ ! The existing memory of "root" is reused instead.
+ !
  type(rbnode_t), intent(in), pointer :: left, root, right
  type(rbnode_t), pointer :: newroot
 
@@ -1046,7 +1048,6 @@ recursive function join_right(tl, key, tr) result(newroot)
  type(rbnode_t), pointer :: newroot
 
  type(rbbasetree_t) :: t
- !type(rbnode_t), pointer :: old
  logical(int8) :: tl_isblack
 
  tl_isblack = rbnode_isblack(tl)
@@ -1075,7 +1076,6 @@ recursive function join_left(tl, key, tr) result(newroot)
  type(rbnode_t), pointer :: newroot
 
  type(rbbasetree_t) :: t
- !type(rbnode_t), pointer :: old
  logical(int8) :: tr_isblack
 
  tr_isblack = rbnode_isblack(tr)
@@ -1099,6 +1099,12 @@ end function join_left
 
 
  function join(tl, key, tr) result(newroot)
+ !* Join two sub-trees and return the pointer to a root of new tree. New
+ ! node with "key" data is allocated during the process.
+ !
+ ! Note: all nodes in the left subtree must have key less than "key", and
+ ! all nodes in the right subtree must have key greater than "key" !
+ !
  type(rbnode_t), intent(in), pointer :: tl, tr
  integer(DATA_KIND), intent(in) :: key(:)
  type(rbnode_t), pointer :: newroot
@@ -1132,10 +1138,13 @@ end function join
  recursive subroutine split(l_root, key_node, r_root, old_root, key, cfun)
  !* Split tree. Nodes with a value less than "key" go to the left subtree,
  ! and nodes with a value larger than "key" go to the right subtree.
- ! If there is a node with value equal to "key", this node will not be
- ! included in any of the sub-trees. This node can be accessed through the
- ! returned pointer "key_node" (it can be freed or inserted to any of the
- ! subtrees by an user)
+ !
+ ! If tree contains a node with the same value as "key", this node will not
+ ! be included in any of the sub-trees. This node can be accessed through the
+ ! returned pointer "key_node" and it can be freed or inserted to any of the
+ ! subtrees as needed.
+ !
+ ! Tree rooted by "old_root" no longer exists after this operation !
  !
  type(rbnode_t), pointer, intent(out) :: l_root, r_root
  type(rbnode_t), intent(out), pointer :: key_node
@@ -1151,30 +1160,47 @@ recursive subroutine split(l_root, key_node, r_root, old_root, key, cfun)
  r_root => null()
  return
  end if
+
  select case(cfun(key, rbnode_read(old_root)))
- case(0)
+ case(0) ! key == old_root%key
  l_root => old_root%left
+ if (associated(l_root)) l_root%parent=>null()
+
+ ! the key-node will no longer be part of any sub-tree
  key_node => old_root
- r_root => old_root%right
- !l_root%parent=>null()
- !r_root%parent=>null()
- ! nullify pointers, as the key_node will not be part of any tree
  key_node%left => null()
  key_node%right => null()
  key_node%parent => null()
+
+ r_root => old_root%right
+ if (associated(r_root)) r_root%parent=>null()
+
  case(-1) ! key < old_root%key
  call split(ltmp, key_node, rtmp, old_root%left, key, cfun)
  to_delete => old_root
  l_root => ltmp
  r_root => join(rtmp, rbnode_read(old_root), old_root%right)
+
+ ! While "join" returns a correct root node, the parent pointer of the root
+ ! to the other tree must be nullified here. 
+ if (associated(l_root)) l_root%parent=>null()
+
+ ! As a new node has been allocated during "join" process, the actual
+ ! root became superfluous and must be freed. 
  call rbnode_free(to_delete)
+
  case(+1) ! key > old_root%key
  call split(ltmp, key_node, rtmp, old_root%right, key, cfun)
  to_delete => old_root
  l_root => join(old_root%left,rbnode_read(old_root),ltmp)
  r_root => rtmp
+
+ if (associated(r_root)) r_root%parent=>null()
  call rbnode_free(to_delete)
- !r_root => old_root%right ! wikipedia: error or ok?
+
+ !Note: there might be an error on wikipedia...
+ !r_root => old_root%right
+
  case default
  error stop 'split: user function returned invalid value'
  end select

test/tree_test.f90

@@ -8,7 +8,7 @@ module tree_test_mod
  subroutine tree_test_join()
  type(rbbasetree_t) :: tree_a, tree_b, tree_ab
  integer :: i, ierr
- integer, parameter :: IMID=4, ISPLIT=4, NTOT=12
+ integer, parameter :: IMID=4000, ISPLIT=3914080, NTOT=4120000
  !logical :: key_in_tree
  type(rbnode_t), pointer :: key_in_tree
 
@@ -26,28 +26,27 @@ subroutine tree_test_join()
  print '("Insertion R - Valid? ",L2," black height is ",i0)', &
  tree_b%isvalid(tree_test_basic_comp), tree_b%blackheight()
 
- call dump_graphviz('our_a', tree_a)
- call dump_graphviz('our_b', tree_b)
+ !call dump_graphviz('our_a', tree_a)
+ !call dump_graphviz('our_b', tree_b)
  print *
- print *, 'Traverse A'
- call traverse(tree_a)
+ !print *, 'Traverse A'
+ !call traverse(tree_a)
  print *
- print *, 'Traverse B'
- call traverse(tree_b)
+ !print *, 'Traverse B'
+ !call traverse(tree_b)
 
  tree_ab%root => join(tree_a%root, transfer(IMID,mold), tree_b%root)
  print '("Join L+R - Valid? ",L2," black height is ",i0)', &
  tree_ab%isvalid(tree_test_basic_comp), tree_ab%blackheight()
 
- call dump_graphviz('our_ab', tree_ab)
+ !call dump_graphviz('our_ab', tree_ab)
  print *
- print *, 'Traverse AB'
- call traverse(tree_ab)
+ !print *, 'Traverse AB'
+ !call traverse(tree_ab)
 
  ! Split
  print *
  print *, 'SPLIT'
- nullify(tree_a%root, tree_b%root)
  call split(tree_a%root,key_in_tree,tree_b%root, &
  tree_ab%root, transfer(ISPLIT,mold), tree_test_basic_comp)
  print '("Split: key_in_tree ",L2)', associated(key_in_tree)
@@ -59,14 +58,14 @@ subroutine tree_test_join()
  tree_a%isvalid(tree_test_basic_comp), tree_a%blackheight()
  print '("Insertion R - Valid? ",L2," black height is ",i0)', &
  tree_b%isvalid(tree_test_basic_comp), tree_b%blackheight()
- call dump_graphviz('our_c', tree_a)
- call dump_graphviz('our_d', tree_b)
+ !call dump_graphviz('our_c', tree_a)
+ !call dump_graphviz('our_d', tree_b)
  print *
- print *, 'Traverse B'
- call traverse(tree_b)
+ !print *, 'Traverse B'
+ !call traverse(tree_b)
  print *
- print *, 'Traverse A'
- call traverse(tree_a)
+ !print *, 'Traverse A'
+ !call traverse(tree_a)
 
  ! Delete everything
  print *
@@ -153,6 +152,11 @@ subroutine traverse(t)
  type(rbnode_t), pointer :: current
  integer :: i
  ! traversing
+ if (.not. associated(t%root)) then
+ print '("Traverse: Tree is empty")'
+ return
+ end if
+
  current=>rbnode_leftmost(t%root)
  do
  if (.not. associated(current)) exit