all utility code for vm compiler compiles by the vm compiler

parent d985199e
......@@ -12,11 +12,17 @@
(<define> (extended . l)
(<code> (error "extended is no good function")))
(define *extended* #f)
(set-procedure-property! extended 'dynamic-directive #t)
(define *extended* #f)
(define *extended-body* #f)
(<define> (set_extended L B)
(<pp> `(set_extended ,L ,B))
(<code> (set! *extended* (<scm> L)))
(<code> (set! *extended*
(let lp ((l (<scm> L)) (r '()))
(if (pair? l)
(lp (cddr l) (cons (list (car l) (cadr l)) r))
r))))
(<code> (set! *extended-body* (<scm> B))))
......
......@@ -24,11 +24,11 @@ narg([X|L],I,N) :-
narg(_,I,I).
push_code_with_cut(X,Label,V,L,LL) :-
L=[[label,Label],[clean-sp]|LX],
L=[[label,Label],['clean-sp']|LX],
compile_goal(X,#t,V,[LX,LL]).
push_code_without_cut(X,Label,V,L,LL) :-
L=[[label,Label],[clean-sp]|LX],
L=[[label,Label],['clean-sp']|LX],
compile_goal(call(X),#t,V,[LX,LL]).
push_args_args(K,X,V,L,LL,_,_) :- var_p(X),!,K==#f,
......
......@@ -9,7 +9,8 @@
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog macros)
#:use-module (logic guile-log guile-prolog vm-compiler)
#:use-module ((logic guile-log guile-prolog vm-compiler)
#:select ())
#:export (caller push_args_args2 push_args_args push_args))
#;
......
......@@ -7,7 +7,8 @@
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog macros)
#:use-module (logic guile-log guile-prolog vm-compiler)
#:use-module ((logic guile-log guile-prolog vm-compiler)
#:select ())
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var2)
#:export (compile_conj collect_conj))
......
......@@ -7,7 +7,9 @@
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log soft-cut)
#:use-module (logic guile-log guile-prolog vm-compiler)
#:use-module (logic guile-log guile-prolog macros)
#:use-module ((logic guile-log guile-prolog vm-compiler)
#:select ())
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var2)
#:export (compile_disj compile_disjunction collect_disj))
......
(<define> (set_extended x)
(<code> (set! unify_operators (combine_ops (<scm> x)))))
(<define> (gen x) (<=> x ,(gensym "disj")))
(<define> (gen-rec x) (<=> x ,(gensym "Rec")))
(<define> (get_consts x) (<=> x ,(get-consts)))
(compile-prolog-string "
reverse_op(<,>).
reverse_op(>,<).
reverse_op(=<,>=).
......@@ -13,6 +19,8 @@ reverse_op(@>=,@=<).
reverse_op(=:=,=:=).
reverse_op(=\\=,=\\=).
zero(V) :- get_A(V,A),A=[[0|_]].
print([]).
......@@ -30,7 +38,7 @@ wrap(Code,[L,LL]) :-
)).
-extended(',',m_and,;,m_or,\\+,m_not).
compile_goal(Code,Iout):-
compile_goal(Code,Iout):- !,
compile_goal(Code,Iout,StackSize,Narg,Consts,#t).
compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
......@@ -49,7 +57,8 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
%print(L),nl,!,
get_M(V,StackSize),
handle_all(L,LL),
(var(Constants)->Constants=scm[(get-consts)];true),
(var(Constants)-> get_consts(Constants);true),
%print(LL),nl,!,
(Pretty==#t -> Iout=LL ; (b_setval(pretty,#f),mmtr(LL,Iout))).
......@@ -153,7 +162,7 @@ compile_goal((F :- Goal),Tail,V,L) :- !,
wrap(compile_goal((pop(4),Goal),Tail,V,L),L).
compile_goal(newtag_F(F),Tail,V,[L,L]) :-
F=scm[(gensym \"disj\")].
gen(F).
compile_goal(extended_off,Tail,V,[L,L]) :- !,
set_extended(#f).
......@@ -177,7 +186,8 @@ compile_goal(Op(\"recur\",Args),Tail,V,[L,LL]) :-
push_args_args(#f,Xin,V,L,L1,_,_),
touch_A(V),
touch_Q(10,V),
%set_F(V,scm[(gensym \"Rec\")]),
%gen_rec(Sym)
%set_F(V,Sym)
L1=[[label,A]|L2],
compile_goal((begin_att,Impr,end_att),Tail,V,[L2,LL]).
......@@ -222,7 +232,7 @@ compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
)
).
compile_goal(verbatim_call(X),Tail,V,[L,LL]) :-
compile_goal(verbatim_call(X),Tail,V,[L,LL]) :- !,
( \\+var_p(X),
(
F(|Args)=X ->
......@@ -235,7 +245,7 @@ compile_goal(verbatim_call(X),Tail,V,[L,LL]) :-
!,
compile_goal(X,Tail,V,[L,LL]).
compile_goal(call(X),Tail,V,[L,LL]) :-
compile_goal(call(X),Tail,V,[L,LL]) :- !,
( \\+var_p(X),
(
F(|Args)=X ->
......@@ -339,7 +349,6 @@ compile_goal(\\+X,Tail,V,[L,LL]) :- !,
),
(
get_A(V,A1),
(A==A1 -> true ; throw(mismatching_begin_end_in_negation)),
set_QACESB(V,Q,A,C,E,S,B),
(A=[[0|_]|_] -> Tp is 0 ; Tp is 1),
L = [ [Newframe,Al,Tp] |LX ],
......@@ -362,6 +371,7 @@ compile_goal((m_and(Op,m_or(<,>,=<,>=,=:=,=\\=,@<,@=<,@>,@>=)))(X,Y),
push_v(-1,V),
reverse_op(Op,Or),
binop1L(Or,O),
tr(O,OO),
LY=[[OO,EX]|LLL]
))
......@@ -488,6 +498,7 @@ isApply([X|L]) :- isApply(L).
ncons(X,N) :-
ncons(X,0,N).
")
......
......@@ -6,7 +6,8 @@
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log prolog swi)
#:use-module (logic guile-log guile-prolog macros)
#:use-module (logic guile-log guile-prolog vm-compiler)
#:use-module ((logic guile-log guile-prolog vm-compiler)
#:select ())
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var2)
#:use-module (logic guile-log guile-prolog vm vm-args2)
......@@ -19,7 +20,6 @@
#:use-module (system vm assembler)
#:export (begin_att end_att recur verbatim_call with_cut pr
extended_off extended_on))
#;
(eval-when (compile)
(pk (prolog-run-rewind 1 (x)
......
......@@ -146,16 +146,14 @@ handle(['newvar', _],I,I,L,L) :- !.
handle([cutter,[[S1,V1,Q1],N1,F1|_],[[S2,V2,Q2],N2,F2|_]],I,II,L,LL) :-
!,
(
F==#t -> throw(end_with_no_begin) ;
(
new_var(V1,Q1,S1),
new_var(V2,Q2,S2),
V1=[V1C|_],
V2=[V2C|_],
VC is V1C + V2C << 16,
L=[[cutter,VC]|LL],
II is I + 2
)
new_var(V1,Q1,S1),
new_var(V2,Q2,S2),
(V1=[V1C|_] -> E1=0 ; (V1=V1C,E1=1)),
(V2=[V2C|_] -> E2=0 ; (V2=V2C,E2=1)),
E is E1 + E2 << 1,
VC is V1C + V2C << 16 + E << 32,
L=[[cutter,VC]|LL],
II is I + 2
).
handle(['pre-unify',At,Vx],I,II,L,LL) :- !,
......@@ -692,8 +690,6 @@ code([push3,V1,V2,V3],Code,Action) :-
Code is V1C + V2C << 16 + V3C << 32 + A << 48,
Action = 'push-3variables-x'.
code3(V1,V2,V3,C) :- C is V1 + V2 << 16 + V3 << 32.
code2(V1,V2,C) :- C is V1 + V2 << 16.
......
......@@ -5,7 +5,8 @@
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log prolog swi)
#:use-module (compat racket misc)
#:use-module (logic guile-log guile-prolog vm-compiler)
#:use-module ((logic guile-log guile-prolog vm-compiler)
#:select ())
#:use-module (logic guile-log guile-prolog macros)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var2)
......
......@@ -7,7 +7,8 @@
#:use-module (logic guile-log prolog swi)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog vm-compiler)
#:use-module ((logic guile-log guile-prolog vm-compiler)
#:select ())
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var2)
#:export (compile_scm))
......
......@@ -6,6 +6,7 @@
#:use-module (logic guile-log prolog swi)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog macros)
#:use-module (logic guile-log guile-prolog vm-compiler)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var2)
......
......@@ -433,8 +433,9 @@ get_line([A|U],[A|X],[_|Xin],I,N) :- !,
get_line(_,[],[],I,I).
%:- dynamic([compile_goal/2]).
compile_goal.
:- dynamic([compile_goal/2]).
collect_F.
newtag_F.
......
......@@ -8,7 +8,8 @@
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog macros)
#:use-module (logic guile-log guile-prolog vm-compiler)
#:use-module ((logic guile-log guile-prolog vm-compiler)
#:select ())
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:replace (first)
#:export ())
......
......@@ -1180,7 +1180,7 @@
(define (test x)
(let ((x (module-ref (current-module) x)))
(if (and (procedure? x)
(procedure-property x 'module))
(procedure-property x 'dynamic-directive))
#t
#f)))
......
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