recur tested

parent d5609276
......@@ -13,7 +13,7 @@
#:export (compilable_scm collect_data
make-vm-function
compile_to_fkn
instr))
instr define-prolog))
(define instr (@@ (logic guile-log guile-prolog vm vm-pre) instr))
......@@ -176,4 +176,20 @@ variables is the most difficult part to maintain
(list->vector constants)
tvar))))))))))
(define readline_term_str (@@ (logic guile-log guile-prolog interpreter)
readline_term_str))
(compile-prolog-string "
generate_lambda(X,F) :-
readline_term_str(X,T,[variables(V),variable_names(N)]),
compile_to_fkn(T,F).
")
(define-syntax-rule (define-prolog n code-string)
(define n (letrec ((n
(let ((g (prolog-run 1 (f)
(generate_lambda code-string f))))
(if (null? g)
(error "failed compile")
(car g)))))
n)))
......@@ -27,7 +27,7 @@ constant = #(nlocals nstack constants code)
(auto-defs)
(eval-when (compile eval load)
(define debug #t))
(define debug #f))
(define-syntax DB
(lambda (x)
......@@ -271,12 +271,21 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule (PRSTACK sp fp)
(DB (<icall> 'printf (<c> "sp - fp . %d\n") (<-> fp sp))))
(define-syntax-rule (LABEL s)
(begin
(TOUCH s 1)
(<begin>
(<label> s)
(PRINTF "%s : %d\n" (symbol->string 's) (hash-ref *map* 's 0)))))
(define-syntax LABEL
(lambda (x)
(syntax-case x ()
((_ s)
(if debug
#'(begin
(TOUCH s 1)
(<begin>
(<label> s)
(PRINTF "%s : %d\n"
(symbol->string 's) (hash-ref *map* 's 0))))
#'(begin
(TOUCH s 1)
(<label> s)))))))
#;
(define-syntax-rule (LABEL s)
......@@ -737,9 +746,9 @@ constant = #(nlocals nstack constants code)
(<recur> lp ()
(<if> (q> sp xp)
(<begin>
(<icall> 'printf
(<c> "wrong stack state sp - xp = %d, will equalize\n")
(<-> xp sp))
(PRINTF
(<c> "wrong stack state sp - xp = %d, will equalize\n")
(<-> xp sp))
(<=> sp xp))
(<if> (q< sp xp)
(<begin>
......@@ -922,7 +931,12 @@ constant = #(nlocals nstack constants code)
(REGISTER op2< ls)
(REGISTER op2>= ge)
(REGISTER op2=< le)
(REGISTER gtL)
(REGISTER ltL)
(REGISTER geL)
(REGISTER leL)
(REGISTER =:= eq)
(REGISTER #{=\\=}# neq)
sp))
......@@ -1170,21 +1184,28 @@ constant = #(nlocals nstack constants code)
(<call> schmop x)))
(define-syntax-rule (CMP op schmop p instructions inst-pt fp sp)
(<let> ((y (<let> ((nn (<*> inst-pt)))
(<++> inst-pt)
(<if> (<call> scm_is_false nn)
(<let> ((xx (ARG -1 sp)))
(CLEAR 1 sp)
xx)
nn)))
(x (ARG -1 sp)))
(<let> ((x (ARG -2 sp))
(y (ARG -1 sp)))
(CLEAR 2 sp)
(FORMAT "~a ~a ~a~%\n" x (<scm> 'schmop) y)
(<if> (<and> (<call> SCM_I_INUMP x) (<call> SCM_I_INUMP y))
(<if> (<not> (op x y))
(BACKTRACK p instructions inst-pt fp sp))
(<if> (<call> scm_is_false (<call> schmop x y))
(BACKTRACK p instructions inst-pt fp sp)))
(CLEAR 1 sp)))
(BACKTRACK p instructions inst-pt fp sp)))))
(define-syntax-rule (CMP-1 op schmop p instructions inst-pt fp sp)
(<let> ((x (<*> inst-pt))
(y (ARG -1 sp)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(CLEAR 1 sp)
(FORMAT "~a ~a ~a~%\n" x (<scm> 'schmop) y)
(<if> (<and> (<call> SCM_I_INUMP x) (<call> SCM_I_INUMP y))
(<if> (<not> (op x y))
(BACKTRACK p instructions inst-pt fp sp))
(<if> (<call> scm_is_false (<call> schmop x y))
(BACKTRACK p instructions inst-pt fp sp)))))
(define-syntax-rule (NOTCMP op schmop p instructions inst-pt fp sp)
(<let> ((y (<let> ((nn (<*> inst-pt)))
......@@ -2082,6 +2103,16 @@ constant = #(nlocals nstack constants code)
(CMP q> scm_gr_p p instructions inst-pt fp sp)
(NEXT inst-pt)
(LABEL gtL)
(PRSTACK sp fp)
(CMP-1 q> scm_gr_p p instructions inst-pt fp sp)
(NEXT inst-pt)
(LABEL ltL)
(PRSTACK sp fp)
(CMP-1 q< scm_less_p p instructions inst-pt fp sp)
(NEXT inst-pt)
(LABEL ls)
(PRSTACK sp fp)
(CMP q< scm_less_p p instructions inst-pt fp sp)
......@@ -2092,10 +2123,20 @@ constant = #(nlocals nstack constants code)
(CMP q>= scm_geq_p p instructions inst-pt fp sp)
(NEXT inst-pt)
(LABEL geL)
(PRSTACK sp fp)
(CMP-1 q>= scm_geq_p p instructions inst-pt fp sp)
(NEXT inst-pt)
(LABEL le)
(PRSTACK sp fp)
(CMP q>= scm_leq_p p instructions inst-pt fp sp)
(NEXT inst-pt)
(LABEL leL)
(PRSTACK sp fp)
(CMP-1 q>= scm_leq_p p instructions inst-pt fp sp)
(NEXT inst-pt)
(LABEL eq)
(PRSTACK sp fp)
......
......@@ -164,14 +164,9 @@ rec(F,A,N,Args,Tail,V,[L,LL]) :-
touch_A(V),
set_FS(V,F,S),
(
Tail == #t ->
(
tr(goto-inst,Goto),
LL2 = [[Goto,A]|LL]
);
throw(recur_call_only_at_tail_position(F))
tr('goto-inst',Goto),
LL2 = [[Goto,A]|LL]
).
")
......@@ -157,13 +157,14 @@ compile_goal((F :- Goal),Tail,V,L) :- !,
wrap(compile_goal((pop(4),Goal),Tail,V,L),L).
compile_goal(Op(recur,F(|U)),Tail,V,L) :-
compile_goal(Op(\"recur\",Args),Tail,V,[L,LL]) :-
Args = F(|U),
Op=\"op2*\",!,
get_line(U,X,Xin,N),
reverse(X,XX),
mg(recur(|U),XX,Impr,0,N),
add_recur(F,A,N),
push_args(Xin,V,L,L1),
push_args_args(Xin,V,L,L1),
L1=[[label,A]|L2],
compile_goal((begin_att,Impr,end_att),Tail,V,[L2,LL]).
......@@ -349,7 +350,8 @@ compile_goal((m_and(Op,m_or(<,>,=<,>=,=:=,=\\=,@<,@=<,@>,@>=)))(X,Y),
(
push_v(-2,V),
tr(Op,OOp),
binop(OOp,O)
binop(OOp,O),
LY=[[Op]|LLL]
))).
compile_goal(X is Y,Tail,V,L) :- !,
......
......@@ -108,20 +108,16 @@ handle(['push-variable',[[S,V,Q],N,F|_]],I,II,L,LL) :- !,
(
(F==#t,N==1) -> (L=[[pushv,#f]|LL] , II is I + 2);
F==#t -> (new_var(V,Q,S), L=[[pushv,V]|LL] , II is I + 2);
N==1 -> (L=[['push-variable',V,1]|LL] , II is I + 3);
(new_var(V,Q,S), L=[['push-variable',V,0]|LL], II is I + 3)
).
handle(['push-variable-scm',[[S,V,Q],N,F|_]],I,II,L,LL) :- !,
(
F==#t ->
throw(first_variable_in_scheme_context);
N==1 ->
(L=[['push-variable-scm',V]|LL], II is I + 2);
(
throw(pushes_new_variable_to_scheme_context)
)).
F==#t ->
throw(first_variable_in_scheme_context);
(L=[['push-variable-scm',V]|LL], II is I + 2)
).
handle([unify,[[S,V,Q],N,F|_],M],I,II,L,LL) :- !,
(
......
......@@ -31,7 +31,7 @@ compile_imprint([Y|LY],V, L,LL,M) :- !,
touch_A(V),
(M=#f -> tr('icons',Icons) ; tr('icons!',Icons)),
L=[[Icons]|L1],
push_v(1,V1),
push_v(1,V),
compile_imprint(Y ,V,L1,L2,M),
compile_imprint(LY,V,L2,LL,M).
......
......@@ -20,7 +20,7 @@
(<define> (get_recur x y n)
(let ((a (vhash-ref (fluid-ref *recurs*) (<lookup> x) #f)))
(if a
(<=> (y n) (,(car a) (cdr a))))))
(<=> (y n) (,(car a) ,(cdr a))))))
(<define> (add_recur x y n)
(<code> (fluid-set! *recurs*
......@@ -251,10 +251,10 @@ t(dup).
t(=..).
t(>).
t(<).
t(>=).
t(=<).
bin1(>,gtL,gtR).
bin1(< ,ltL,ltR).
bin1(>=,geL,geR).
bin1(=<,leL,leR).
t(=:=).
t(=\\=).
t(@<).
......
......@@ -363,11 +363,11 @@ push_v(N,V) :-
get_line(U,X,Xin,N) :-
get_line(U,X,Xin,0,N).
get_line(((A,B),U),[A|X],[B|Xin],I,N) :- !,
get_line([(A,B)|U],[A|X],[B|Xin],I,N) :- !,
II is I + 1,
get_line(U,X,Xin,II,N).
get_line((A,U),[A|X],[_|Xin],I,N) :- !,
get_line([A|U],[A|X],[_|Xin],I,N) :- !,
II is I + 1,
get_line(U,X,Xin,II,N).
......
......@@ -722,6 +722,4 @@
(append ffkn (map (lambda (x) (gp-make-var))
(append vars ovars)))))))
(set! (@@ (logic guile-log match) compile-prolog) compile-prolog)
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