various bugfixes, variables are now entities

parent 7bf33f86
......@@ -1002,6 +1002,11 @@ constant = #(nlocals nstack constants code)
(CONS (int->scm inst) ctrl-stack)
middle))
(define-syntax-rule (PACK-ALWAYS-P- middle inst ctrl-stack)
(CONS
(CONS inst ctrl-stack)
middle))
(define-syntax-rule (PACK-ALWAYS-CC middle inst ctrl-stack pp)
(CONS
(CONS (int->scm inst) (CONS ctrl-stack pp))
......@@ -1036,6 +1041,11 @@ constant = #(nlocals nstack constants code)
(PACK-MIDDLE-P-CC session middle sp-stack)
inst ctrl-stack))
(define-syntax-rule (PACK-P- session middle inst ctrl-stack sp-stack)
(PACK-ALWAYS-P-
(PACK-MIDDLE-P-CC session middle sp-stack)
inst ctrl-stack))
(define-syntax-rule (PACK-CC session middle inst ctrl-stack sp-stack pp)
(PACK-ALWAYS-CC
(PACK-MIDDLE-P-CC session middle sp-stack)
......@@ -1104,8 +1114,7 @@ constant = #(nlocals nstack constants code)
(UNPACK-VAR 1 n i2 pinned? variables variables-scm nvar
cnst session middle
(<=> (SVAR-REF fp nstack i2) (<scm> #f))
(<=> (<ref> variables i2) (<scm> #f)))
(<=> (<ref> variables i2) (<scm> #f)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<if> (<not> (EQ (<call> scm_fluid_ref *delayers*) old))
(<begin>
......@@ -1319,6 +1328,12 @@ constant = #(nlocals nstack constants code)
(PACK-ENV (<c> 1) nlocals)
(PACK-P session middle inst ctrl-stack sp-stack)))
(define-syntax-rule (MAKEP-P- nlocals session middle inst ctrl-stack
sp-stack)
(<call> gp_custom_fkn *model-lambda*
(PACK-ENV (<c> 1) nlocals)
(PACK-P- session middle inst ctrl-stack sp-stack)))
(define-syntax-rule (MK-P p pp code)
(<if> (NUMBER? p)
(<if> (<and> (PAIR? pp) (EQ (CAR pp) p))
......@@ -1390,7 +1405,7 @@ constant = #(nlocals nstack constants code)
((SCM *) instructions (<c> 0))
(SCM tvars-scm (<scm> #f))
((SCM *) tvars (<c> 0))
(int ninst (<c> 1))
(int ninst (<c> 0))
(int nstack (<c> 0))
(int nvar (<c> 2))
(SCM ctrl-stack (<scm> '()))
......@@ -1408,9 +1423,6 @@ constant = #(nlocals nstack constants code)
(PRSTACK sp fp)
(SET-S-P p? s p sp fp)
(<if> (<or> p? (<==> ninst (<c> 0)))
(<=> call? (<c> 0)))
(<if> p? (<=> sp fp))
......@@ -1430,6 +1442,9 @@ constant = #(nlocals nstack constants code)
(UNPACK-ALWAYS always p? ninst ctrl-stack pp)
(<if> (<or> p? (<==> ninst (<c> 0)))
(<=> call? (<c> 0)))
(<if> (<and> (PAIR? pp) (EQ (CDR pp) p))
(<=> p (CAR pp)))
......@@ -1471,12 +1486,12 @@ constant = #(nlocals nstack constants code)
(PRSTACK sp fp)
(<let*> ((SCM st (GET-STACK fp sp))
(SCM p (MK-P p pp
(MAKEP-P nlocals
session
middle
(<-> inst-pt instructions)
ctrl-stack
sp-stack)))
(MAKEP-P- nlocals
session
middle
p
ctrl-stack
sp-stack)))
(SCM cc (GET-CC variables)))
(FORMAT "STACK: ~a~%" st)
(CLEAR-SP-XP sp fp)
......@@ -1716,8 +1731,9 @@ constant = #(nlocals nstack constants code)
(DECR 3 sp)
(<=> cut c)
(<if> (PAIR? sp-stack)
(INSTALL-STACK fp sp nstack nsloc sp-stack))
(NEXT inst-pt))))
(INSTALL-STACK fp sp nstack nsloc sp-stack))))
(NEXT inst-pt))
(LABEL fail)
......
......@@ -11,13 +11,13 @@
#:export (caller push_args_args2 push_args_args push_args))
(compile-prolog-string "
narg(X,N,N) :- var(X),!.
narg(X,N,N) :- var_p(X),!.
narg([X|L],I,N) :-
II is I + 1,
narg(L,II,N).
narg(_,I,I).
push_args_args(X,V,L,LL) :- var(X),!,
push_args_args(X,V,L,LL) :- var_p(X),!,
push_args(X,V,L,LL).
push_args_args([X|Y],V,L,LL) :- !,
......@@ -26,7 +26,7 @@ push_args_args([X|Y],V,L,LL) :- !,
push_args_args([],V,L,L) :- !.
push_args_args2(X,V,L,LL) :- var(X),!,
push_args_args2(X,V,L,LL) :- var_p(X),!,
push_args(X,V,L,LL).
push_args_args2([X|Y],V,L,LL) :- !,
......@@ -36,7 +36,7 @@ push_args_args2([X|Y],V,L,LL) :- !,
push_args_args2([],V,L,LL) :-
push_args([],V,L,LL).
push_args(X,V,L,LL) :- var(X),!,
push_args(X,V,L,LL) :- var_p(X),!,
add_var(X,V,Tag),
push_v(1,V),
tr('push-variable',Push),
......
......@@ -76,7 +76,6 @@ compile_conj0([G|Gs],Tail,V,L) :- !,
link_l(L,L1,L2),
ifc(compile_goal(G,#f,V,L1),E,
(
write([G,E]),nl,
tfc(E),
(
E==#t ->
......
......@@ -65,7 +65,7 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
write(LL),nl,
(Pretty==#t -> Iout=LL ; (b_setval(pretty,#f),mmtr(LL,Iout))).
compile_goal(X,Tail,V,L) :- var(X),!,
compile_goal(X,Tail,V,L) :- var_p(X),!,
compile_goal(call(X),Tail,V,L).
......@@ -87,6 +87,7 @@ compile_goal(begin_att,Tail,V,[L,LL]) :- !,
A=[[Ai | _] | _],
set_A(V,[[AAi,AAx,AAt] | A]),
AAi is Ai + 1,
var_p(AAx),
add_var(AAx,V,Tagx),
tr('pre-unify',Pre),
L = [[Pre,AAt,Tagx]|LL]
......@@ -99,6 +100,7 @@ compile_goal(end_att,Tail,V,[L,LL]) :- !,
[[Ai,Ax,At]|AA]=A,
set_A(V, AA),
(Ai==0 -> throw(missmatching_begin_end_pair) ; true),
var_p(Ax),
add_var(Ax,V,Tag),
(Tail==#t -> tr('post-unify-tail',Post) ; tr('post-unify',Post)),
(
......@@ -181,15 +183,12 @@ compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
XX=[Z] -> compile_goal(Z,Tail,V,[L,LL]) ;
(
get_AESM(V,Aq,E,S,M),
S2 is S + 2,
M2 is max(M,S2),
set_ESM(V,0,S2,M2),
label(Lab),label(Out),tr(newframe,Newframe),
compile_disjunction(XX,#t,Aq,Ae,Out,Lab,Lab,Tail,S2,U,V,LM),!,
(zero(V) -> Tp is 0 ; Tp is 2),
compile_disjunction(XX,#t,Aq,Ae,Out,Lab,Lab,Tail,S,U,V,LM),!,
(zero(V) -> Tp is 0 ; Tp is 1),
L = [[Newframe,Lab,Tp] | LX],
LM = [LX, [[label,Out] | LL]],
get_EBH(V,B,Ed,H),
get_EBH(V,Ed,B,H),
add_missing_variables(H,U,Ed,Ed,EEd),!,
EE is E \\/ EEd,
set_E(V,EE)
......@@ -197,11 +196,11 @@ compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
).
compile_goal(verbatim_call(X),Tail,V,[L,LL]) :-
( nonvar(X),
( (\\+var_p(X)),
(
F(|Args)=X ->
(
(var(F) ; isApply(Args)) -> fail ; true
(var_p(F) ; isApply(Args)) -> fail ; true
) ;
true
)
......@@ -210,11 +209,11 @@ compile_goal(verbatim_call(X),Tail,V,[L,LL]) :-
compile_goal(X,Tail,V,[L,LL]).
compile_goal(call(X),Tail,V,[L,LL]) :-
( nonvar(X),
( \\+var_p(X),
(
F(|Args)=X ->
(
(var(F) ; isApply(Args)) -> fail ; true
(var_p(F) ; isApply(Args)) -> fail ; true
) ;
true
)
......@@ -235,7 +234,7 @@ compile_goal(call(X),Tail,V,[L,LL]) :-
compile_goal((X =.. Y),Tail,V, L, LL) :- !,
(var(X);constant(X)) ->
(var_p(X);constant(X)) ->
(
compile_arg(X,Branch,HC,HV,L,LLX),
compile_imprint(Y,Branch,HC,HV,LLX,LLY),
......@@ -246,7 +245,7 @@ compile_goal((X =.. Y),Tail,V, L, LL) :- !,
compile_goal(set(V,X),Tail,V,[L,LL]) :- !,
tr(set,Set),
(var(X) -> true ; throw(no_var_in_set)),
(var_p(X) -> true ; throw(no_var_in_set)),
add_var(X,V,Tag),
(isFirst(Tag) -> true ; force_variable(Tag)),
push_args(X,V,L,LX),
......@@ -280,10 +279,11 @@ compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
get_ACESB(V,A,C,E,S,B),
C = [C0|_],
CC = [Al|C],
set_ACE(V,[[0|_]],CC,0),
compile_goal(X,#f,V,[LX,LLX]),
set_ACESB(V,A,C,E,S,B),
(Tail=#t -> LG==[[cc]|LL] ; LG=LL),
LLX = [[goto-inst ,Bl ],
(Tail=#t -> LG=[[cc]|LL] ; LG=LL),
LLX = [['goto-inst' ,Bl ],
[label ,Al ],
['unwind-negation' ,Al,C0],
[label ,Bl ],
......@@ -369,13 +369,14 @@ compile_goal(iss(X,Y),Tail,V,[L,LL]) :- !,
);
(
tr('unify-instruction-2',Unify),
var_p(X),
add_var(X,V,Tag),
L=[[Unify,Tag,Y,#t]|LLL]
)
);
ifc(compile_scm(Y,V,L,LX),EY,compile_goal(X is EY, Tail, V, [L,LL]),
(
var(X) ->
var_p(X) ->
(
add_var(X,V,Tag),
push_v(-1,V),
......@@ -441,7 +442,7 @@ compile_goal(imprint(X,M),Tail,V,[L,LL]) :-
compile_goal(m_and(X,F(|Args)),Tail,V,L) :- !,
(
(var(F) ; isApply(Args)) -> compile_goal(call(X),Tail,V,L) ;
(var_p(F) ; isApply(Args)) -> compile_goal(call(X),Tail,V,L) ;
caller(F,Args,Tail,V,L)
).
......@@ -451,7 +452,7 @@ compile_goal(F,Tail,V,L) :-
compile_goal(X,_,_,_) :-
throw(failed_compile_goal(X)).
isApply(X) :- var(X),!.
isApply(X) :- var_p(X),!.
isApply([X|L]) :- isApply(L).
ncons(X,N) :-
......
......@@ -21,7 +21,7 @@ newv([_|L]) :- newv(L).
handle_all(L,Lout) :-
newv(L),
handle_all(L,-1,II,Lout,[]).
handle_all(L,0,II,Lout,[]).
handle_all([],I,I,L,L).
handle_all([X|Y],I,II,L,LL) :-
......@@ -54,7 +54,7 @@ handle((X,['post-call',A,P]),I,II,L,LL) :- !,
handle((X,['post-unicall',A,P]),I,II,L,LL) :- !,
get_nsvars(P,N),
set(P,N),
II is I + 2, L=[X|LL].
II is I + 3, L=[X|LL].
handle(['newvar', _],I,I,L,L) :- !.
......@@ -74,17 +74,29 @@ handle(['pre-unify',At,Vx],I,II,L,LL) :- !,
)
).
handle([(Op,('post-unify' ; 'post-unify-tail')),[[S,V,Q],N,F|_]],I,II,L,LL) :-
handle(['post-unify-tail',[[S,V,Q],N,F|_]],I,II,L,LL) :-
!,
(
F==#t -> throw(end_with_no_begin) ;
(
new_var(V,Q,S),
L=[[Op,V]|LL],
L=[['post-unify-tail',V]|LL],
II is I + 2
)
).
handle(['post-unify',[[S,V,Q],N,F|_]],I,II,L,LL) :-
!,
(
F==#t -> throw(end_with_no_begin) ;
(
(get_nsvars(Q,M) -> true ; M=0),
new_var(V,Q,S),
L=[['post-unify',V,M]|LL],
II is I + 3
)
).
handle([set,(W,[[S,V,Q],N,F|_])],I,II,L,LL) :- !,
(
(F=#t,N=1) -> (L=LL, I=II) ;
......@@ -115,7 +127,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=I) ;
(M==#t ; M==0) -> (tr(pop,Pop),L=[[Pop,1]|LL],II is I + 2) ;
(L=[[false]|LL] , II is I + 1)
);
(F==#t,S==#t) ->
......@@ -124,7 +136,7 @@ handle([unify,[[S,V,Q],N,F|_],M],I,II,L,LL) :- !,
(
new_var(V,Q,S),
L=[[unify,M,V,#t]|LL],
II is I + 5
II is I + 4
)
);
F==#t ->
......@@ -133,7 +145,7 @@ handle([unify,[[S,V,Q],N,F|_],M],I,II,L,LL) :- !,
(
new_var(V,Q,S),
L=[[unify,M,V,#f]|LL],
II is I + 5
II is I + 4
)
);
N==1 ->
......
......@@ -12,7 +12,7 @@
(compile-prolog-string "
compile_imprint(Y,V,L,LL,M) :-
var(Y) ->
var_p(Y) ->
(!,
add_var(Y,V,Tag),
push_v(-1,V),
......
......@@ -146,6 +146,14 @@
(<define> (inc x)
(<=> x ncode)
(<code> (set! ncode (+ ncode 1))))))
(define vartag (gensym "var"))
(<define> (gen x) (<=> x ,(cons vartag (gensym "id"))))
(<define> (var_p x)
(let ((x (<lookup> x)))
(<if> (var CUT x)
(gen x)
(if (and (pair? x) (eq? (car x) vartag))
<cc>))))
(compile-prolog-string
"
......
......@@ -14,7 +14,7 @@
"
-extended.
compile_scm(X,V,L,LL) :-
var(X) ->
var_p(X) ->
( !,
add_var(X,V,Tag),tr('push-variable-scm',Push),
push_v(1,V),
......
......@@ -14,7 +14,7 @@
(compile-prolog-string "
compile_unify(X,Y,V,[L,LL],M) :-
X==Y -> (!,throw(#t));
var(X) ->
var_p(X) ->
(
!,
(
......@@ -34,7 +34,7 @@ compile_unify(X,Y,V,[L,LL],M) :-
L = [[Unify,Tag1,Y,M]|LL]
);
var(Y) ->
var_p(Y) ->
(
get_H(V,H),
tr('unify-2',Unify),
......@@ -54,7 +54,7 @@ compile_unify(X,Y,V,[L,LL],M) :-
)
)
) ;
var(Y) -> (!,compile_unify(Y,X,V,[L,LL],M)).
var_p(Y) -> (!,compile_unify(Y,X,V,[L,LL],M)).
compile_unify([X|LX],[Y|LY],V,L,M) :- !,
link_l(L,L1,L2),
......
This diff is collapsed.
This diff is collapsed.
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