Reproduce a bug in split for debugging

src/rbnode_mod.f90

@@ -50,7 +50,7 @@ module rbnode_mod
  public rbnode_leftmost, rbnode_nextnode, rbnode_prevnode
  public rbnode_insert, rbnode_delete
  public rbnode_validate, rbnode_blackheight
- public join
+ public join, split
 
  integer, public, save :: allocation_counter = 0
  !! temporary, just for mem.leakage debuging TODO
@@ -1129,6 +1129,58 @@ function join(tl, key, tr) result(newroot)
  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)
+ !
+ type(rbnode_t), pointer, intent(out) :: l_root, r_root
+ type(rbnode_t), intent(out), pointer :: key_node
+ type(rbnode_t), pointer, intent(in) :: old_root
+ integer(DATA_KIND), intent(in) :: key(:)
+ procedure(compare_fun) :: cfun
+
+ type(rbnode_t), pointer :: ltmp, rtmp, to_delete
+
+ if (.not. associated(old_root)) then
+ l_root => null()
+ key_node => null()
+ r_root => null()
+ return
+ end if
+ select case(cfun(key, rbnode_read(old_root)))
+ case(0)
+ l_root => old_root%left
+ 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()
+ 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)
+ 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
+ call rbnode_free(to_delete)
+ !r_root => old_root%right ! wikipedia: error or ok?
+ case default
+ error stop 'split: user function returned invalid value'
+ end select
+ end subroutine split
+
+
  ! ================================
  ! Validation and debugging helpers
  ! ================================

test/tree_test.f90

@@ -8,37 +8,85 @@ module tree_test_mod
  subroutine tree_test_join()
  type(rbbasetree_t) :: tree_a, tree_b, tree_ab
  integer :: i, ierr
- integer, parameter :: NMID=2500000, NRIGHT=2500200
+ integer, parameter :: IMID=4, ISPLIT=4, NTOT=12
+ !logical :: key_in_tree
+ type(rbnode_t), pointer :: key_in_tree
 
- do i=1, NMID-1
+ do i=2, IMID-1, 2
  call rbnode_insert(tree_a, rbnode_t(transfer(i,mold)), tree_test_basic_comp)
  end do
  print '("Insertion L - Valid? ",L2," black height is ",i0)', &
  tree_a%isvalid(tree_test_basic_comp), tree_a%blackheight()
 
- do i=NRIGHT, NMID+1, -1
+ do i=NTOT, IMID+1, -2
  !do i=NMID+1, NRIGHT
  call rbnode_insert(tree_b, rbnode_t(transfer(i,mold)), tree_test_basic_comp, ierr)
  if (ierr/=0) print *, 'Insert ierr = ',ierr
  end do
  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 *
+ print *, 'Traverse B'
+ call traverse(tree_b)
 
- tree_ab%root => join(tree_a%root, transfer(NMID,mold), tree_b%root)
+ 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)
+
+ ! 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)
+ if (associated(key_in_tree)) then
+ print *, 'Key =',transfer(rbnode_read(key_in_tree),i)
+ call rbnode_free(key_in_tree)
+ end if
+ print '("Insertion L - Valid? ",L2," black height is ",i0)', &
+ 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)
+ print *
+ print *, 'Traverse B'
+ call traverse(tree_b)
+ print *
+ print *, 'Traverse A'
+ call traverse(tree_a)
 
  ! Delete everything
- do i=1,NRIGHT
- call rbnode_delete(tree_ab, rbnode_find(tree_ab%root, transfer(i,mold), tree_test_basic_comp))
+ print *
+ print *, 'DELETE'
+ !do i=1,NRIGHT
+ ! call rbnode_delete(tree_ab, rbnode_find(tree_ab%root, transfer(i,mold), tree_test_basic_comp))
+ !end do
+ do i=2,min(ISPLIT-1,NTOT),2
+ call rbnode_delete(tree_a, rbnode_find(tree_a%root, transfer(i,mold), tree_test_basic_comp))
+ end do
+ do i=ISPLIT+2-mod(ISPLIT,2), NTOT,2
+ call rbnode_delete(tree_b, rbnode_find(tree_b%root, transfer(i,mold), tree_test_basic_comp))
  end do
+
+ !print '("Empty tree - Valid? ",L2," black height is ",i0)', &
+ ! tree_ab%isvalid(tree_test_basic_comp), tree_ab%blackheight()
  print '("Empty tree - Valid? ",L2," black height is ",i0)', &
- tree_ab%isvalid(tree_test_basic_comp), tree_ab%blackheight()
+ tree_a%isvalid(tree_test_basic_comp), tree_a%blackheight()
+ print '("Empty tree - Valid? ",L2," black height is ",i0)', &
+ tree_b%isvalid(tree_test_basic_comp), tree_b%blackheight()
  print *, 'Allocated nodes zero? =', allocation_counter
 
  end subroutine tree_test_join
@@ -99,6 +147,22 @@ subroutine tree_test_basic()
 
  end subroutine
 
+
+ subroutine traverse(t)
+ type(rbbasetree_t), intent(in) :: t
+ type(rbnode_t), pointer :: current
+ integer :: i
+ ! traversing
+ current=>rbnode_leftmost(t%root)
+ do
+ if (.not. associated(current)) exit
+ write(*,'("[",i0,l2,": ",i0,"]",3x)',advance='no') &
+ transfer(rbnode_read(current),i), current%is_node_black(), rbnode_blackheight(current)
+ current => current%nextnode()
+ end do
+ write(*,*)
+ end subroutine traverse
+
  subroutine dump_graphviz(basename, tree)
  character(len=*), intent(in) :: basename
  type(rbbasetree_t), intent(in) :: tree