refined call logic

parent 7e74daae
......@@ -1146,7 +1146,8 @@ constant = #(nlocals nstack constants code)
(<--> sp)
(<if> register?
(MAKE-REGS sp)
(<let> ((int narg (<c> 0))
(<let> ((int call? (<c> 1))
(int narg (<c> 0))
(int nlocals (<c> 0))
(SCM always (<scm> #f))
(SCM middle (<scm> #f))
......@@ -1179,6 +1180,9 @@ constant = #(nlocals nstack constants code)
(SET-S-P p? s p sp fp)
(<if> (<or> p? (<==> ninst (<c> 0)))
(<=> call? (<c> 0)))
(UNPACK-CONST
cnst nvar nstack instructions-scm constants-scm tvars-scm)
......@@ -1432,23 +1436,29 @@ constant = #(nlocals nstack constants code)
(<let> ((SCM c (<ref> inst-pt (<c> 0)))
(SCM pop? (<ref> inst-pt (<c> 1))))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<if> call?
(<begin>
(<=> call? (<c> 0))
(<if> (TRUE pop?)
(DECR 3 sp))
(<=> cut c)
(<if> (PAIR? sp-stack)
(INSTALL-STACK fp sp nstack (<c> 0) sp-stack))
(NEXT inst-pt))
(NEXT inst-pt))))
(LABEL post-unicall)
(PRSTACK sp fp)
(<let> ((SCM c (<ref> inst-pt (<c> 0)))
(int nsloc (scm->int (<ref> inst-pt (<c> 1)))))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<if> call?
(<begin>
(<=> call? (<c> 0))
(DECR 3 sp)
(<=> cut c)
(<if> (PAIR? sp-stack)
(INSTALL-STACK fp sp nstack nsloc sp-stack))
(NEXT inst-pt))
(NEXT inst-pt))))
(LABEL cut)
......
......@@ -123,9 +123,9 @@ caller(cc,Args,Tail,V,[L,LL]) :- !,
LL2 = [[Call]|LL].
caller(F,Args,Tail,V,[L,LL]) :-
((F==cc,Tail=#f) -> throw(cc_not_in_tail_context) ; true),
tr('clear-sp' , Clear),
L=[[Clear]|L2],
touch_A(V),
get_CS(V,C,S),
set_S(V,0),
push_args(F,V,L2,L3),
......
......@@ -51,6 +51,7 @@ compile_disjunction
([X],First,Aq,Ae,Out,Lab,A,Tail,S0,[U],V,[L,LL]) :- !,
(First=#t -> compile_goal(X,First,V,[L,LL]) ;
catch((
set_F(V,Out),
get_CES(V,C,E,S),
set_AES(V,Aq,0,S0),
(
......@@ -95,15 +96,18 @@ goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,C,S,S0,E,U,UU,V,L,LL,LG,LLX) :-
A1q=Ae
);
(
Ae == A1q -> true ;
throw(all_disjuction_goals_needs_the_same_begin_level)
set_F(V,Out),
(Ae == A1q -> true ;
throw(all_disjuction_goals_needs_the_same_begin_level))
)
),
ifc(compile_disjunction(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);
head_at_true(First,#t,A,C,Lab,Lab2,L,LL)
)
),
head_at_true(First,#f,A,C,Lab,Lab2,L,LX)
).
......@@ -116,6 +120,7 @@ compile_disjunction([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,[U|UU],V,[L,LL]) :- !,
catch(goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,C,S,S0,E,U,UU,V,L,LL,LG,LLX), Er,
(
tfc(Er),
(First == #t -> true ; set_F(V,Out)),
(Tail==#t -> LLG = [[cc]|LG] ; LLG=LG),
(
Er==c -> throw(#f) ;
......
......@@ -80,27 +80,31 @@ compile_goal(begin_att,Tail,V,[L,LL]) :- !,
(
get_A(V,A),
A=[[Ai | _] | _],
set_A(V,[[AAi,AAx] | A]),
set_A(V,[[AAi,AAx,AAt] | A]),
AAi is Ai + 1,
add_var(AAx,V,Tagx),
tr('pre-unify',Pre),
L = [[Pre,Tagx]|LL]
L = [[Pre,At,Tagx]|LL]
)
).
compile_goal(end_att,Tail,V,[L,LL]) :- !,
check_tail(Tail),
get_AF(V, A, F),
[[Ai,Ax]|AA]=A,
[[Ai,Ax,At]|AA]=A,
set_A(V, AA),
(Ai==0 -> throw(missmatching_begin_end_pair) ; true),
add_var(Ax,V,Tag),
(Tail==#t -> tr('post-unify-tail',Post) ; tr('post-unify',Post)),
(
Tail==#t -> LLL=LL ;
(tr('post-unicall',PostCall),get_C(V,C),LLL=[[PostCall,C,F]|LL])
(
At=#t ->
(tr('post-unicall',PostCall),get_C(V,C),LLL=[[PostCall,At,C,F]|LL]) ;
LLL=LL
)
),
L = [[Post,Tag]|LLL].
L = [[Post,At,Tag]|LLL].
compile_goal(pop(N),Tail,V,[L,LL]) :- !,
check_tail(Tail),
......@@ -120,7 +124,7 @@ compile_goal((Args <= Goal),Tail,V,L) :- !,
L2=[[[label,G]|U],U],
set_S(V,0),
push_v(NN,V),
compile_goal((begin_att,Impr,end_att,pop(3)),Tail,V,L3).
compile_goal((begin_att,Impr,pop(3),end_att),Tail,V,L3).
compile_goal((F(|Args) :- Goal),Tail,V,L) :- !,
(listp(Args) -> true ; throw(not_proper_head(F(|Args)))),
......@@ -129,7 +133,7 @@ compile_goal((F(|Args) :- Goal),Tail,V,L) :- !,
NN is N + 4,
push_v(NN,V),
get_A(V,[[0|_]|_]) ->
wrap(compile_goal((begin_att,Impr,end_att,pop(4),Goal),Tail,V,L),L);
wrap(compile_goal((begin_att,Impr,pop(4),end_att,Goal),Tail,V,L),L);
wrap(compile_goal((begin_att,Impr,pop(4),Goal),Tail,V,L),L).
compile_goal((F :- Goal),Tail,V,L) :- !,
......
......@@ -17,15 +17,18 @@ compile_imprint(Y,V,L,LL,M) :-
add_var(Y,V,Tag),
push_v(-1,V),
tr(unify,Unify),
(isFirst(Tag) -> true ; touch_A(V)),
L=[[Unify,Tag,M]|LL]
).
compile_imprint({Y},V, L, LL, M) :- !,
touch_A(V),
(M=#f -> tr('icurly',Curly) ; tr('icurly!',Curly)),
L=[[Curly]|L1],
compile_imprint(Y,V,L1,LL,M).
compile_imprint([Y|LY],V, L,LL,M) :- !,
touch_A(V),
(M=#f -> tr('icons',Icons) ; tr('icons!',Icons)),
L=[[Icons]|L1],
push_v(1,V1),
......@@ -63,6 +66,7 @@ compile_imprint(Y,V,L,LL,M) :-
compile_imprint_fkn(Y(|LY),V,L,LL,M) :-
touch_A(V),
(M=#f -> tr(ifkn,Ifkn); tr('ifkn!',Ifkn)),
L=[[Ifkn]|L1],
compile_imprint([Y|LY],V,L1,LL,M).
......
......@@ -191,6 +191,12 @@
(compile-prolog-string
"
touch_A0([[0|_]]).
touch_A0([[_,_,#t]|L]) :- touch_A0(L).
touch_A(V) :-
get_A(V,A),
touch(A).
ifc(G,E,X,Y) :-
catch(G,E,X),
(var(E) -> Y ; true).
......
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