bugfixing

parent 45e4ebb3
......@@ -2204,7 +2204,7 @@ add/run * vlist *
(lambda (x)
(syntax-case x ()
((_ (pat ...) code)
(with-syntax (((pat2 ...) (pp 'a (parse-pat-extended2 #'(pat ...)))))
(with-syntax (((pat2 ...) (pp 'a (parse-pat-extended2 #'(pat ...)))))
(pp 'lam1 #`(list (lambda ()
#,(pp 'b (mk-varpat-extended2 #'(pat ...))))
(lambda ()
......@@ -2264,11 +2264,14 @@ add/run * vlist *
(define (change-symbols a)
(define (tr a)
(if (procedure? a)
(procedure-name a)
(if (string? a)
(string->symbol a)
a)))
(match a
(('quasiquote ('unquote x)) x)
(_
(if (procedure? a)
(procedure-name a)
(if (string? a)
(string->symbol a)
a)))))
(define l (fluid-ref special-translators))
......
......@@ -93,6 +93,7 @@ variables is the most difficult part to maintain
(define vm-model
((@@ (logic guile-log code-load) gp-make-vm-model) vm-bytevector))
#|
((@@ (logic guile-log code-load) gp-setup-prolog-vm-env)
(@@ (logic guile-log macros ) dls)
(@@ (logic guile-log code-load) *delayers*)
......@@ -103,6 +104,8 @@ variables is the most difficult part to maintain
(@@ (logic guile-log macros ) gp-not-n)
(@@ (logic guile-log macros ) gp-is-delayed?)
vm-model)
|#
(define (make-vm-function a b)
((@@ (logic guile-log code-load) gp-custom-fkn)
......@@ -140,7 +143,7 @@ variables is the most difficult part to maintain
(define (parse-extended)
(set! unify_operators (combine_ops *extended*)))
(define pack-start (@@ (logic guile-log code-load) pack-start))
;(define pack-start (@@ (logic guile-log code-load) pack-start))
(define (name-it x) (set-procedure-property! x 'name 'anonymous) x)
(<define> (compile_to_fkn code f)
(<code> (parse-extended))
......
......@@ -54,10 +54,9 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
b_setval(pretty,#t),
make_state(0,[[0,_,_]],[],[[0,_]],0,0,0,0,0,[HC,HV],[],V),
wrap(compile_goal(Code,#t,V,[L,[]]),[L,[]]),!,
%print(L),nl,!,
print(L),nl,!,
get_M(V,StackSize),
handle_all(L,LL),
(var(Constants)-> get_consts(Constants);true),
print(LL),nl,!,
(Pretty==#t -> Iout=LL ; (b_setval(pretty,#f),mmtr(LL,Iout))).
......@@ -190,12 +189,10 @@ compile_goal(Op(\"recur\",Args),Tail,V,[L,LL]) :-
L1=[[label,A]|L2],
compile_goal((begin_att,Impr,end_att),Tail,V,[L2,LL]).
compile_goal((X,Y),Tail,V,L) :- !,
collect_conj((X,Y),Gs,[]),
compile_conj(Gs,Tail,V,L).
compile_goal(m_or(fail,false),#t,V,[[[fail],[cc] |L], L]).
compile_goal(m_or(fail,false),#f,V,[[[fail] |L], L]).
compile_goal(true,_,_,_) :- throw(#t).
......@@ -520,7 +517,6 @@ compile_goal(\\+X,Tail,V,L) :- !,
)).
compile_goal((m_and(Op,m_or(<,>,=<,>=,=:=,=\\=,@<,@=<,@>,@>=)))(X,Y),
Tail,V,[L,LL]) :- !,
check_tail(Tail),
......@@ -597,7 +593,6 @@ compile_goal(iss(X,Y),Tail,V,[L,LL]) :- !,
)
))).
compile_goal(unify_with_occurs_check(X,Y),Tail,V,L) :- !,
touch_Q(13,V),
(
......
......@@ -32,10 +32,10 @@
scmcall('gp-prune',[scut],I,_,L7,L8),
reset(I,L8,LL).
'sp-move'(V,I,II,L,LL) :-
-trace.
'sp-move'(_,V,I,II,L,LL) :-
II is I - 1,
gset(V,svar(II),I,L,LL),
gset(V,sp(II),I,L,L1),
reset(II,L1,LL).
'equal-instruction'(C,I,II,L,LL) :-
......
......@@ -8,7 +8,7 @@
((eq? s 'reset) 'pl-reset)
(else s))))
#:export (ggset unify unify-2 unify-constant-2
#:export (ggset unify unify-2 unify-constant-2 unify-instruction-2
unify-instruction pre-unify post-unify-tail
post-unify
))
......@@ -23,7 +23,7 @@
'pre-unify'(V,I,L,LL) :-
vset('call?',c(0),I,L,L1),
gset(V,top(delayers),I,L,L1).
gset(V,c(delayers),I,L1,LL).
'post-unify'(V,Nsloc,I,L,LL) :-
gref(V,I,L,L1),
......@@ -47,7 +47,7 @@
label(E,LL),
cc(L7,LL).
-trace.
unify(Code,V,I,II,L,LL) :-
M is (Code /\\ 3),
A is (Code /\\ 4) >> 2,
......@@ -110,13 +110,11 @@
)
).
'unify-constant-2'(Code,V,I,L,LL) :-
M is Code /\\ 3,
A is (Code /\\ 4) >> 2,
K is (Code /\\ 24) >> 3,
'unify-instruction-2'(M,C,V,K,I,II,L,LL) :- 'unify-constant-2'(M,C,V,K,I,II,L,LL).
-trace.
'unify-constant-2'(M,C,V,K,I,I,L,LL) :-
(
K == #f ->
gset(V,c(C),I,L,LL);
(
......
......@@ -2,24 +2,26 @@
#:use-module (logic guile-log iso-prolog)
#:export (reset gset gref move scmcall make_p make_cc j je jne
label gfalse gtrue isTrue pltest lookup2
test sp cc vec cut scut pp pltest_s))
test sp cc s c vec cut stack call? scut pp pltest_s))
(compile-prolog-string
"
generate(Tok,[Tok|LL],LL).
id(s ,sp(0)).
id(p ,sp(1)).
id(cut ,sp(2)).
id(scut ,sp(3)).
id(vec ,sp(4)).
id(stack ,sp(5)).
id(cc ,var(0)).
id(s ,sp(0)).
id(p ,sp(1)).
id(cut ,var(0)).
id(scut ,var(1)).
id(vec ,var(2)).
id(stack ,var(3)).
id(cc ,var(4)).
id('call?' ,var(5)).
sp(6).
e(cc(C),I,II,L,LL) :- cc(C,I,II,L,LL).
e(pp,I,II,L,LL) :- pp(I,II,L,LL).
-trace.
reset(I,L,LL) :-
call(II is I),
generate(reset(II),L,LL).
......@@ -37,20 +39,21 @@
move(I,J,L,LL) :-
call(II is I),
call(JJ is J),
generate(move(II,JJ),L,LL) .
generate(move(II,JJ),L,LL).
gref(c(X),I,L,LL) :-
-trace.
gref(c(X),I,L,LL) :- !,
constant(X,I,L,LL).
gref(var(X),I,L,LL) :-
gref(var(X),I,L,LL) :- !,
var_ref(X,I,L,LL).
gref(sp(X),I,L,LL) :- !,
move(X,I,L,LL).
gref(l(X),I,L,LL) :- !,
generate('label-ref'(I,X),L,LL).
gref(sp(X),I,L,LL) :-
move(X,I,L,LL).
gref(A,I,L,LL) :-
id(A,X),
gref(X,I,L,LL).
......@@ -82,7 +85,7 @@
gref(c(X),I,L,L1),
move(I,J,L1,LL).
gset(var(V),Val,I,L,LL) :-
gset(var(V),Val,I,L,LL) :- !,
vset(V,Val,I,L,LL).
gset(sp(V),Val,I,L,LL) :- !,
......@@ -99,7 +102,8 @@
generate('handle-interrupts',L3,L4),
I = N,
generate('pl-setup-frame',L4,LL).
-trace.
args([],I,I,L,L).
args([X|A],I,II,L,LL) :-
......@@ -107,18 +111,19 @@
I1 is I + 1,
args(A,I1,II,L1,LL).
-trace.
scmcall(F,Args,I,II,L,LL) :-
length(Args,N),
NN is N + 1,
NNN is I + NN,
reset(NNN,L,L1),
args(Args,I,I1,L1,L2),
gref(F,I1,L2,L3),
args(Args,I,I1,L1,L2),
gref(c(F),I1,L2,L3),
I2 is I1 + 1,
generate(handle_interupts,L3,L4),
generate(call(I2,NN),L3,L4),
generate(call(I2,NN),L4,L5),
II is I2 + 1,
reset(II,L4,LL).
reset(II,L5,LL).
j(Label,L,LL) :-
generate(j(Label),L,LL).
......@@ -132,14 +137,13 @@
label(Label,L,LL) :-
generate(label(Label),L,LL).
gfalse(I,L,LL) :-
gref(I,p,I,L,L1),
gfalse(I,I,L,LL) :-
gref(p,I,L,L1),
generate('immediate-tag?='(I,7,0),L2,L3),
generate(je(A),L3,L4),
generate(goto(I),L4,L5),
label(A,L5,L6),
II is I + 1,
scmtailcall(sp(I),[],II,L6,LL).
II is I + 1.
gtrue(I,L,L).
......@@ -147,15 +151,17 @@
call(II is I),
generate(test1(true,II,Label),L,LL).
-trace.
pltest(F,A,I,II,L,LL) :-
scmcall(F,A,I,I,II,L,L1),
scmcall(F,A,I,II,L,L1),
isTrue(sp(II-1),II,Label,L1,L2),
gfalse(II,L2,L3),
gfalse(II,_,L2,L3),
label(Label,L3,LL).
-trace.
pltest_s(F,A,I,L,LL) :-
pltest(F,A,I,II,L,L1),
gset(s,sp(II-1),L1,LL).
gset(s,sp(II-1),II,L1,LL).
lookup2(I,L,LL) :-
scmcall('gp-lookup',[sp(I-2),s],I,L,L1),
......
......@@ -24,7 +24,7 @@
newframe-negation store-state store-ps store-p
;; utils
gfalse gtrue
gfalse gtrue sp
;; push
cutter goto-inst sp-move equal-instruction
......@@ -34,7 +34,7 @@
;; unify
ggset unify unify-2 unify-constant-2
unify-instruction pre-unify post-unify-tail
post-unify
post-unify unify-instruction-2
;; fkn
......
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