improving

parent eb74dbfe
......@@ -128,6 +128,7 @@ PSSOURCES = \
logic/guile-log/guile-prolog/vm/vm-unify.scm \
logic/guile-log/guile-prolog/vm/vm-goal.scm \
logic/guile-log/guile-prolog/vm-compiler.scm \
logic/guile-log/guile-prolog/vm/vm-disj2.scm \
logic/guile-log/examples/kanren/type-inference.scm \
logic/guile-log/imatch.scm \
prolog-user.scm \
......
......@@ -318,6 +318,7 @@ generate_stx(STX,X,F) :-
(apply gg x)))))
n)))))))
(define (mockalambda source? s pat code)
(let* ((Cut (gp-var! s))
(SCut (gp-var! s))
......@@ -334,7 +335,7 @@ generate_stx(STX,X,F) :-
(prolog-run-rewind
1 (meta)
(compile_to_meta source? all meta))))
(if (pair? comp)
(if (pk 'pair (pair? comp))
#`(lambda ()
(let ((f #,(car comp)))
(lambda (s p cc cut scut x)
......
......@@ -11,177 +11,4 @@
#:use-module (logic guile-log guile-prolog vm vm-var)
#:export (compile_disj compile_disjunction collect_disj))
(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(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)
)
)).
")
(include-from-path "logic/guile-log/guile-prolog/vm/vm-disj-model.scm")
......@@ -59,6 +59,7 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
b_setval(pretty,#t),
make_state(0,[[0,_,_]],[0],0,0,0,0,[HC,HV],[],V),
wrap(compile_goal(Code,#t,V,[L,[]]),[L,[]]),!,
% write(L),nl,!,
get_M(V,StackSize),
handle_all(L,LL),
(var(Constants)->Constants=scm[(get-consts)];true),
......
......@@ -341,7 +341,7 @@ handle([unify,[[S,V,Q],N,F|_],M],I,II,L,LL) :- !,
(
(F==#t,N==1) ->
(
(M==#t ; M==0) -> (tr(pop,Pop),L=[[Pop,1]|LL],II is I + 2) ;
(M==#t ; M==0) -> (L=[[pop,1]|LL],II is I + 2) ;
(L=[[false]|LL] , II is I + 1)
);
(F==#t,S==#t) ->
......@@ -505,6 +505,7 @@ handle(X,I,II,L,LL) :- !,
L=[XX|LL].
code([unify,M,V,K],Code,Action) :- !,
(
(M\\=#f,K=#f) ->
(
V=[U|_] ->
......@@ -526,7 +527,7 @@ code([unify,M,V,K],Code,Action) :- !,
),
U is A + KC << 1 + VC << 3,
Code is MC + U << 2
).
)).
code(['unify-2',M,V1,K1,V2,K2],Code) :- !,
(
......
......@@ -100,9 +100,10 @@
code ...))
(define-syntax-rule (<scm> x)
(if (number? x)
x
(gp->scm x S)))
(let ((u x))
(if (number? u)
u
(gp->scm u S))))
(define-syntax-rule (<cons> x y) (gp-cons! x y S))
(define-syntax-rule (<car> x) (gp-car (gp-lookup x S) S))
......
......@@ -85,10 +85,10 @@
F
(length (<scm> A))))))
(type_error callable F))
(<and>
(<push-dynamic> (<lookup> F) U
(catch #t
(<push-dynamic> (<lookup> F) U
(catch #t
(lambda ()
(mockalambda #f (<scm> S) (<scm> A) Body))
......@@ -291,7 +291,7 @@
(instantiation_error))
(#((F . A))
(<cut>
(<recur> lp2 ((F (<lookup> F)))
(<recur> lp2 ((F (pk (<lookup> F))))
(if (not (dynamic? F))
(if (procedure? F)
(if (object-property F 'prolog-symbol)
......@@ -323,7 +323,7 @@
(#((F . A))
(<cut>
(<values> (A Body) (analyze A true))
(<recur> lp ((F (<lookup> F)))
(<recur> lp ((F (pk (<lookup> F))))
(if (not (dynamic? F))
(if (procedure? F)
(if (object-property F 'prolog-symbol)
......@@ -338,9 +338,10 @@
(<cc>
#`(<push-dynamic> #,(datum->syntax stx (get-name (<lookup> F)))
#,(catch #t
(lambda () (mockalambda stx
(<scm> S) (<scm> A)
Body))
(lambda ()
(mockalambda stx
(<scm> S) (<scm> A)
Body))
(lambda x
(format #t "PROLOG HOT COMPILE ERROR:~%~a~%~%" x)
(type_error S P CC callable true)))))))))
......
......@@ -1135,11 +1135,11 @@
(<<match>> (#:mode - #:name expand) (y)
((x . l)
(<and>
(lp l (cons (pp (<scm>
(assertz-source+ S (lambda () #f) (lambda (s p x) x)
stx
(<scm> x) #f)))
r))))
(lp l (cons (pp (<scm>
(assertz-source+ S (lambda () #f) (lambda (s p x) x)
stx
(<scm> x) #f)))
r))))
(()
(<cc> (pp #`(begin
#,@(map
......
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