further improvements

parent 7f80659f
......@@ -265,12 +265,20 @@ generate_stx(STX,X,F) :-
(syntax->datum
#'code-string)
meta))))
(if (null? g)
(lambda x (error "not implemented"))
(if (null? g)
(begin
(warn "compilation failed of "
(syntax->datum #'n))
#'(lambda x
(error
(format #f "not implemented ~a"
'n))))
(if (not (eq? (car g) 1))
(car g)
(lambda x
(error "not implemented"))))))))
#'(lambda x
(error
(format #f "not implemented ~a"
'n)))))))))
(letrec ((n (lambda x
(let ((gg (g)))
(module-set! (resolve-module '#,(cur x))
......
......@@ -8,7 +8,10 @@
#:use-module (logic guile-log guile-prolog vm vm-var)
#: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
))
(compile-prolog-string "'with-cut'. 'without-cut'.")
#|
By setting a procedure as 'with-cut we can pass under the radar
......
......@@ -3,7 +3,7 @@
(use-modules (logic guile-log guile-prolog vm-compiler))
(define-prolog f1 "
f(N,I,J,S) :-
f1(N,I,J,S) :-
I < N ->
(
II is I + 1,
......
......@@ -1180,6 +1180,11 @@ void gp_init_stacks()
gp_stacks = scm_make_fluid_with_default(SCM_EOL);
gp_nil_fr = gp_make_variable();
gp_nil_ci = gp_make_variable();
scm_t_bits tag = GP_MK_FRAME_EQ(gp_type);
SET_FRAME(tag);
GP_GETREF(gp_nil_fr)[0] = SCM_PACK(GP_MK_FRAME_EQ(gp_type));
GP_GETREF(gp_nil_ci)[0] = SCM_PACK(tag);
GP_GETREF(gp_nil_fr)[1] = scm_from_int(GP_FRAMESIZE);
GP_GETREF(gp_nil_ci)[1] = scm_from_int(0);
}
......
//#define DB(X) X
#define DB(X) X
#define STATE_LOGICAL 0
#define STATE_DYNSTACK 1
......@@ -206,7 +206,7 @@ static inline int gp_advanced_fr(SCM item, int state, SCM *old, SCM gp_unbd)
case gp_redo_tag:
if(!SCM_CONSP(item))
scm_misc_error("unwind","d",SCM_EOL);
if(!SCM_CONSP(*old))
if(!SCM_CONSP(*old) && state == gp_store)
scm_misc_error("unwind","e",SCM_EOL);
item = SCM_CDR(item);
......@@ -402,13 +402,13 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
mask_on(gp->id,&gp_unbd,SCM_PACK(GP_MK_FRAME_UNBD(gp_type)));
DB(printf("unwind> ci %x gp_ci %x\n",ci - gp->gp_cstack,
gp->gp_ci - gp->gp_cstack));
DB(printf("unwind> fi %x gp_fi %x\n",fr - gp->gp_frstack,
gp->gp_fr - gp->gp_frstack));
if(gp->gp_ci < ci)
if(gp->gp_fr < fr)
{
return;
scm_misc_error("gp_unwind","wrong unwind forward in time",SCM_EOL);
scm_misc_error("gp_unwind","wrong unwind forward in time (fr)",SCM_EOL);
}
ci_old = gp->gp_ci;
......@@ -524,6 +524,16 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
}
out0:
DB(printf("unwind> ci %x gp_ci %x\n",ci - gp->gp_cstack,
gp->gp_ci - gp->gp_cstack));
if(gp->gp_ci < ci)
{
return;
scm_misc_error("gp_unwind","wrong unwind forward in time (ci)",SCM_EOL);
}
state = 0;
old = SCM_EOL;
......@@ -823,7 +833,7 @@ static inline void gp_unwind_(SCM s, int ncons, int nvar, int nfr)
ci = gp->gp_cstack + GP_GET_VAL_VAL(fr);
if(!scm_is_eq(*ci,GP_GET_VAL(fr)))
if(!SCM_CONSP(fr) && !scm_is_eq(*ci,GP_GET_VAL(fr)))
scm_misc_error("gp-unwind","ci self entry is not the same~%~a",
scm_list_1(*ci));
......@@ -1411,6 +1421,9 @@ static int gp_rewind_fr(SCM pp, SCM pend, struct gp_stack *gp)
}
gp->gp_fr += GP_FRAMESIZE;
int ch = GP_GET_CHOICE(gp->gp_fr);
GP_SET_VAR(gp->gp_fr, gp->gp_si, ch, gp);
GP_SET_CONS(gp->gp_fr, gp->gp_cs, gp);
set_self(gp);
......@@ -1560,11 +1573,10 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
if(n > m)
{
gp_debug0("n > m\n");
gp_debug2("n > m %d > %d\n",n,m);
pp_x = pathfr;
for(;n > m; n--)
{
gp_debug2("restore n > m %d > %d\n",n,m);
if(SCM_CONSP(pp_x))
pp_x = SCM_CDR(pp_x);
else
......@@ -1573,6 +1585,7 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
,scm_list_3(pp_x,
SCM_I_MAKINUM(n), SCM_I_MAKINUM(m)));
}
gp_debug2("restore n == m %d > %d\n",n,m);
}
if(n != m)
......@@ -1591,10 +1604,10 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
si = gp->gp_stack + GP_GET_VAR (fr);
cs = gp->gp_cons_stack + GP_GET_CONS (fr);
ci = gp->gp_cstack + GP_GET_VAL_VAL (fr);
ci = gp->gp_cstack + GP_GET_VAL_VAL (fr) + 1;
if(!scm_is_eq(*ci,GP_GET_VAL(fr)))
scm_misc_error("restore-satate","ci self entry is not the same~%~a"
if(!SCM_CONSP(*(ci - 1)) && !scm_is_eq(*(ci - 1),GP_GET_VAL(fr)))
scm_misc_error("restore-state","ci self entry is not the same~%~a"
, scm_list_1(*ci));
if(si > gp->gp_si) si = gp->gp_si;
......@@ -1616,7 +1629,7 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
check("valstack", ci, pp_c, path);
gp_debug0("rewind ci\n");
gp_rewind(path, pp_c, gp);
gp_rewind(path, pp_c, gp);
gp_debug0("rewind fr\n");
gp_rewind_fr(pathfr,pp_x, gp);
......@@ -1715,4 +1728,5 @@ SCM_DEFINE(gp_add_unwind_hook, "gp-add-unwind-hook", 1, 0, 0, (SCM x),
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
//#define DB(X)
#define DB(X)
......@@ -2916,29 +2916,46 @@ SCM_DEFINE(gp_print_stack, "gp-print-stack", 2, 0, 0, (SCM s, SCM allp),
for(i = gp->gp_frstack; i < gp->gp_fr; i++)
{
printf("i=%ld fr=%lx\n",i - gp->gp_frstack,SCM_UNPACK(*i));
if(scm_is_true(allp))
format1("<fr> = ~a~%",*i);
if(scm_is_true(allp))
{
printf("i=%ld fr=%lx | ",i - gp->gp_frstack,SCM_UNPACK(*i));
format2("<fr:~a> = ~a~%",scm_from_ulong(i - gp->gp_frstack),*i);
}
else
printf("i=%ld fr=%lx\n",i - gp->gp_frstack,SCM_UNPACK(*i));
}
for(i = gp->gp_cstack; i < gp->gp_ci; i++)
{
printf("i=%ld ci=%lx\n",i - gp->gp_cstack,SCM_UNPACK(*i));
if(scm_is_true(allp))
format1("<ci> = ~a~%",*i);
if(scm_is_true(allp))
{
printf("i=%ld ci=%lx | ",i - gp->gp_cstack,SCM_UNPACK(*i));
format2("<ci:~a> = ~a~%",scm_from_ulong(i - gp->gp_frstack),*i);
}
else
printf("i=%ld ci=%lx\n",i - gp->gp_cstack,SCM_UNPACK(*i));
}
for(i = gp->gp_stack; i < gp->gp_si; i++)
{
printf("%ld v %lx\n",i - gp->gp_stack,SCM_UNPACK(*i));
if(scm_is_true(allp))
format1("<si> = ~a~%",*i);
if(scm_is_true(allp))
{
printf("%ld v %lx | ",i - gp->gp_stack,SCM_UNPACK(*i));
format1("<si> = ~a~%",*i);
}
else
printf("%ld v %lx\n",i - gp->gp_stack,SCM_UNPACK(*i));
}
for(i = gp->gp_cons_stack; i < gp->gp_cs; i++)
{
printf("%ld cons %lx\n",i - gp->gp_cons_stack,SCM_UNPACK(*i));
if(scm_is_true(allp))
format1("<cs> = ~a~%",*i);
if(scm_is_true(allp))
{
printf("%ld cons %lx | ",i - gp->gp_cons_stack,SCM_UNPACK(*i));
format1("<cs> = ~a~%",*i);
}
else
printf("%ld cons %lx\n",i - gp->gp_cons_stack,SCM_UNPACK(*i));
}
return SCM_UNSPECIFIED;
}
......
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