newframe

parent 713f3c25
......@@ -164,7 +164,7 @@ handle(['post-unify',[[S,V,Q],N,F|_]],L,LL) :-
handle([set,(W,[[S,V,Q],N,F|_])],L,LL) :- !,
(
(F=#t,N=1) -> (L=LL) ;
S=#t -> (new_var(V,Q,S),gset(V,L,LL)) ;
S=#t -> (new_var(V,Q,S),ggset(V,L,LL)) ;
handle([unify,W,#t],L,LL)
).
......
......@@ -12,7 +12,7 @@
(compile-prolog-string
"
'icons!'(I,II,L,LL) :-
pltest('gp-pair!?',[sp(I-1),s],I,L,L2),
pltest_s('gp-pair!?',[sp(I-1),s],I,L,L2),
scmcall('gp-cdr',[sp(I-1),s],I,I2,L2,L3),
scmcall('gp-car',[sp(I-1),s],I2,I3,L4),
move(I2-1,I-1,L4,L5),
......@@ -21,14 +21,14 @@
reset(II,L6,LL).
'ifkn!'(I,L,LL) :-
pltest('fkn!?',[sp[I - 1],s],I,L,L1),
pltest_s('fkn!?',[sp[I - 1],s],I,L,L1),
scmcall('vector-ref',[sp[I - 1],c(0)],I,I2,L1,L2),
move(I2-1,I-1,L2,L3),
reset(I,L3,LL).
'icurly!'(I,L,LL) :-
pltest('curly!?',[sp[I - 1],s],I,L,L1),
pltest_s('curly!?',[sp[I - 1],s],I,L,L1),
scmcall('vector-ref',[sp[I - 1],c(1)],I,I1,L1,L2),
move(I1-1,I-1,L2,L3),
reset(I,L3,LL).
......@@ -65,7 +65,7 @@
icons(I,II,L,LL) :-
pltest('gp-pair?',[sp[-1],s],I,L,L1),
pltest('gp-pair?',[sp[-1],s],I,_,L,L1),
scmcall('gp-cdr',[sp[-1],s],I,I2,L1,L2),
scmcall('gp-car',[sp[-1],s],I2,I3,L2,L3),
move(sp(I2-1),I-1,L3,L4),
......@@ -74,13 +74,13 @@
reset(II,L5,LL).
ifkn(I,L,LL) :-
pltest('fkn?',[sp(I-1)],I,L,L1),
pltest('fkn?',[sp(I-1)],I,_,L,L1),
scmcall('vector-ref',[sp(I-1),c(0)],I,L1,L2),
move(I+3,I-1,L2,L3),
reset(I,L3,LL).
icurly(I,L,LL) :-
pltest('curly?',[sp(I-1)],I,L,L1),
pltest('curly?',[sp(I-1)],I,_,L,L1),
scmcall('vector-ref',[sp(I-1),c(1)],I,I2,L1,L2),
move(I2-1,I-1,L2,L3),
reset(I,L3,LL).
......
(define-module (logic guile-log vm newframe)
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log iso-prolog)
#:export (newframe-ps newframe-pst newframe-light newframe
newframe-negation))
(compile-prolog-string
"
'newframe-ps'(PP,SS,I,L,LL) :-
gset(PP,p,I,L,L1),
gset(SS,s,I,L1,L2),
reset(I,L2,LL).
'newframe-pst'(P,S,T,I,L,LL) :-
gset(P,p,I,L,L1),
gset(S,s,I,L1,L2).
gset(T,delayers,I,L2,L3),
reset(I,L3,LL).
'newframe-light'(P,NP,I,L,LL) :-
sset(P,p,I,L,L1),
gset(p,l(NP),I,L1,L2),
reset(I,L2,LL).
/*
(LABEL newframe)
(PRSTACK sp fp)
(<let> ((SCM np (<ref> inst-pt (<c> 0)))
(int tp (scm->int (<ref> inst-pt (<c> 1))))
(SCM fr (NEWFRAME s)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<=> ctrl-stack (STORE-STATE tp np s fr p ctrl-stack))
(<=> s fr)
(<=> p np)
(<call> INTERUPT)
(NEXT inst-pt))
*/
newframe(NP,TP,I,L,LL) :-
newframe(I,L,L1,
store_state(l(NP),TP,I,L1,L2),
gset(p,sp(I),L2,L3),
gset(s,newframe,I,L3,L4).
/*
(LABEL newframe-negation)
(PRSTACK sp fp)
(<let> ((SCM np (<ref> inst-pt (<c> 0)))
(int tp (scm->int (<ref> inst-pt (<c> 1))))
(SCM so s)
(SCM ss (NEWFRAME s)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<=> s ss)
(<=> s (<call> gp_set
*gp-not-n*
(<call>
SCM_I_MAKINUM
(<+> (<c> 1)
(<call> SCM_I_INUM
(<call> gp_gp_lookup
*gp-not-n* s))))
s))
(<=> s (<call> gp_set *gp-is-delayed?* (<scm> #f) s))
(<=> ctrl-stack (STORE-STATE-NEG tp np so ss scut p ctrl-stack))
(<=> p np)
(<=> cut np)
(<call> INTERUPT)
(NEXT inst-pt))
*/
'newframe-negation'(NP,TP,I,L,LL) :-
neframe(L,L1),
I1 is I + 1,
gset(sp(I),l(NP),II,L1,L2),
mkcstack(sp(I),TP,newframe,s,scut,p,cstack),
scmcall('gp-newframe-negation',
[vec,],II,III,L2,L3),
gset(cstack,sp(III),
")
(define-module (logic guile-log vm utils)
#:use-module (logic guile-log iso-prolog)
#:export (reset gset gref move scmcall make_p make_cc j je jne
label gfalse isTrue pltest lookup2
test sp cc vec cut scut pp))
label gfalse gtrue isTrue pltest lookup2
test sp cc vec cut scut pp pltest_s))
(compile-prolog-string
"
......@@ -141,18 +141,21 @@
II is I + 1,
scmtailcall(sp(I),[],II,L6,LL).
gtrue(I,L,L).
isTrue(sp(I),Label,I,L,LL) :-
call(II is I),
generate(test1(true,II,Label),L,LL).
pltest(F,A,I,L,LL) :-
scmcall(F,A,I,II,L,L1),
III is II + 2,
isTrue(sp(II + 1),III,Label,L1,L2),
gfalse(L2,L3),
label(Label,L3,L4),
gset(s,sp(II + 1),III,L4,L5),
reset(I,L5,LL).
pltest(F,A,I,II,L,LL) :-
scmcall(F,A,I,I,II,L,L1),
isTrue(sp(II-1),II,Label,L1,L2),
gfalse(II,L2,L3),
label(Label,L3,LL).
pltest_s(F,A,I,L,LL)
pltest(F,A,I,II,L,L1),
gset(s,sp(II-1),L1,LL).
lookup2(I,L,LL) :-
scmcall('gp-lookup',[sp(I-2),s],I,L,L1),
......
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