general is operators

parent e48805c6
......@@ -16,6 +16,10 @@ By setting a procedure as 'with-cut we can pass under the radar
(<=> k #f))))
(<define> (gen_f x) (<=> x ,(gensym "F")))
(<define> (need_s f)
(when (eq? (object-property (<lookup> f) 'prolog-functor-type) #:scm)))
(compile-prolog-string "
narg(X,N,N) :- var_p(X),!.
narg([X|L],I,N) :-
......@@ -60,6 +64,15 @@ push_args_args2([X|Y],V,L,LL) :- !,
push_args_args2([],V,L,LL) :-
push_args([],V,L,LL).
push_args_args3(X,V,L,LL) :- var_p(X),!,
push_args(X,V,L,LL).
push_args_args3([X|Y],V,L,LL) :- !,
push_args(X,V,L,L1),
push_args_args3(Y,V,L1,LL).
push_args_args3([],V,L,L).
push_args(X,V,L,LL) :- var_p(X),!,
add_var(X,V,Tag),
push_v(1,V),
......@@ -173,6 +186,53 @@ caller(F,Args,Tail,V,[L,LL]) :-
)
))).
-trace.
scm_caller(F,Args,Tail,V,L,LL) :-
length(Args,Nargs),
push_args_args3(Args,V,L,L1),
(
need_s(F) ->
(
L1=[['push-s']|L2],
N is Nargs + 1
);
(
L2=L1,
N is Nargs
)
),
L2=[['push-instruction',F]|L3],
(
Tail == #t ->
L3 = [['scm-call',N],[cc]|LL];
L3 = [['scm-call',N]|LL]
).
scm_caller2(F,Args,Tail,V,L,LL) :-
length(Args,Nargs),
(
need_s(F) ->
(
L=[['push-s']|L2],
N is Nargs + 1
);
(
L2=L,
N is Nargs
)
),
L2=[['push-instruction',F]|L3],
(
Tail == #t ->
L3 = [['scm-call',N],[cc]|LL];
L3 = [['scm-call',N]|LL]
).
rec(F,A,N,Args,Tail,V,[L,LL]) :-
(narg(Args,0,N) -> true ; throw(recur_call_wrong_number_of_arguments(F))),
tr('clear-sp' , Clear),
......
......@@ -9,6 +9,6 @@
#:use-module (logic guile-log vm vm)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:export (caller push_args_args2 push_args_args push_args))
#:export (caller push_args_args2 push_args_args push_args scm_caller scm_caller2))
(include-from-path "logic/guile-log/guile-prolog/vm/vm-args-model.scm")
......@@ -62,6 +62,12 @@ handle([\"label\",C],I,I,L,LL) :- !,
I=II,
inlabel(C,L,LL).
handle([\"scm-call\",N],I,II,L,LL) :- !,
II is I - N,
NN is N + 1,
scmcall0(NN,II,I,L,LL).
handle([\"label\",C,D],I,I,L,LL) :- !,
I=II,
inlabel(C,D,L,LL).
......
(define (ele s x)
((@@ (logic guile-log guile-prolog set) ele)
s (lambda () (error "wrong set construction")) (lambda (s p x) x) x))
(set-object-property! ele 'prolog-functor-type #:scm)
(compile-prolog-string
"
rev(X,Y) :-
rev(X,[],Y).
rev([],X,X).
rev([A|X],Y,Z) :-
YY = [A|Y],
rev(X,YY,Z).
-trace.
-extended.
compile_scm(X,V,L,LL) :-
......@@ -59,4 +73,28 @@ compile_scm((Op,(+ ; - ; \\))(X),V,L,LL) :- !,
LX=[[O]|LL]
)
)).
compile_scm({X},V,L,LL) :- !,
scm_caller(ele,[X],#f,V,L,LL).
compile_scm(F(|X),V,L,LL) :- !,
rev(X,XX),
allcom(XX,V,L,L1),
scm_caller2(F,X,#f,V,L1,LL).
allcom([A|U],V,L,LL) :- !,
ifc(compile_scm(A,V,L,L1),EX,
(
write('EX'(EX)),nl,
(number(EX) -> true ; throw(EX)),
L=[['push-instruction',EX]|L1]
),
(
true
)),
allcom(U,V,L1,LL).
allcom([],V,L,L).
")
......@@ -8,6 +8,7 @@
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (logic guile-log guile-prolog vm vm-args)
#:use-module (logic guile-log vm vm)
#:export (compile_scm))
......
......@@ -15,7 +15,7 @@
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log vm fkn)
#:export (in-call cc-call in-tailcall in-post-call post-unicall
push-3 pushtail-3 handle-spcc cut))
push-3 pushtail-3 handle-spcc cut scmcall0))
(compile-prolog-string
"
......@@ -89,5 +89,10 @@
gset(p,cut,I,L,LL).
cut(_,V,I,I,L,LL) :-
gset(p,V,I,L,LL).
-trace.
scmcall0(N,II,I,L,LL) :-
generate(call(N,I),L,L1),
reset(II,L1,LL).
")
......@@ -18,7 +18,7 @@
;; call
in-call cc-call in-tailcall in-post-call post-unicall
push-3 pushtail-3 handle-spcc cut
push-3 pushtail-3 handle-spcc cut scmcall0
;; newframe
newframe-ps newframe-pc newframe-psc newframe-light newframe
......
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