fix log(0.0) and log10(0.0) to be SICStus compatible.

git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1245 b08c6af1-5177-4d33-ba66-4b1c6b8b522a

C/arith1.c

@@ -343,12 +343,8 @@ p_log(Term t E_ARGS)
     }
   }
 
-  if (dbl > 0) {
+  if (dbl >= 0) {
     RFLOAT(log(dbl));
-  } else if (dbl == 0) {
-    Yap_Error(DOMAIN_ERROR_NOT_ZERO, t, "log(%f)", dbl);
-    P = (yamop *)FAILCODE;
-    RERROR();
   } else {
     Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t, "log(%f)", dbl);
     P = (yamop *)FAILCODE;
@@ -401,12 +397,8 @@ p_log10(Term t E_ARGS)
     }
   }
 
-  if (dbl > 0) {
+  if (dbl >= 0) {
     RFLOAT(log10(dbl));
-  } else if (dbl == 0) {
-    Yap_Error(DOMAIN_ERROR_NOT_ZERO, t, "log10(%f)", dbl);
-    P = (yamop *)FAILCODE;
-    RERROR();
   } else {
     Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t, "log10(%f)", dbl);
     P = (yamop *)FAILCODE;

C/attvar.c

@@ -79,7 +79,7 @@ CopyAttVar(CELL *orig, CELL ***to_visit_ptr, CELL *res)
   Int j;
 
   /* add a new attributed variable */
-  newv = (attvar_record *)Yap_ReadTimedVar(DelayedVars);
+  newv = DelayTop();
   if (H0 - (CELL *)newv < 1024+(2*NUM_OF_ATTS))
     return FALSE;
   RESET_VARIABLE(&(newv->Done));
@@ -113,7 +113,7 @@ CopyAttVar(CELL *orig, CELL ***to_visit_ptr, CELL *res)
   }
   *to_visit_ptr = to_visit;
   *res = (CELL)&(newv->Done);
-  Yap_UpdateTimedVar(DelayedVars, (CELL)(newv->Atts+2*j));
+  SetDelayTop(attv->Atts+2*j);
   return(TRUE);
 }
 
@@ -342,7 +342,7 @@ BuildNewAttVar(Term t, Int i, Term tatt)
   Term time;
   int j;
 
-  attvar_record *attv = (attvar_record *)Yap_ReadTimedVar(DelayedVars);
+  attvar_record *attv = DelayTop();
   if (H0 - (CELL *)attv < 1024+(2*NUM_OF_ATTS)) {
     return FALSE;
   }
@@ -356,7 +356,7 @@ BuildNewAttVar(Term t, Int i, Term tatt)
   }
   attv->NS = Yap_UpdateTimedVar(AttsMutableList, (CELL)&(attv->Done));
   Bind((CELL *)t,(CELL)attv);
-  Yap_UpdateTimedVar(DelayedVars,(CELL)(attv->Atts+2*j));
+  SetDelayTop(attv->Atts+2*j);
   /* avoid trouble in gc */
   /* if i < 0 then we have the list of arguments */
   if (i < 0) {

C/exec.c

@@ -1523,7 +1523,7 @@ Yap_InitYaamRegs(void)
   Yap_StartSlots();
 #if COROUTINING
   RESET_VARIABLE((CELL *)Yap_GlobalBase);
-  DelayedVars = Yap_NewTimedVar((CELL)Yap_GlobalBase);
+  DelayedVars = Yap_NewTimedVar(MkIntTerm(0));
   WokenGoals = Yap_NewTimedVar(TermNil);
   MutableList = Yap_NewTimedVar(TermNil);
   AttsMutableList = Yap_NewTimedVar(TermNil);

C/heapgc.c

@@ -21,6 +21,7 @@ static char     SccsId[] = "%W% %G%";
 #include "absmi.h"
 #include "yapio.h"
 #include "alloc.h"
+#include "attvar.h"
 
 
 #define EARLY_RESET 1
@@ -3335,13 +3336,13 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop)
   effectiveness = 0;
   gc_trace = FALSE;
 #if COROUTINING
