diogo
/
yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

some nice extra predicatesy 

git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@2273 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2008-06-11 11:08:25 +00:00
parent c1f9fc9bcf
commit 02565ae625
2 changed files with 169 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

121
C/arrays.c
View File

@ -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);

55
library/rbtrees.yap
View File

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