diff --git a/C/arrays.c b/C/arrays.c index f63a388ff..d0852a105 100644 --- a/C/arrays.c +++ b/C/arrays.c @@ -692,6 +692,95 @@ ResizeStaticArray(StaticArrayEntry *pp, Int dim) WRITE_UNLOCK(pp->ArRWLock); } +static void +ClearStaticArray(StaticArrayEntry *pp) +{ + statarray_elements old_v = pp->ValueOfVE; + static_array_types type = pp->ArrayType; + Int dim = - pp->ArrayEArity, i; + + /* change official size */ + if (pp->ArrayEArity >= 0){ + return; + } + WRITE_LOCK(pp->ArRWLock); + switch(type) { + case array_of_ints: + memset((void *)pp->ValueOfVE.ints,0,sizeof(int)*dim); + break; + case array_of_chars: + memset((void *)pp->ValueOfVE.chars,0,sizeof(char)*dim); + break; + case array_of_uchars: + memset((void *)pp->ValueOfVE.uchars,0,sizeof(unsigned char)*dim); + break; + case array_of_doubles: + memset((void *)pp->ValueOfVE.floats,0,sizeof(double)*dim); + break; + case array_of_ptrs: + memset((void *)pp->ValueOfVE.ptrs,0,sizeof(void *)*dim); + break; + case array_of_atoms: + for (i = 0; i< dim; i++) + pp->ValueOfVE.atoms[i] = TermNil; + break; + case array_of_dbrefs: + for (i = 0; i < dim; i++) { + Term t0 = pp->ValueOfVE.dbrefs[i]; + if (t0 != 0L) { + DBRef ptr = DBRefOfTerm(t0); + + if (ptr->Flags & LogUpdMask) { + LogUpdClause *lup = (LogUpdClause *)ptr; + LOCK(lup->ClLock); + lup->ClRefCount--; + if (lup->ClRefCount == 0 && + (lup->ClFlags & ErasedMask) && + !(lup->ClFlags & InUseMask)) { + UNLOCK(lup->ClLock); + Yap_ErLogUpdCl(lup); + } else { + UNLOCK(lup->ClLock); + } + } else { + ptr->NOfRefsTo--; + if (ptr->NOfRefsTo == 0 && + (ptr->Flags & ErasedMask) && + !(ptr->Flags & InUseMask)) { + Yap_ErDBE(ptr); + } + } + } + pp->ValueOfVE.dbrefs[i] = 0L; + } + break; + case array_of_terms: + for (i = 0; i < dim; i++) { + DBTerm *ref = pp->ValueOfVE.terms[i]; + + if (ref != NULL) { + Yap_ReleaseTermFromDB(ref); + } + pp->ValueOfVE.terms[i] = NULL; + } + break; + case array_of_nb_terms: + for (i = 0; i < dim; i++) { + Term told = pp->ValueOfVE.lterms[i].tstore; + CELL *livep = &(pp->ValueOfVE.lterms[i].tlive); + + RESET_VARIABLE(livep); + /* recover space */ + if (IsApplTerm(told)) { + Yap_ReleaseTermFromDB((DBTerm *)RepAppl(told)); + } + pp->ValueOfVE.lterms[i].tstore = old_v.lterms[i].tstore; + } + break; + } + WRITE_UNLOCK(pp->ArRWLock); +} + /* create an array (?Name, + Size) */ static Int p_create_array(void) @@ -1008,6 +1097,37 @@ p_resize_static_array(void) } } +/* resize a static array (+Name, + Size, +Props) */ +/* does not work for mmap arrays yet */ +static Int +p_clear_static_array(void) +{ + Term t = Deref(ARG1); + + if (IsVarTerm(t)) { + Yap_Error(INSTANTIATION_ERROR,t,"clear a static array"); + return FALSE; + } + else if (IsAtomTerm(t)) { + /* resize a named array */ + Atom a = AtomOfTerm(t); + StaticArrayEntry *pp = RepStaticArrayProp(RepAtom(a)->PropsOfAE); + + while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty) + pp = RepStaticArrayProp(pp->NextOfPE); + if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) { + Yap_Error(PERMISSION_ERROR_RESIZE_ARRAY,t,"clear a static array"); + return FALSE; + } else { + ClearStaticArray(pp); + return TRUE; + } + } else { + Yap_Error(TYPE_ERROR_ATOM,t,"clear a static array"); + return FALSE; + } +} + /* Close a named array (+Name) */ static Int p_close_static_array(void) @@ -2368,6 +2488,7 @@ Yap_InitArrayPreds(void) Yap_InitCPred("dynamic_update_array", 3, p_assign_dynamic, SafePredFlag); Yap_InitCPred("add_to_array_element", 4, p_add_to_array_element, SafePredFlag); Yap_InitCPred("array_element", 3, p_access_array, 0); + Yap_InitCPred("reset_static_array", 1, p_clear_static_array, SafePredFlag); Yap_InitCPred("close_static_array", 1, p_close_static_array, SafePredFlag); Yap_InitCPred("$sync_mmapped_arrays", 0, p_sync_mmapped_arrays, SafePredFlag|HiddenPredFlag); Yap_InitCPred("$compile_array_refs", 0, p_compile_array_refs, SafePredFlag|HiddenPredFlag); diff --git a/library/rbtrees.yap b/library/rbtrees.yap index 303f026f5..ff2b11084 100644 --- a/library/rbtrees.yap +++ b/library/rbtrees.yap @@ -20,6 +20,7 @@ rb_apply/4, % +T, +Key, :G, -TN rb_lookupall/3, % +Key, -Value, +T rb_insert/4, % +T0, +Key, ?Value, -TN + rb_insert_new/4, % +T0, +Key, ?Value, -TN rb_delete/3, % +T, +Key, -TN rb_delete/4, % +T, +Key, -Val, -TN rb_visit/2, % +T, -Pairs @@ -345,13 +346,6 @@ insert(Tree0,Key,Val,Nil,Tree) :- insert2(Tree0,Key,Val,Nil,TreeI,_), fix_root(TreeI,Tree). -% -% make sure the root is always black. -% -fix_root(black(L,K,V,R),black(L,K,V,R)). -fix_root(red(L,K,V,R),black(L,K,V,R)). - - % % Cormen et al present the algorithm as % (1) standard tree insertion; @@ -402,6 +396,53 @@ insert2(black(L,K0,V0,R), K, V, Nil, NT, Flag) :- fix_right(Flag0, black(L,K0,V0,IR), NT, Flag) ). +% We don't use parent nodes, so we may have to fix the root. + +%% rb_insert_new(+T0, +Key, ?Value, -TN) +% +% Add a new element with key Key and Value to the tree T0 creating a +% new red-black tree TN. Duplicated elements are not allowed. + +insert_new(Tree0,Key,Val,Nil,Tree) :- + insert_new_2(Tree0,Key,Val,Nil,TreeI,_), + fix_root(TreeI,Tree). + +% +% actual insertion, copied from insert2 +% +insert_new_2(black([],[],[],[]), K, V, Nil, T, Status) :- !, + T = red(Nil,K,V,Nil), + Status = not_done. +insert_new_2(red(L,K0,V0,R), K, V, Nil, NT, Flag) :- + ( K @< K0 + -> NR = R, + NT = red(NL,K0,V0,R), + insert_new_2(L, K, V, Nil, NL, Flag) + ; K == K0 -> + fail + ; + NT = red(L,K0,V0,NR), + insert2(R, K, V, Nil, NR, Flag) + ). +insert_new_2(black(L,K0,V0,R), K, V, Nil, NT, Flag) :- + ( K @< K0 + -> insert_new_2(L, K, V, Nil, IL, Flag0), + fix_left(Flag0, black(IL,K0,V0,R), NT, Flag) + ; K == K0 -> + fail + ; + insert_new_2(R, K, V, Nil, IR, Flag0), + fix_right(Flag0, black(L,K0,V0,IR), NT, Flag) + ). + +% +% make sure the root is always black. +% +fix_root(black(L,K,V,R),black(L,K,V,R)). +fix_root(red(L,K,V,R),black(L,K,V,R)). + + + % % How to fix if we have inserted on the left %