-  max = (CELL *)Yap_ReadTimedVar(DelayedVars);
+  max = (CELL *)DelayTop();
-  if (H0 - max < 1024+(2*NUM_OF_ATTS)) {
+  while (H0 - max < 1024+(2*NUM_OF_ATTS)) {
     if (!Yap_growglobal(&current_env)) {
       Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
       return 0;
     }
-    max = (CELL *)Yap_ReadTimedVar(DelayedVars);
+    max = (CELL *)DelayTop();
   }
 #else
   max = NULL;
@@ -3404,7 +3405,7 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop)
     current_env = (CELL *)*ASP;
     ASP++;
 #if COROUTINING
-    max = (CELL *)Yap_ReadTimedVar(DelayedVars);
+    max = (CELL *)DelayTop();
 #endif
   }
 #endif
@@ -3427,7 +3428,7 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop)
       current_env = (CELL *)*ASP;
       ASP++;
 #if COROUTINING
-      max = (CELL *)Yap_ReadTimedVar(DelayedVars);
+      max = (CELL *)DelayTop();
 #endif
     }
     memset((void *)bp, 0, alloc_sz);

C/unify.c

@@ -467,7 +467,7 @@ unify_nvar:
 unify_nvar_nvar:
   /* both arguments are bound */
   if (d0 == d1)
