add a few missing files

parent ddae7f0f
(compile-prolog-string "
cat(F,G) :-
catch(F,Er,
(
tfc(Er),
(
Er==#t -> throw(bug_should_not_throw_true) ;
Er==#f -> throw(bug_should_not_throw_cut) ;
G
)
)).
collect_disj([],U,U).
collect_disj(['*->'(A,B)|L],U,UU) :-
U=['soft-if-f'(A,B,';'(|L))|UU].
collect_disj(['-i>'(A,B)|L],U,UU) :-
U=['interleaving-if-f'(A,B,';'(|L))|UU].
collect_disj([X|L],U,UU) :-
collect_disjunction(X,U,U1),
collect_disj(L,U1,UU).
collect_disjunction(X,[X|UU],UU) :- var(X),!.
collect_disjunction(';'(|L),U,UU) :- !,
collect_disj(L,U,UU).
collect_disjunction(X,[X|UU],UU).
%head_at_true(First,Last,A,C,Lab,Lab2,L1,LLX)
head_at_true(Q,#t,_,A,C,Lab,Lab2,L1,LLX) :- L1=LLX, Lab2=Lab.
head_at_true(Q,#t,_,A,C,Lab,Lab2,L1,LLX) :- L1=LLX, Lab2=Lab.
head_at_true(Q,#f,#f,A,C,Lab,Lab2,L1,LLX) :-
(var(Q) -> tr('unwind-light',Unwind) ; tr(unwind,Unwind)),
L1=[[label,Lab,U],[Unwind,A,Lab2]|LLX].
head_at_true(Q,#f,#t,A,C,Lab,Lab2,L1,LLX) :-
(var(Q) -> tr('unwind-light-tail',Unwind) ; tr('unwind-tail',Unwind)),
L1=[[label,Lab,U],[Unwind,A]|LLX].
compile_disjunction0
([X],First,Aq,Ae,Out,Lab,A,Tail,S0,[U],V,[L,LL]) :- !,
(First=#t -> compile_goal(X,First,V,[L,LL]) ;
catch((
read_Q(V,Qit),
pop_Q(V,_),
get_CES(V,[C|_],E,S),
set_AES(V,Aq,0,S0),
(
((nonvar(X),X=(G1->G2)) -> XX=(G1,softie(A),G2) ; XX=X),
compile_goal(XX,Tail,V,[LX,LL]),
get_ACES(V,Aq1,[C1|_],E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
(
eql_a(Ae,Aq1) -> true ;
throw(all_disjuction_goals_needs_the_same_begin_level)
),
SS is max(S,S1),
EE is E \\/ E1,
set_AES(V,Aq,EE,SS),
U = [E1,_],
head_at_true(Qit,First,#t,A,C,Lab,Lab2,L,LX)
)),Er,
(
tfc(Er),
(
Er == #t ->
(
First==#t ->
throw(#t) ;
head_at_true(Qit,#f,#t,A,C,Lab,Lab2,L,LL)
);
Er == c ->
throw(c) ;
throw(#f)
)
))).
goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,LLX) :-
read_Q(V,Qit),
get_CES(V,[C|_],E,S),
set_AES(V,Aq,0,S0),
((nonvar(X),X=(G1->G2)) ->
XX=(G1,softie(A),collect_F(FF),G2) ;
(XX=(X,newtag_F(FF)))),
compile_goal(XX,Tail,V,[LX,LG]),
(var(FF) -> true ; set_F(V,FF)),
get_ACES(V,A1q,[C1|_],E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
S2 is max(S,S1),
E2 is E \\/ E1,
U = [E1,_],
set_ES(V,E2,S2),
(
First == #t ->
(
A1q=Ae
);
(
set_F(V,scm[(gensym \"tag\")]),
(Ae == A1q -> true ;
throw(all_disjuction_goals_needs_the_same_begin_level))
)
),
ifc(compile_disjunction0(Y,#f,Aq,Ae,Out,Lab2,A,Tail,S0,UU,V,[LLX,LL]),Err,
(
(
Err==#t ->
throw(bug_true_not_be_send_in_non_first_disjunction);
(
pop_Q(V,_),
head_at_true(Qit,First,#f,A,C,Lab,Lab2,L,LX),
Err==c ->
LLX=[[cut],[fail]|LL];
LLX=LL
)
)
),
head_at_true(Qit,First,#f,A,C,Lab,Lab2,L,LX)
).
compile_disjunction0([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,U,V,[L,LL]) :- !,
tr('goto-inst',Goto),
read_Q(V,Qit),
(Tail==#t -> LG=LLX ; LG = [[Goto,Out]|LLX]),
catch(goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,U,V,L,LL,LG,LLX), Er,
(
tfc(Er),
(Tail==#t -> LLG = [[cc]|LG] ; LLG=LG),
(
Er==c ->
throw(c) ;
Er==#t ->
(
U = [E1,_],
ifc(compile_disjunction0
(Y,#f,Aq,Aq,Out,Lab2,A,Tail,S0,UU,V,[LLX,LL]),Er2,
(
tfc(Er2),
(
Er2==#f ->
(
First = #t ->
throw(#t);
(
head_at_true(Qit,#f,#t,A,C,Lab,Lab2,L,LLG),
LLX=LL
)
);
throw(bug_should_not_throw_true_or_cut)
)
),
(
(First==#t -> true ;
(Aq==Ae -> true ;
throw(syntax_error_begin_en_missmatch))),
head_at_true(Qit,First,#f,A,C,Lab,Lab2,L,LG)
)));
compile_disjunction0(Y,First,Aq,Ae,Out,Lab,A,Tail,S0,U,V,[L,LL])
)
)).
compile_disjunction(Y,First,Aq,Ae,Out,Lab,A,Tail,S0,U,V,[L,LL]) :-
catch(compile_disjunction0(Y,First,Aq,Ae,Out,Lab,A,Tail,S0,U,V,[L,LL]),Er,
(
tfc(Er),
(
Er=softie(_) -> throw(#f) ; throw(Er)
)
)).
")
(define-module (logic guile-log guile-prolog vm vm-disj2)
#:use-module (logic guile-log)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log prolog swi)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log soft-cut)
#:use-module (logic guile-log guile-prolog vm-compiler)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:export (compile_disj compile_disjunction collect_disj))
#;
(eval-when (compile)
(prolog-run-rewind 1 (x)
(dyntrace (@@ (logic guile-log guile-prolog vm vm-handle)
handle))))
(compile-prolog-string
"
- eval_when(compile).
the_tr2(X,[X]).
:- add_term_expansion_temp(the_tr2).
")
(include-from-path "logic/guile-log/guile-prolog/vm/vm-disj-model.scm")
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment