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

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

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1245 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2005-02-18 21:34:02 +00:00
parent 755c60a7ca
commit 18f0de5486
13 changed files with 76 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
C/arith1.c
View File

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

8
C/attvar.c
View File

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

2
C/exec.c
View File

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

11
C/heapgc.c
View File

@ -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);
if (H0 - max < 1024+(2*NUM_OF_ATTS)) {
max = (CELL *)DelayTop();
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);

6
C/unify.c
View File

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

7
C/utilpreds.c
View File

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

18
CLPBN/clpbn.yap
View File

@ -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").

1
CLPBN/clpbn/utils.yap
View File

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

3
CLPBN/clpbn/vel.yap
View File

@ -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([],_,_) :- !.

10
H/attvar.h
View File

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

7
docs/yap.tex
View File

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

4
library/ordsets.yap
View File

@ -184,9 +184,9 @@ 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, Head2, Tail2, Intersection, [Head2|Difference]) :-
ord_intersection([Head1|Tail1], Tail2, Intersection, Difference).

27
pl/corout.yap
View File

@ -546,14 +546,25 @@ 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),
'$call_residue_continuation'(NGoal,NResidue),
'$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)
'$copy_term_but_not_constraints'(NGoal+NResidue, Goal+Residue)
;
'$set_svar_list'(CurrentAttsList), fail
)
@ -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) :-