disjunction works with new begin end refactorisation

parent c544d697
......@@ -117,9 +117,11 @@ PSSOURCES = \
logic/guile-log/guile-prolog/coroutine.scm \
logic/guile-log/guile-prolog/attributator.scm \
logic/guile-log/guile-prolog/vm/vm-pre.scm \
logic/guile-log/guile-prolog/vm/vm-var.scm \
logic/guile-log/guile-prolog/vm/vm-scm.scm \
logic/guile-log/guile-prolog/vm/vm-args.scm \
logic/guile-log/guile-prolog/vm/vm-handle.scm \
logic/guile-log/guile-prolog/vm/vm-disj.scm \
logic/guile-log/guile-prolog/vm/vm-imprint.scm \
logic/guile-log/guile-prolog/vm/vm-unify.scm \
logic/guile-log/guile-prolog/vm/vm-goal.scm \
......
......@@ -6,12 +6,13 @@
#:use-module (logic guile-log prolog swi)
#:use-module (logic guile-log vlist)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (logic guile-log guile-prolog vm vm-goal)
#:use-module (system vm assembler)
#:export (compilable_scm collect_data compile_goal pretty instr
#:re-export (compile_goal begin_att end_att imprint)
#:export (compilable_scm collect_data pretty instr
make-vm-function
imprint compile_to_fkn
begin_att end_att))
compile_to_fkn))
#|
The question is if we can design a system for prolog programs
......
......@@ -5,6 +5,7 @@
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log prolog swi)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:export (caller push_args_args2 push_args_args push_args))
......
......@@ -7,7 +7,8 @@
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:export (compile_disj compile_disjunction collect_disjunction))
#:use-module (logic guile-log guile-prolog vm vm-var)
#:export (compile_disj compile_disjunction collect_disj))
(compile-prolog-string "
collect_disj([],U,U).
......@@ -21,23 +22,21 @@ collect_disjunction(';'(|L),U,UU) :- !,
collect_disjunction(X,[X|UU],UU).
tail(Tail,LL,LLL) :-
Tail = #t ->
(tr(cc,CC),LLL=[[CC]|LL]) ;
LLL=LL.
compile_disjunction
([X],First,Out,Es,Lab,A,Tail,S0,[U],
[[A,AA],[C,CC],[E,EE],[M,MM],[S,SS],[B,BB],H],[L,LL]) :- !,
compile_goal(X,Tail,[[A,A1],[C,C1],[0,E1],[M,MM],[A,S1],[B,BB],H],[LX,LL]),
(A == A1 -> AA=A ; throw(all_disjuction_goals_needs_the_same_begin_level)),
([X],First,Out,Lab,A,Tail,S0,[U],
[[Aq,AAq],[C,CC],[E,EE],[M,MM],[S,SS],[B,BB],H],[L,LL]) :- !,
compile_goal(X,Tail,[[Aq,Aq1],[C,C1],[0,E1],[M,MM],[A,S1],[B,BB],H],[LX,LL]),
(
Aq == Aq1 -> AAq=Aq ;
throw(all_disjuction_goals_needs_the_same_begin_level)
),
SS is max(S,S1),
EE is E \\/ E1,
U = [E1,_],
tr('unwind-tail',UnwindTail),
L=[[label,Lab,U],[UnwindTail,A,0] | LX].
compile_disjunction([X|Y],First,Out,Es, Lab,A,Tail,S0,[U|UU],V,[L,LL]) :- !,
compile_disjunction([X|Y],First,Out, Lab,A,Tail,S0,[U|UU],V,[L,LL]) :- !,
tr('goto-inst',Goto),
V = [[Aq,AAq],[C,CC],[E,EE],[M,MM],[S,SS],[B,BB],H],
(Tail==#t -> LG=LLX ; LG = [[Goto,Out]|LLX]),
......@@ -52,7 +51,7 @@ compile_disjunction([X|Y],First,Out,Es, Lab,A,Tail,S0,[U|UU],V,[L,LL]) :- !,
(
A2q=A1q,
L = [[label,_,U]|LX],
compile_disjunction(Y,#f,Out,[U|Es],Lab,A,Tail,S0,UU,VV,LQ)
compile_disjunction(Y,#f,Out,Lab,A,Tail,S0,UU,VV,LQ)
) ;
(
(
......@@ -61,7 +60,7 @@ compile_disjunction([X|Y],First,Out,Es, Lab,A,Tail,S0,[U|UU],V,[L,LL]) :- !,
),
label(Lab2),tr(unwind,Unwind),
L = [[label,Lab,U],[unwind,A,Lab2,0]|LX],
compile_disjunction(Y,#f,Out,[U|Es],Lab2,A,Tail,S0,UU,VV,LQ)
compile_disjunction(Y,#f,Out,Lab2,A,Tail,S0,UU,VV,LQ)
)
).
")
......@@ -5,15 +5,16 @@
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log prolog swi)
#:use-module (compat racket misc)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (logic guile-log guile-prolog vm vm-args)
#:use-module (logic guile-log guile-prolog vm vm-unify)
#:use-module (logic guile-log guile-prolog vm vm-imprint)
#:use-module (logic guile-log guile-prolog vm vm-scm)
#:use-module (logic guile-log guile-prolog vm vm-disj)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-handle)
#:use-module (system vm assembler)
#:re-export (compile_goal))
#:export (begin_att end_att))
(compile-prolog-string "
reverse_op(<,>).
......@@ -28,7 +29,7 @@ reverse_op(=:=,=:=).
reverse_op(=\\=,=\\=).
touch_A([[[[_,_,#t]|_],_] |_]).
zero([[[[0|_]],_]|_]).
-extended(',',m_and,;,m_or,\\+,m_not).
compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
(
......@@ -42,7 +43,7 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
(var(Constants) -> init_const ; true),
b_setval(pretty,#t),
compile_goal(Code,#t,
[[[0,_,_],_],[0,_],[0,E],[0,StackSize],[0,_],[0,_],[HC,HV]],[L,[]]),!,
[[[[0,_,_]],_],[0,_],[0,E],[0,StackSize],[0,_],[0,_],[HC,HV]],[L,[]]),!,
handle_all(L,LL),
(var(Constants)->Constants=scm[(get-consts)];true),
write(LL),nl,
......@@ -60,8 +61,8 @@ compile_goal(begin_att,Tail,V,[L,LL]) :- !,
Tail==#t -> (L=LLL, equal_v(V)) ;
(
V = [[A,AA]|Vs],
A = [Ai ,Ax , At ],
AA = [AAi,AAx, AAt],
A = [[Ai ,Ax , At ] | _],
AA = [[AAi,AAx, AAt] | A],
AAi is Ai + 1,
link_v(V,V1,V2),
add_var(AAx,V1,Tagx),
......@@ -71,12 +72,13 @@ compile_goal(begin_att,Tail,V,[L,LL]) :- !,
V2 = [[A,AA]|Vs2],
push_v(0,Vs2),
tr('pre-unify',Pre),
L = [[Pre,Tagx,Tagi,At]|LL]
L = [[Pre,Tagx,Tagi,AAt]|LL]
)
).
compile_goal(end_att,Tail,V,[L,LL]) :- !,
V = [[[[Ai,Ax,At]|AA],AA]|Vs],
(Ai==0 -> throw(missmatching_begin_end_pair) ; true),
(At==#t -> add_var(Ax,V,Tag) ; add_var(Ai,V,Tag)),
push_v(0,Vs),
(Tail==#t -> tr('post-unify-tail',Post) ; tr('post-unify',Post)),
......@@ -97,7 +99,7 @@ compile_goal((F(|Args) :- Goal),Tail,V,L) :- !,
NN is N + 4,
push_vv(NN,V1),
(
V=[[[0|_],_]|_] ->
V=[[[[0|_]|_],_]|_] ->
compile_goal((begin_att,Impr,end_att,pop(4),Goal),Tail,V2,L);
compile_goal((begin_att,Impr,pop(4),Goal),Tail,V2,L)
).
......@@ -120,15 +122,15 @@ compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
XX=[Z] -> compile_goal(Z,Tail,V,[L,LL]) ;
(
touch_A(V),
V = [[A,AA],[C,C],[E,EE],[M,MM],[A,SS],[B,BB],H],
V = [Aq,[C,C],[E,EE],[M,MM],[A,SS],B,H],
label(Lab),label(Out),tr(newframe,Newframe),
S2 is A + 2,
M1 is max(M,S2),
L = [[Newframe,Lab,0] | LX],
VV = [[A,AA],[C,_],[0,Ed],[M1,MM],[S2,SS],[B,BB],H],
VV = [Aq,[C,_],[0,Ed],[M1,MM],[S2,SS],B,H],
LM = [LX, [[label,Out] | LL]],
compile_disjunction(XX,#t,Out,[],Lab,A,Tail,S2,U,VV,LM),
add_missing_variables(H,U,Ed,EEd),
compile_disjunction(XX,#t,Out,Lab,A,Tail,S2,U,VV,LM),
add_missing_variables(H,U,Ed,Ed,EEd),
EE is E \\/ EEd
)
).
......@@ -256,7 +258,7 @@ compile_goal(X is Y,Tail,V,[L,LL]) :- !,
).
compile_goal(unify_with_occurs_check(X,Y),Tail,V,L) :- !,
V=[[0,_]|_] ->
zero(V) ->
compile_goal((begin_att,uni_0(X,Y),end_att),Tail,V,L);
compile_goal(uni_0(X,Y),Tail,V,L).
......@@ -265,7 +267,7 @@ compile_goal(uni_0(X,Y),Tail,V,[L,LL]) :- !,
compile_unify(X,Y,V,[L,LLL],0).
compile_goal(X = Y,Tail,V,L) :- !,
V=[[0,_]|_] ->
zero(V) ->
compile_goal((begin_att,uni_x(X,Y),end_att),Tail,V,L);
compile_goal(uni_x(X,Y),Tail,V,L).
......@@ -274,7 +276,7 @@ compile_goal(uni_x(X,Y),Tail,V,[L,LL]) :- !,
compile_unify(X,Y,V,[L,LLL],#t).
compile_goal(X = Y,Tail,V,L) :- !,
V=[[0,_]|_] ->
zero(V) ->
compile_goal((begin_att,uni(X,Y),end_att),Tail,V,L);
compile_goal(uni(X,Y),Tail,V,L).
......@@ -306,3 +308,6 @@ ncons(X,N) :-
ncons(X,0,N).
")
(set! (@@ (logic guile-log guile-prolog vm vm-var) compile_goal)
compile_goal)
......@@ -6,6 +6,7 @@
#:use-module (logic guile-log prolog swi)
#:use-module (compat racket misc)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (system vm assembler)
#:export (handle_all))
......
......@@ -7,6 +7,7 @@
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:export (compile_imprint))
(compile-prolog-string "
......
......@@ -7,7 +7,7 @@
#:use-module (logic guile-log vlist)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:replace (tr first)
#:replace (tr)
#:export ())
(define unify_operators '((";" ";") ("," ",") ("\\+" "\\+")
......@@ -94,65 +94,6 @@
(warn (format #f "could not lookup symbol ~a" id))
-1))))
(compile-prolog-string
"
reference([_,V,_]) :-
(var(V) -> set(V,1) ; (VV is V + 1, set(V,VV))).
first([_,_,#t]).
force_variable([[#t,_],_,_]).
new_tag([HC,HV],X,Tag,Etag) :-
new_e(Etag),
X=[_,_],
Tag=[X,_,_],
vhashq_cons (HV,Tag,Etag),
vhashql_cons (HC,Etag,Tag).
get_e_tag(X,[HC,HV],Ex,Tag,Etags) :-
(
vhashq_ref(HV,X,[XX,E,Etags])
-> true ;
(
Etags=0,
new_e(E),
vhashq_cons(HV,X,[XX,E,Etags]),
vhashql_cons(HC,E,X)
)
),
new_tag([HC,HV],XX,Tag,Etag),
EE is Etags \\/ Etag,
Ex is E \\/ Etag,
set(Etags,EE).
-extended.
get_tags_from_bits(H,0,[]) :- !.
get_tags_from_bits((H,[HC,HV]),N,LL) :-
maskoff(N,E,NN),
(vhash_ref(HC,E,X) ->
(LL=[X|L],get_tags_from_bits(H,NN,L)) ;
get_tags_from_bits(H,NN,LL)).
m(F,[X|L]) :- F(X),m(F,L).
m(_,[]).
add_var(X,V,Tag) :-
add_var(X,0,V,Tag).
add_var(X,S,[[A,AA],[C,C],[E,EE],[M,MM],[St,SSt],[B,BB],H],Tag) :-
get_e_tag(X,H,Ex,Tag,Etags),
EE is E \\/ Ex,
BB is B \\/ Ex,
reference(Tag),
(0 =:= Ex /\\ S -> true ; force_variable(Tag)),
(0 =:= Ex /\\ B -> first(Tag) ; true),
Edeps is Etags /\\ B,
get_tags_from_bits(H,Edeps,Deps),
m(reference,Deps).
")
(eval-when (compile load eval)
(begin
(define ncode 0)
......@@ -287,7 +228,11 @@ un('op1_-').
un('op1_+').
un(\\).
un(ᶜ).
")
(compile-prolog-string
"
trit(X,Y) :- b_setval(pretty,#f), tr(X,Y).
instruction(X) :- nonvar(X),(X=[] ; number(X) ; string(X)).
constant(X) :- atom(X), \\+instruction(X).
......@@ -320,64 +265,6 @@ push_vv(N,[[A,A],[C,C],[E,E],[M,MM],[S,SS],[B,B],H]) :-
push_vv(N,[[C,C],[E,E],[M,MM],[S,SS],[B,B],H]) :-
SS is S + N,
MM is max(M,SS).
find_all_tags(H,0 ,[]).
find_all_tags(H,Es,L) :-
H=[HC,HV],
maskoff(Es,E,EEs),
vhashql_ref(HC,E,V),
(
var(V) -> find_all_tags(H,EEs,L) ;
V=[_,_,_] -> (L=[V|LL], find_all_tags(H,EEs,LL));
find_all_tags(H,EEs,L)
).
add_miss(_,[],[],E,E).
add_miss(H,[[X,N,C]|Xs],Ys,E,EE) :-
C==#t ->
(
new_tag(H,X,Tag,Etag),
first(Tag),
E1 is E \\/ Etag,
Ys=[Tag|YYs],
add_miss(H,Xs,YYs,E1,EE)
) ;
add_miss(H,Xs,Ys,E,EE).
add_missing_variables(_,[],E,E).
add_missing_variables(H,[[E,V]|Es],EE,EEE) :-
Ex is EE /\\ \\E,
find_all_tags(H,Ex,Tags),
add_miss(H,Tags,V,EE,EE2),
add_missing_variables(H,Es,EE2,EEE).
addvs([],I,I,L,L).
addvs([[[S,V],N,F]|Tags],I,II,L,LL) :-
N==1 -> addvs(Tags,I,II,L,LL) ;
(
new_var(V),
L=[[newvar,V]|LL],
II is I + 2
).
mmtr([],[]).
mmtr([[X|Y]|LA],[[XX|Y]|LB]) :-
(tr(X,XX);binop(X,XX);unop(X,XX)),
mmtr(LA,LB).
mg(E,X,_,_,_) :-
var(X) -> throw(predicate_must_have_proper_tail(E)).
mg(E,[],true,N,N).
mg(E,[X],imprint(X,0),I,N) :- !, N is I + 1.
mg(E,[X|L],(imprint(X,0),U),I,N) :-
II is I + 1,
mg(E,L,U,II,N).
listp(X) :- var(X) -> (!, fail).
listp([X|Y]) :- listp(Y).
listp([]).
compile_goal.
")
(all-defined-out)
(define-module (logic guile-log guile-prolog vm-scm)
(define-module (logic guile-log guile-prolog vm vm-scm)
#:use-module (logic guile-log)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log guile-prolog hash)
......@@ -6,7 +6,7 @@
#:use-module (logic guile-log prolog swi)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:export (compile_scm))
(compile-prolog-string
......
......@@ -7,6 +7,7 @@
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (logic guile-log guile-prolog vm vm-imprint)
#:export (compile_unify))
......
(define-module (logic guile-log guile-prolog vm vm-var)
#: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 (logic guile-log vlist)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:replace (first)
#:export ())
(compile-prolog-string
"
reference([_,V,_]) :-
(var(V) -> set(V,1) ; (VV is V + 1, set(V,VV))).
first([_,_,#t]).
force_variable([[#t,_],_,_]).
new_tag([HC,HV],X,Tag,Etag) :-
new_e(Etag),
X=[_,_],
Tag=[X,_,_],
vhashq_cons (HV,Tag,Etag),
vhashql_cons (HC,Etag,Tag).
get_e_tag(X,[HC,HV],Ex,Tag,Etags) :-
(
vhashq_ref(HV,X,[XX,E,Etags])
-> true ;
(
Etags=0,
new_e(E),
vhashq_cons(HV,X,[XX,E,Etags]),
vhashql_cons(HC,E,X)
)
),
new_tag([HC,HV],XX,Tag,Etag),
EE is Etags \\/ Etag,
Ex is E \\/ Etag,
set(Etags,EE).
-extended.
get_tags_from_bits(H,0,[]) :- !.
get_tags_from_bits((H,[HC,HV]),N,LL) :-
maskoff(N,E,NN),
(vhash_ref(HC,E,X) ->
(LL=[X|L],get_tags_from_bits(H,NN,L)) ;
get_tags_from_bits(H,NN,LL)).
m(F,[X|L]) :- F(X),m(F,L).
m(_,[]).
add_var(X,V,Tag) :-
add_var(X,0,V,Tag).
add_var(X,S,[[A,AA],[C,C],[E,EE],[M,MM],[St,SSt],[B,BB],H],Tag) :-
get_e_tag(X,H,Ex,Tag,Etags),
EE is E \\/ Ex,
BB is B \\/ Ex,
reference(Tag),
(0 =:= Ex /\\ S -> true ; force_variable(Tag)),
(0 =:= Ex /\\ B -> first(Tag) ; true),
Edeps is Etags /\\ B,
get_tags_from_bits(H,Edeps,Deps),
m(reference,Deps).
find_all_vars(H,0 ,[]).
find_all_vars(H,Es,L) :-
H=[HC,HV],
maskoff(Es,E,EEs),
vhashql_ref(HC,E,V),
(
var(V) -> (L=[V|LL] , find_all_vars(H,EEs,LL));
find_all_vars(H,EEs,L)
).
add_miss(_,[],[],E,E).
add_miss(H,[V|Xs],Ys,E,EE) :-
new_tag(H,V,Tag,Etag),
first(Tag),
reference(Tag),
E1 is E \\/ Etag,
Ys=[Tag|YYs],
add_miss(H,Xs,YYs,E1,EE).
add_missing_variables(_,[],_,E,E).
add_missing_variables(H,[[E,V]|Es],EE,Ein,Eout) :-
Ex is EE /\\ \\E,
find_all_vars(H,Ex,Vars),
add_miss(H,Vars,V,Ein,EE2),
add_missing_variables(H,Es,EE,EE2,Eout).
addvs([],I,I,L,L).
addvs([[[S,V],N,F]|Tags],I,II,L,LL) :-
N==1 -> addvs(Tags,I,II,L,LL) ;
(
new_var(V,S),
tr(newvar,Newvar),
L2=[[newvar,V]|LL],
I2 is I + 2,
addvs(Tags,I2,II,L2,LL)
).
mmtr([],[]).
mmtr([[X|Y]|LA],[[XX|Y]|LB]) :-
(tr(X,XX);binop(X,XX);unop(X,XX)),
mmtr(LA,LB).
mg(E,X,_,_,_) :-
var(X) -> throw(predicate_must_have_proper_tail(E)).
mg(E,[],true,N,N).
mg(E,[X],imprint(X,0),I,N) :- !, N is I + 1.
mg(E,[X|L],(imprint(X,0),U),I,N) :-
II is I + 1,
mg(E,L,U,II,N).
listp(X) :- var(X) -> (!, fail).
listp([X|Y]) :- listp(Y).
listp([]).
tail(Tail,LL,LLL) :-
Tail = #t ->
(tr(cc,CC),LLL=[[CC]|LL]) ;
LLL=LL.
")
(define compile_goal #f)
(all-defined-out)
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