-    return (TRUE);
+    return TRUE;
   if (IsPairTerm(d0)) {
     if (!IsPairTerm(d1)) {
       return (FALSE);
@@ -530,12 +530,12 @@ unify_var_nvar:
   if (pt0 < H0) Yap_WakeUp(pt0);
  bind_unify4:
 #endif
-  return (TRUE);
+  return TRUE;
 
 #if TRAILING_REQUIRES_BRANCH
 unify_var_nvar_trail:
   DO_TRAIL(pt0);
-  return (TRUE);
+  return TRUE;
 #endif
 
   deref_body(d1, pt1, unify_var_unk, unify_var_nvar);

C/utilpreds.c

@@ -23,6 +23,7 @@ static char     SccsId[] = "@(#)utilpreds.c	1.3";
 #include "Heap.h"
 #include "yapio.h"
 #include "eval.h"
+#include "attvar.h"
 
 typedef struct {
 	Term            old_var;
@@ -206,7 +207,7 @@ copy_complex_term(register CELL *pt0, register CELL *pt0_end, CELL *ptf, CELL *H
 	CELL **bp[1];
 
 	if (dvars == NULL) {
-	  dvars = (CELL *)Yap_ReadTimedVar(DelayedVars);
+	  dvars = (CELL *)DelayTop();
 	} 	
 	if (ptd0 >= dvars) {
 	  *ptf++ = (CELL) ptd0;
@@ -686,8 +687,10 @@ static Int
 p_copy_term_no_delays(void)		/* copy term t to a new instance  */
 {
   Term t = CopyTermNoDelays(ARG1);
-  if (t == 0L)
+  if (t == 0L) {
+    printf("Error\n");
     return FALSE;
+  }
   /* be careful, there may be a stack shift here */
   return(Yap_unify(ARG2,t));
 }

CLPBN/clpbn.yap

@@ -122,7 +122,9 @@ sort_vars_by_key(AVars,SortedAVars, UnifiableVars) :-
 
 get_keys([], []).
 get_keys([V|AVars], [K-V|KeysVars]) :-
-	get_atts(V, [key(K)]),
+	get_atts(V, [key(K)]), !,
+	get_keys(AVars, KeysVars).
+get_keys([V|AVars], KeysVars) :-  % may be non-CLPBN vars.
 	get_keys(AVars, KeysVars).
 
 merge_same_key([], [], _, []).
@@ -130,7 +132,7 @@ merge_same_key([K1-V1,K2-V2|Vs], SortedAVars, Ks, UnifiableVars) :-
 	K1 == K2, !, V1 = V2,
 	merge_same_key([K1-V1|Vs], SortedAVars, Ks, UnifiableVars).
 merge_same_key([K1-V1,K2-V2|Vs], [V1|SortedAVars], Ks, [K1|UnifiableVars]) :-
-	(in_keys(K1, Ks) ; \+ \+ K1 = K2), !, 
+	(in_keys(K1, Ks) ; \+ \+ K1 == K2), !, 
 	add_to_keys(K1, Ks, NKs),
 	merge_same_key([K2-V2|Vs], SortedAVars, NKs, UnifiableVars).
 merge_same_key([K-V|Vs], [V|SortedAVars], Ks, UnifiableVars) :-
@@ -219,27 +221,29 @@ bind_clpbn(T, Var, Key, Domain, Table, Parents) :- var(T),
 	    bind_evidence_from_extra_var(Ev,T)
 	;
 	  true).
-bind_clpbn(_, Var, _, _) :-
+bind_clpbn(_, Var, _, _, _, _) :-
 	use(bnt),
 	check_if_bnt_done(Var), !.
-bind_clpbn(_, Var, _, _) :-
+bind_clpbn(_, Var, _, _, _, _) :-
 	use(vel),
 	check_if_vel_done(Var), !.
-bind_clpbn(T, Var, Key0, _) :-
+bind_clpbn(T, Var, Key0, _, _, _) :-
 	get_atts(Var, [key(Key0)]), !,
 	(
 	  Key = Key0 -> true
 	;
-	  format(user_error, "trying to force evidence ~w through unification with key ~w~n",[T, Key])
+	  add_evidence(Var,T)
 	).
 
 fresh_attvar(Var, NVar) :-
 	get_atts(Var, LAtts),
 	put_atts(NVar, LAtts).
 
+% I will now allow two CLPBN variables to be bound together.
+%bind_clpbns(Key, Domain, Table, Parents, Key, Domain, Table, Parents).
 bind_clpbns(Key, Domain, Table, Parents, Key1, Domain1, Table1, Parents1) :- 
 	Key == Key1, !,
-	( Domain == Domain1, Table == Table1, Parents == Parents1 -> true ; throw(error(domain_error(bayesian_domain),bind_clpbns))).
+	( Domain == Domain1, Table == Table1, Parents == Parents1 -> true ; throw(error(domain_error(bayesian_domain),bind_clpbns(var(Key, Domain, Table, Parents),var(Key1, Domain1, Table1, Parents1))))).
 bind_clpbns(_, _, _, _, _, _, _, _) :-
 	format(user_error, "unification of two bayesian vars not supported~n").
 

CLPBN/clpbn/utils.yap

@@ -14,6 +14,7 @@ check_for_hidden_vars([V|Vs], AllVs0, [V|NVs]) :-
 	check_for_hidden_vars(IVs, AllVs, NVs).
 
 check_for_extra_variables(V,AllVs0, AllVs, Vs, IVs) :-
+	var(V),
 	clpbn:get_atts(V, [dist(_,_,[V1|LV])]), !,
 	add_old_variables([V1|LV], AllVs0, AllVs, Vs, IVs).
 check_for_extra_variables(_,AllVs, AllVs, Vs, Vs).

CLPBN/clpbn/vel.yap

@@ -39,7 +39,8 @@ check_if_vel_done(Var) :-
 	get_atts(Var, [size(_)]), !.
 
 vel(LVs0,Vs0,AllDiffs) :-
-	get_rid_of_ev_vars(LVs0,LVs),
+	sort(LVs0,LVs1),
+	get_rid_of_ev_vars(LVs1,LVs),
 	do_vel(LVs,Vs0,AllDiffs).
 	       
 do_vel([],_,_) :- !.

H/attvar.h

@@ -54,6 +54,16 @@ typedef struct attvar_struct {
 #define AbsAttVar(attvar_ptr)	AbsAppl(((CELL *)(attvar_ptr)))
 #define RepAttVar(val)		((attvar_record *)RepAppl(val))
 
+static inline attvar_record *
+DelayTop(void) {
+  return (attvar_record *)((CELL *)Yap_GlobalBase+IntegerOfTerm(Yap_ReadTimedVar(DelayedVars)));
+}
+
+static inline void
+SetDelayTop(CELL *new_top) {
+  Yap_UpdateTimedVar(DelayedVars, MkIntegerTerm((CELL)(new_top-(CELL *)Yap_GlobalBase)));
+}
+
 #endif
 
 

docs/yap.tex

@@ -7319,6 +7319,13 @@ Holds when the two ordered sets have at least one element in common.
 Holds when Intersection is the ordered representation of @var{Set1}
 and @var{Set2}.
 
+@item ord_intersection(+@var{Set1}, +@var{Set2}, ?@var{Intersection}, ?@var{Diff})
+@findex ord_intersect/4
+@syindex ord_intersect/4
+@cnindex ord_intersect/4
+Holds when Intersection is the ordered representation of @var{Set1}
+and @var{Set2}. @var{Diff} is the diffference between @var{Set2} and @var{Set1}.
+
 @item ord_seteq(+@var{Set1}, +@var{Set2})
 @findex ord_seteq/2
 @syindex ord_seteq/2

library/ordsets.yap

@@ -184,7 +184,7 @@ ord_intersection([Head1|Tail1], [Head2|Tail2], Intersection, Difference) :-
 
 ord_intersection(=, Head,  Tail1, _,     Tail2, [Head|Intersection], Difference) :-
 	ord_intersection(Tail1, Tail2, Intersection, Difference).
-ord_intersection(<, Head1,     Tail1, Head2, Tail2, Intersection, [Head1|Difference]) :-
+ord_intersection(<, Head1,     Tail1, Head2, Tail2, Intersection, Difference) :-
 	ord_intersection(Tail1, [Head2|Tail2], Intersection, Difference).
 ord_intersection(>, Head1, Tail1, Head2,  Tail2, Intersection, [Head2|Difference]) :-
 	ord_intersection([Head1|Tail1], Tail2, Intersection, Difference).

pl/corout.yap

@@ -546,11 +546,22 @@ frozen(V, LG) :-
 
 
 call_residue(Goal,Residue) :-
+	var(Goal), !,
+	'$do_error'(instantiation_error,call_residue(Goal,Residue)).
+call_residue(Module:Goal,Residue) :-
+	atom(Module), !,
+	'$call_residue'(Goal,Module,Residue).
+call_residue(Goal,Residue) :-
+	'$current_module'(Module),
+	'$call_residue'(Goal,Module,Residue).
+	
+'$call_residue'(Goal,Module,Residue) :-
 	'$read_svar_list'(OldAttsList),
 	'$copy_term_but_not_constraints'(Goal, NGoal),
 	(  create_mutable([], CurrentAttsList),
           '$set_svar_list'(CurrentAttsList),
-	  '$execute'(NGoal),
+	  '$system_catch'(NGoal,Module,Error,'$residue_catch_trap'(Error,OldAttsList)),
+
 	    '$call_residue_continuation'(NGoal,NResidue),
 	    ( '$set_svar_list'(OldAttsList),
 		'$copy_term_but_not_constraints'(NGoal+NResidue, Goal+Residue)
@@ -561,6 +572,11 @@ call_residue(Goal,Residue) :-
           '$set_svar_list'(OldAttsList), fail
         ).
 
+% make sure we set the suspended goal list to its previous state!
+'$residue_catch_trap'(Error,OldAttsList) :-
+	'$set_svar_list'(OldAttsList),
+	throw(Error).
+
 %
 % goal needs to be in a different procedure to catch suspended goals.
 %
@@ -600,6 +616,7 @@ call_residue(Goal,Residue) :-
 	'$undefined'(modules_with_attributes(LAV),attributes), !,
 	'$fetch_delays'(Vs, LGs, []).
 '$project'([V|LAV],LIV,LDs) :-
+	attvar(V), !,
 	attributes:modules_with_attributes(LMods),
 	'$pick_vars_for_project'(LIV,NLIV),
 	'$project_module'(LMods,NLIV,[V|LAV]),
@@ -634,11 +651,11 @@ call_residue(Goal,Residue) :-
 	
 '$do_convert_att_vars'([], _, []).
 '$do_convert_att_vars'([V|LAV], LIV, NGs) :-
-	var(V),
+	attvar(V),
 	attributes:convert_att_var(V,G),
-	'$do_not_creep',
 	G \= true,
 	!,
+	'$do_not_creep',
 	'$split_goals_for_catv'(G,V,NGs,IGs),
 	'$do_convert_att_vars'(LAV, LIV, IGs).
 '$do_convert_att_vars'([_|LAV], LIV, Gs) :-