negation cmompiles and compilation debugged and tested

parent 2732f879
......@@ -103,19 +103,26 @@ constant = #(nlocals nstack constants code)
(<declare-s> int SCM_I_IS_VECTOR ((SCM x)))
(<declare-s> int SCM_I_VECTOR_LENGTH ((SCM x)))
(<declare-s> SCM gp_mkvar ((SCM s)))
(<declare-s> SCM scm_variable_ref ((SCM s)))
(<declare-s> SCM scm_make_variable ((SCM s)))
(<declare-s> int SCM_VARIABLEP ((SCM s)))
(<declare-s> int gp_varp ((SCM x) (SCM s)))
(<declare-s> SCM gp_custom_fkn ((SCM model) (SCM a) (SCM b) (SCM c)
(SCM d)))
(<declare-s> remove_me_t gp_make_vm_model ())
(define-syntax-rule (CAR x) (<call> SCM_CAR x))
(define-syntax-rule (CDR x) (<call> SCM_CDR x))
(define-syntax-rule (TRUE x) (<call> scm_is_true x))
(define-syntax-rule (FALSE x) (<call> scm_is_false x))
(define-syntax-rule (CONS x y) (<call> scm_cons x y))
(define-syntax-rule (PAIR? x) (<call> SCM_CONSP x))
(define-syntax-rule (NUMBER? s) (<call> SCM_I_INUMP s))
(define-syntax-rule (MKVAR s) (<call> gp_mkvar s))
(define-syntax-rule (CAR x) (<call> SCM_CAR x))
(define-syntax-rule (CDR x) (<call> SCM_CDR x))
(define-syntax-rule (TRUE x) (<call> scm_is_true x))
(define-syntax-rule (FALSE x) (<call> scm_is_false x))
(define-syntax-rule (CONS x y) (<call> scm_cons x y))
(define-syntax-rule (PAIR? x) (<call> SCM_CONSP x))
(define-syntax-rule (NUMBER? s) (<call> SCM_I_INUMP s))
(define-syntax-rule (MKVAR s) (<call> gp_mkvar s))
(define-syntax-rule (VARIABLE? x) (<call> SCM_VARIABLEP x))
(define-syntax-rule (MAKE-VARIABLE x)
(<call> scm_make_variable x))
(define-syntax-rule (VARIABLE-REF x) (scm_variable_ref x))
(define-syntax-rule (LENGTH st)
(<recur> lp ((s st) (int i (<c> 0)))
(if (PAIR? s)
......@@ -630,12 +637,22 @@ constant = #(nlocals nstack constants code)
(BACKTRACK p instructions inst-pt fp sp))))))))
(define-syntax-rule (STORE-STATE tp tag s p stack)
(define-syntax-rule (STORE-STATE tp tag s p cut stack)
(<let> ((np (<if> (NUMBER? p) p (<scm> 0))))
(CONS (CONS tag
(CONS s
(<if> tp
(CONS np (<call> scm_fluid_ref *delayers*))
(<if> (q> tp (<c> 0))
(CONS np
(<if> (<==> tp 1)
cut
(<if> (<==> tp 2)
(MAKE-VARIABLE
(<call> scm_fluid_ref
*delayers*))
(CONS cut
(<call>
scm_fluid_set_x
*delayers*)))))
np)))
stack)))
......@@ -653,22 +670,31 @@ constant = #(nlocals nstack constants code)
(<=> (<*> sp) (<scm> #f))
(<next> lp))))))
(define-syntax-rule (RESTORE-STATE s tag stack)
(define-syntax-rule (RESTORE-STATE s cut tag stack)
(<recur> lp ()
(<let> ((x (CAR stack)))
(<if> (EQ x tag)
(<let*> ((x1 (CDR x))
(ss (CAR x1))
(x2 (CDR x1)))
(<=> s ss)
(<if> (PAIR? x2)
(<begin>
(<call> scm_fluid_set_x *delayers* (CDR x2)))))
(<=> s ss)
(<if> (PAIR? x2)
(<let> ((x3 (CDR x2)))
(<if> (PAIR? x3)
(<begin>
(<=> cut (CAR x3))
(<call> scm_fluid_set_x *delayers*
(CDR x3)))
(<if> (VARIABLE? x3)
(<call> scm_fluid_set_x *delayers*
(VARIABLE-REF x3))
(<=> cut x3))))))
(<begin>
(<=> stack (CDR stack))
(<next> lp))))))
(define-syntax-rule (RESTORE-STATE-TAIL s p tag stack)
(define-syntax-rule (RESTORE-STATE-TAIL s p cut tag stack)
(<recur> lp ()
(<let> ((x (CAR stack)))
(<if> (EQ x tag)
......@@ -680,7 +706,16 @@ constant = #(nlocals nstack constants code)
(<if> (PAIR? x2)
(<begin>
(<=> p (CAR x2))
(<call> scm_fluid_set_x *delayers* (CDR x2)))
(<let*> ((x3 (CDR x3)))
(<if> (PAIR? x3)
(<begin>
(<=> cut (CAR x3))
(<call> scm_fluid_set_x *delayers*
(CDR x3)))
(<if> (VARIABLE? x3)
(<call> scm_fluid_set_x *delayers*
(VARIABLE-REF x3))
(<=> cut x3)))))
(<=> p x2)))
(<begin>
(<=> stack (CDR stack))
......@@ -1322,7 +1357,7 @@ constant = #(nlocals nstack constants code)
(SCM ss (NEWFRAME s)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(<=> s ss)
(<=> ctrl-stack (STORE-STATE tp (<scm> 1) s p ctrl-stack))
(<=> ctrl-stack (STORE-STATE tp (<scm> 1) s p cut ctrl-stack))
(NEXT inst-pt))
(LABEL newframe)
......@@ -1332,7 +1367,7 @@ constant = #(nlocals nstack constants code)
(SCM ss (NEWFRAME s)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<=> s ss)
(<=> ctrl-stack (STORE-STATE tp np s p ctrl-stack))
(<=> ctrl-stack (STORE-STATE tp np s p cut ctrl-stack))
(<=> p np)
(NEXT inst-pt))
......@@ -1348,10 +1383,13 @@ constant = #(nlocals nstack constants code)
(<call>
SCM_I_MAKINUM
(<+> (<c> 1)
(<call> SCM_I_INUM (<call> gp_gp_lookup *gp-not-n* s))))
(<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 tp np ss p ctrl-stack))
(<=> ctrl-stack (STORE-STATE tp np ss p cut ctrl-stack))
(<=> cut np)
(NEXT inst-pt))
......@@ -1368,10 +1406,10 @@ constant = #(nlocals nstack constants code)
;; [.z.]
(LABEL unwind-negation)
(PRSTACK sp fp)
(<let> ((int n (scm->int (<*> inst-pt)))
(int m (scm->int (<ref> inst-pt (<c> 1)))))
(<=> inst-pt (<+> inst-pt (<c> 3)))
(RESTORE-STATE-TAIL s p n ctrl-stack)
(<let> ((int np (scm->int (<ref> inst-pt (<c> 0))))
(int out (scm->int (<ref> inst-pt (<c> 1)))))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(RESTORE-STATE-TAIL s p cut np ctrl-stack)
(<let> ((int n (scm->int (<call> gp_gp_lookup *gp-not-n* s)))
(SCM d (<call> gp_gp_lookup *gp-is-delayed?* s)))
(UNWIND s)
......@@ -1382,16 +1420,15 @@ constant = #(nlocals nstack constants code)
*gp-is-delayed?* (<scm> #t) s)
(BACKTRACK p instructions inst-pt fp sp))
(<begin>
(<=> inst-pt (<+> instructions m))
(<=> inst-pt (<+> instructions out))
(NEXT inst-pt)))))
;; We will
(LABEL unwind-tail)
(PRSTACK sp fp)
(<let> ((SCM tag (<*> inst-pt)))
(<=> cut (<ref> inst-pt (<c> 1)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(RESTORE-STATE-TAIL s p tag ctrl-stack)
(<=> inst-pt (<+> inst-pt (<c> 1)))
(RESTORE-STATE-TAIL s p cut tag ctrl-stack)
(UNWIND-TAIL s)
(NEXT inst-pt))
......@@ -1399,10 +1436,9 @@ constant = #(nlocals nstack constants code)
(LABEL unwind)
(PRSTACK sp fp)
(<let> ((SCM tag (<ref> inst-pt (<c> 0))))
(<=> p (<ref> inst-pt (<c> 1)))
(<=> cut (<ref> inst-pt (<c> 2)))
(<=> inst-pt (<+> inst-pt (<c> 3)))
(RESTORE-STATE s tag ctrl-stack)
(<=> p (<ref> inst-pt (<c> 1))))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(RESTORE-STATE s cut tag ctrl-stack)
(UNWIND s)
(NEXT inst-pt))
......@@ -1410,10 +1446,9 @@ constant = #(nlocals nstack constants code)
(LABEL post-negation)
(PRSTACK sp fp)
(<let> ((SCM n (<*> inst-pt))
#;(int tp (scm->int (<ref> inst-pt (<c> 1)))))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(RESTORE-STATE-TAIL s p n ctrl-stack)
(UNWIND s)
(<=> inst-pt (<+> inst-pt (<c> 1)))
(RESTORE-STATE-TAIL s p cut n ctrl-stack)
(UNWIND-TAIL s)
(<call> gp_fluid_force_bang *gp-is-delayed?* (<scm> #f) s)
(NEXT inst-pt))
......
......@@ -40,12 +40,12 @@ head_at_true(#t,_,A,C,Lab,Lab2,L1,LLX) :- L1=LLX, Lab2=Lab.
head_at_true(#f,#f,A,C,Lab,Lab2,L1,LLX) :-
tr(unwind,Unwind),
label(Lab2),
L1=[[label,Lab,U],[Unwind,A,Lab2,0,C]|LLX].
L1=[[label,Lab,U],[Unwind,A,Lab2]|LLX].
head_at_true(#f,#t,A,C,Lab,Lab2,L1,LLX) :-
label(Lab2),
tr('unwind-tail',UnwindTail),
L1=[[label,Lab,U],[UnwindTail,A,C]|LLX].
L1=[[label,Lab,U],[UnwindTail,A]|LLX].
compile_disjunction
([X],First,Aq,Ae,Out,Lab,A,Tail,S0,[U],V,[L,LL]) :- !,
......
......@@ -163,7 +163,8 @@ compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
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),!,
L = [[Newframe,Lab,0] | LX],
(zero(V) -> Tp is 0 ; Tp is 2),
L = [[Newframe,Lab,Tp] | LX],
LM = [LX, [[label,Out] | LL]],
get_EBH(V,B,Ed,H),
add_missing_variables(H,U,Ed,Ed,EEd),!,
......@@ -201,13 +202,20 @@ compile_goal(\\+X,Tail,V,[L,LL]) :- !,
get_ACESB(V,A,C,E,S,B),
CC is C + 1,
set_CE(V,CC,0),
compile_goal(X,#f,V,[LX,LLX]),
get_A(V,A1),
(A==A1 -> true ; throw(mismatching_begin_end_in_negation)),
set_ACESB(V,A,C,E,S,B),
label(Al),label(Bl),label(Cl),
L = [ [Newframe,A,B] |LX ],
LLX = [ [Unwind,Al,Cl],[label,Bl],[Post,Al],[label,Cl] | LLL].
ifc(compile_goal(X,#f,V,[LX,LLX]),Er,
(
tfc(Er),
(Er==#t -> throw(#f) ; throw(#t))
),
(
get_A(V,A1),
(A==A1 -> true ; throw(mismatching_begin_end_in_negation)),
set_ACESB(V,A,C,E,S,B),
label(Al),label(Bl),
(A=[[0|_]|_] -> Tp is 1 ; Tp is 3),
L = [ [Newframe,Al,Tp] |LX ],
LLX = [ [Unwind,Al,Bl],[label,Al],[Post,Al],[label,Bl] | LLL]
)).
......@@ -281,9 +289,12 @@ compile_goal(X is Y,Tail,V,[L,LL]) :- !,
compile_goal(unify_with_occurs_check(X,Y),Tail,V,L) :- !,
zero(V) ->
compile_goal((begin_att,uni_0(X,Y),end_att),Tail,V,L);
compile_goal(uni_0(X,Y),Tail,V,L).
(
X==Y -> throw(#t) ;
zero(V) ->
compile_goal((begin_att,uni_0(X,Y),end_att),Tail,V,L);
compile_goal(uni_0(X,Y),Tail,V,L)
).
compile_goal(uni_0(X,Y),Tail,V,[L,LL]) :- !,
check_tail(Tail),
......@@ -291,19 +302,25 @@ 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) :- !,
zero(V) ->
compile_goal((begin_att,uni_x(X,Y),end_att),Tail,V,L);
compile_goal(uni_x(X,Y),Tail,V,L).
(
X==Y -> throw(#t) ;
zero(V) ->
compile_goal((begin_att,uni_x(X,Y),end_att),Tail,V,L);
compile_goal(uni_x(X,Y),Tail,V,L)
).
compile_goal(uni_x(X,Y),Tail,V,[L,LL]) :- !,
check_tail(Tail),
tail(Tail,LL,LLL),
compile_unify(X,Y,V,[L,LLL],#t).
compile_goal(X = Y,Tail,V,L) :- !,
zero(V) ->
compile_goal((begin_att,uni(X,Y),end_att),Tail,V,L);
compile_goal(uni(X,Y),Tail,V,L).
compile_goal(X == Y,Tail,V,L) :- !,
(
X==Y -> throw(#t) ;
zero(V) ->
compile_goal((begin_att,uni(X,Y),end_att),Tail,V,L);
compile_goal(uni(X,Y),Tail,V,L)
).
compile_goal(uni(X,Y),Tail,V,[L,LL]) :- !,
check_tail(Tail),
......
......@@ -32,21 +32,16 @@ handle_all([X|Y],I,II,L,LL) :-
handle([label,N],I,II,L,LL) :- !,
N=I,I=II,LL=L.
handle((X,[('goto-inst';'store-state';'post-negation'),N]),
handle((X,[('goto-inst';'store-state';'post-negation';'unwind-tail'),N]),
I,II,L,LL) :- !,
II is I + 2,
L=[X|LL].
handle((X,[(newframe;'newframe-negation';'unwind-negation';'unwind-tail'),A,B,C]),
handle((X,[(newframe;'newframe-negation';'unwind-negation';'unwind'),A,B]),
I,II,L,LL) :- !,
II is I + 3,
L=[X|LL].
handle((X,[unwind,A,B,C,Cut]),
I,II,L,LL) :- !,
II is I + 5,
L=[X|LL].
handle([label,N,[_,Tags]],I,II,L,LL) :- !,
N=I,
addvs(Tags,I,II,L,LL).
......
......@@ -16,19 +16,21 @@ compile_unify(X,Y,V,[L,LL],M) :-
X==Y -> (!,throw(#t));
var(X) ->
(
!,touch_A(V),
!,
(
constant(Y) ->
(
tr('unify-constant-2',Unify),
regconst(Y,YY),
add_var(X,V,Tag1),
(isFirst(Tag1) -> true ; touch_A(V)),
L = [[Unify,Tag1,YY,M]|LL]
);
instruction(Y) ->
(
tr('unify-instruction-2',Unify),
add_var(X,V,Tag1),
(isFirst(Tag1) -> true ; touch_A(V)),
L = [[Unify,Tag1,Y,M]|LL]
);
......@@ -38,6 +40,7 @@ compile_unify(X,Y,V,[L,LL],M) :-
tr('unify-2',Unify),
add_var(X,V,Tag1),
add_var(Y,V,Tag2),
((isFirst(Tag1) ; isFirst(Tag2)) -> true ; touch_A(V)),
((isFirst(Tag1),isFirst(Tag2),M=#f) -> throw(#f) ; true),
L = [[Unify,Tag1,Tag2,M]|LL]
);
......@@ -45,12 +48,13 @@ compile_unify(X,Y,V,[L,LL],M) :-
tr('push-variable',Push),
L=[[Push,Tag1]|L1],
add_var(X,V,Tag1),
(isFirst(Tag1) -> true ; touch_A(V)),
push_v(1,V),
compile_imprint(Y,V,L1,LL,M)
)
)
) ;
var(Y) -> (!, touch_A(V),compile_unify(Y,X,V,[L,LL],M)).
var(Y) -> (!,compile_unify(Y,X,V,[L,LL],M)).
compile_unify([X|LX],[Y|LY],V,L,M) :- !,
link_l(L,L1,L2),
......
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