everythingy compiles

parent 957524e9
......@@ -51,7 +51,7 @@
(lambda x #f)
(lambda x
(gp-add-unwind-hook
(lambda (s)
(lambda ()
(<wrap-s>
(<lambda> ()
(<gc-call> 1 '() (<lambda> () (goal-eval code))))
......
......@@ -33,14 +33,14 @@ 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,LW,LW) :- var_p(X),!,K==#f,
push_args_args(K,X,V,L,LL,_,_) :- var_p(X),!,K==#f,
push_args(X,V,L,LL).
push_args_args(#f,[X|Y],V,L,LL,_,_) :- !,
......@@ -48,12 +48,12 @@ push_args_args(#f,[X|Y],V,L,LL,_,_) :- !,
push_args_args(Y,V,L1,LL).
push_args_args(with_cut,[X|Y],V,L,LL,LW,LLW) :- !,
L=[['push-closure',Label]|LL]
L=[['push-closure',Label]|L1],
push_code_with_cut(X,Label,V,LW,LLW),
push_args_args(Y,V,L1,LL).
push_args_args(without_cut,[X|Y],V,L,LL,LW,LLW) :- !,
L=[['push-closure',Label]|LL]
L=[['push-closure',Label]|L1],
push_code_without_cut(X,Label,V,L,L1),
push_args_args(Y,V,L1,LL).
......@@ -169,7 +169,7 @@ caller(F,Args,Tail,V,[L,LL]) :-
push_v(3,V),
tr(seek,Seek),
L3=[[Seek,3]|L4],
argkind(F,K)
argkind(F,K),
push_args_args(K,Args,V,L4,LL2,LW,LL),
touch_A(V),
set_FS(V,scm[(gensym \"F\")],S),
......
......@@ -25,11 +25,11 @@ cat(F,G) :-
collect_disj([],U,U).
collect_disj([A *-> B]|L],U,UU) :-
U=[['soft-if-f',A,B,';'(|L)]|UU].
collect_disj(['*->'(A,B)|L],U,UU) :-
U=['soft-if-f'(A,B,';'(|L))|UU].
collect_disj([A -i> B]|L],U,UU) :-
U=[['interleaving-if-f',A,B,';'(|L)]|UU].
collect_disj(['-i>'(A,B)|L],U,UU) :-
U=['interleaving-if-f'(A,B,';'(|L))|UU].
collect_disj([X|L],U,UU) :-
collect_disjunction(X,U,U1),
......
......@@ -46,7 +46,7 @@ and rgard removes it from the list going backwards reverses the actions.
(<with-cut> cut2 b)))))))))))))
(<define> (soft-if-f a b c) (<soft-if> (a) (b) (c)))
(set-procedure-property soft-if-f 'argkind 'with-cut)
(set-procedure-property! soft-if-f 'argkind 'with-cut)
(define-guile-log <setup-call-cleanup-once>
(syntax-rules ()
......
......@@ -76,18 +76,47 @@ struct gp_stack
#define GP_FRAMESIZE 6
#define CHOICE_BIT (1UL<<63)
#define GP_GET_HANDLERS(fr) ((fr)[-6])
#define GP_GET_DLENGTH(fr) SCM_UNPACK((fr)[-5]))
#define GP_GET_DLENGTH(fr) SCM_UNPACK(((fr)[-5]))
#define GP_GET_SELF(fr) ((fr)[-4])
#define GP_GET_VAR(fr) (scm_to_ulong(((fr)[-3])) & ~CHOICE_BIT)
#define GP_GET_VAL(fr) ((fr)[-2])
#define GP_GET_CHOICE(fr) (scm_to_ulong(((fr)[-3])) & CHOICE_BIT)
#define GP_SET_SELF(fr,c) ((fr)[-4] = (c))
#define GP_SET_HANDLERS(fr,gp) ((fr)[-6] = ((gp)->handlers))
#define GP_SET_DLENGTH(fr,gp) ((fr)[-5] = SCM_PACK(gp->dynstack_length))
#define GP_SET_VAL(fr,c,gp) ((fr)[-2] = (c))
#define GP_SET_VAL(fr,c) ((fr)[-2] = (c))
#define GP_SET_CONS(fr,c,gp) ((fr)[-1] = scm_from_ulong((c) - gp->gp_cons_stack))
inline ulong GP_GET_CHOICE(SCM *fr)
{
SCM a = fr[-3];
ulong x = scm_to_ulong(a);
return (x & CHOICE_BIT);
}
inline void set_self(struct gp_stack *gp)
{
SCM val = scm_from_uint(gp->gp_fr - gp->gp_frstack);
SCM *f = GP_GETREF(GP_GET_SELF(gp->gp_fr));
f[1] = val;
}
inline ulong GP_GET_SELF_TAG(SCM tag)
{
return scm_to_ulong(GP_GETREF(tag)[1]);
}
inline ulong GP_GET_SELF_SELF(SCM *fr)
{
SCM* f = GP_GETREF(GP_GET_SELF(fr));
return scm_to_ulong(f[1]);
}
inline ulong GP_GET_VAL_VAL(SCM *fr)
{
SCM* f = GP_GETREF(GP_GET_VAR(fr));
return scm_to_ulong(f[1]);
}
inline void GP_SET_VAR(SCM *fr, SCM *c, scm_t_bits ch, struct gp_stack *gp)
{
if(ch)
......@@ -101,14 +130,6 @@ inline ulong GP_GET_CONS(SCM *fr)
return scm_to_ulong(get_touched_tag(fr[-1]));
}
inline void set_self(struct gp_stack *gp, SCM *ci)
{
GP_SET_CONS(gp->gp_fr, gp->gp_cs);
GP_SET_VAR (gp->gp_fr, gp->gp_si);
GP_SET_VAL (gp->gp_fr, gp->gp_ci, GP_GET_CHOICE(gp->gp_fr), gp);
}
#define GP_TEST_FRSTACK if(gp->gp_fr > gp->gp_nnfr) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_nfr))
#define GP_TEST_CSTACK if(gp->gp_ci > gp->gp_nnc) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_nc))
......@@ -165,26 +186,30 @@ static inline void init_gp_cons(SCM *cand)
static inline SCM *get_gp_cons(struct gp_stack *gp)
{
SCM cand;
SCM *cand;
gp_debug0("get_gp_cons\n");
GP_TEST_CCSTACK;
cand = *(gp->gp_cs);
if(!GP(cand))
SCM candi = *(gp->gp_cs);
if(!GP(candi))
{
cand = gp_make_cons();
gp->gp_cs[0] = cand;
candi = gp_make_cons();
gp->gp_cs[0] = candi;
}
cand = GP_GETREF(candi);
gp->gp_cs ++;
init_gp_cons(GP_GETREF(cand));
init_gp_cons(cand);
SCM *v1 = get_gp_var(gp);
SCM *v2 = get_gp_var(gp);
cand[1] = GP_UNREF(v1);
cand[2] = GP_UNREF(v2);
return GP_GETREF(cand);
return cand;
}
static inline SCM *get_gp_cons_pure(struct gp_stack *gp)
......@@ -1144,8 +1169,10 @@ static void gp_module_stack_init()
void gp_init_stacks()
{
gp_stacks = scm_make_fluid_with_default(SCM_EOL);
gp_nil = gp_make_variable();
GP_GETREF(gp_nil)[1] = scm_from_int(GP_FRAMESIZE);
gp_nil_fr = gp_make_variable();
gp_nil_ci = gp_make_variable();
GP_GETREF(gp_nil_fr)[1] = scm_from_int(GP_FRAMESIZE);
GP_GETREF(gp_nil_ci)[1] = scm_from_int(0);
}
......@@ -1249,7 +1276,7 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
// compress the ci si and cs stack
{
SCM *cs = (SCM*)0, *si=(SCM*)0, *ci = (SCM*)0;
SCM *cs = (SCM*)0, *si=(SCM*)0;
cs = GP_GET_CONS(pt1) + gp->gp_cons_stack;
si = GP_GET_VAR (pt1) + gp->gp_stack;
#define macro \
......@@ -1312,16 +1339,15 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
} \
\
} \
} \
}
}
macro;
GP_SET_VAR (pt1_insert, pt2_insert, ch, gp);
GP_SET_VAR (pt1_insert, pt2_insert, choice_p, gp);
GP_SET_CONS(pt1_insert, pt3_insert, gp);
}
continue;
}
}
*pt1_insert = *pt1;
......@@ -1341,21 +1367,21 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
gp->gp_cs = pt3_insert;
}
while(pt4 < ci)
while(pt4 < gp->gp_ci)
{
if(SCM_CONSP(*pt4) && SCM_NIMP(SCM_CAR(*pt4)))
{
x = get_touched_tag(*pt4);
SCM x = get_touched_tag(*pt4);
if(x && GP(x) && GP_FRAME_VAR(x))
{
SCM *f = GP_UNREF(x);
f[1] = scm_from_ulong(pt4_insert - gp->gp_cistack);
SCM *f = GP_GETREF(x);
f[1] = scm_from_ulong(pt4_insert - gp->gp_cstack);
}
}
if(*pt4 && GP(*pt4) && GP_FRAME_VAR(*pt4))
{
SCM *f = GP_UNREF(*pt4);
f[1] = scm_from_ulong(pt4_insert - gp->gp_cistack);
SCM *f = GP_GETREF(*pt4);
f[1] = scm_from_ulong(pt4_insert - gp->gp_cstack);
}
if(scm_is_false(*pt4))
{
......
......@@ -253,8 +253,7 @@ item
static inline int gp_do_cons_fr(SCM item, int state, SCM *old, SCM gp_unbd)
{
tag = SCM_CAR(item);
gp_advanced_fr(item,state,old,gp_unbd);
return gp_advanced_fr(item,state,old,gp_unbd);
}
static inline int gp_do_cons(SCM item, int state, SCM *old, SCM gp_unbd)
......@@ -351,8 +350,8 @@ SCM unwind_hooks = SCM_BOOL_F;
//#define DB(X) X
static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
{
SCM val, old = SCM_EOL;
SCM *i, iold = SCM_EOL, *fr_old, *ci_old, *id;
SCM val, old = SCM_EOL;
SCM *i, *fr_old, *ci_old, *id;
int state = 0;
SCM gp_unbd;
......@@ -495,7 +494,6 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
gp_debug1("ci iter %x\n",i - gp->gp_cstack);
if(SCM_CONSP(*i))
{
iold = SCM_CDR(*i);
state = gp_do_cons(*i, state, &old, gp_unbd);
continue;
}
......@@ -505,7 +503,7 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
if(GP(*i) && GP_FRAME_VAR(*i))
{
MASK_OFF(*i);
MASK_OFF();
}
retry_for_false:
......@@ -744,11 +742,9 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
if(!SCM_NULLP(l))
{
l = scm_reverse(l);
SCM * f = set_ci_scm(ci, gp);
SCM s = scm_cons(GP_UNREF(f), SCM_EOL);
while(!SCM_NULLP(l))
{
scm_call_1(SCM_CAR(l), s);
scm_call_0(SCM_CAR(l));
l = SCM_CDR(l);
}
}
......@@ -756,18 +752,18 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
}
//#define DB(X)
static inline void gp_unwind_(SCM fr, int ncons, int nvar)
static inline void gp_unwind_(SCM s, int ncons, int nvar)
{
struct gp_stack *gp = get_gp();
SCM *fr, *ci,*si,*cs,lt;
scm_t_bits dyn_n;
SCM ha, tag = SCM_EOL;
if(GP(fr) && GP_CONSP(fr))
if((GP(s) && GP_CONSP(s)) || SCM_CONSP(s))
{
tag = gp_car(gp_car(fr, fr),fr)
lt = gp_gp_cdr(fr,fr);
fr = GP_GET_FR(tag,fr);
tag = gp_car(gp_car(s, s),s);
lt = gp_gp_cdr(s,s);
fr = gp->gp_frstack + GP_GET_SELF_TAG(tag);
if(vlist_p(lt))
{
vhash_truncate_x(lt);
......@@ -779,7 +775,7 @@ static inline void gp_unwind_(SCM fr, int ncons, int nvar)
}
ha = GP_GET_HANDLERS(fr);
dyn_n = SCM_UNPACK(GP_GET_DLENGTH(fr));
dyn_n = GP_GET_DLENGTH(fr);
ci = gp->gp_cstack + GP_GET_VAL_VAL(fr);
si = gp->gp_stack + GP_GET_VAR(fr) - nvar;
cs = gp->gp_cons_stack + GP_GET_CONS(fr) - ncons;
......@@ -800,7 +796,7 @@ static inline void gp_unwind_(SCM fr, int ncons, int nvar)
static inline void gp_unwind(SCM fr)
{
gp_unwind(fr,0,0)
gp_unwind_(fr,0,0);
}
static inline void gp_unwind_soft(int ncons)
......@@ -812,12 +808,12 @@ static inline void gp_unwind_soft(int ncons)
static inline void gp_unwind_ncons(SCM fr, int ncons)
{
gp_unwind(fr,ncons+2,2)
gp_unwind_(fr,ncons,0);
}
static inline void gp_unwind_tail(SCM fr)
{
gp_unwind(fr,2,2)
gp_unwind_(fr,2,2);
}
SCM_DEFINE(gp_gp_unwind, "gp-unwind", 1, 0, 0, (SCM fr),
......@@ -925,7 +921,7 @@ static inline SCM gp_store_state(struct gp_stack *gp)
data = gp->gp_fr[-1];
headfr = SCM_EOL;
SCM headfr = SCM_EOL;
if(SCM_CONSP(data) && SCM_I_INUMP(SCM_CAR(data)))
{
gp_debug1("store state, got tag %x\n",SCM_UNPACK(SCM_CAR(data)));
......@@ -1024,7 +1020,7 @@ static inline SCM * gp_get_branch(SCM *p, SCM *fr, struct gp_stack *gp)
SCM pt = *p;
for(;fr > gp->gp_frstack;)
{
for(;fr > gp->gp_frstack && SCM_NIMP(fr) ; fr -= GP_FRAMESIZE)
for(;fr > gp->gp_frstack && SCM_I_INUMP(*fr) ; fr -= GP_FRAMESIZE)
{
int i = 0;
for(i=0;i<GP_FRAMESIZE;i++)
......@@ -1048,6 +1044,8 @@ static inline SCM * gp_get_branch(SCM *p, SCM *fr, struct gp_stack *gp)
return fr;
}
}
return SCM_EOL;
}
//#define DB(X) X
......@@ -1108,17 +1106,14 @@ static int gp_rewind(SCM pp, SCM pend, struct gp_stack *gp)
gp_debug0("consp\n");
if(GP(SCM_CAR(q)))
{
else
{
gp_debug0("gp\n");
id = GP_GETREF(SCM_CAR(q));
q = SCM_CDR(q);
gp_store_var_2(id,1,gp);
id[0] = SCM_PACK(SCM_I_INUM(SCM_CAR(q)));
id[1] = SCM_CDR(q);
}
gp_debug0("gp\n");
id = GP_GETREF(SCM_CAR(q));
q = SCM_CDR(q);
gp_store_var_2(id,1,gp);
id[0] = SCM_PACK(SCM_I_INUM(SCM_CAR(q)));
id[1] = SCM_CDR(q);
}
else
{
......@@ -1150,7 +1145,7 @@ static int gp_rewind(SCM pp, SCM pend, struct gp_stack *gp)
static int gp_rewind_fr(SCM pp, SCM pend, struct gp_stack *gp)
{
SCM *id,q,stack[51 + GP_FRAMESIZE];
SCM q,stack[51 + GP_FRAMESIZE];
int sp;
gp_debug0("entering a rewind frame\n");
......@@ -1193,10 +1188,9 @@ static int gp_rewind_fr(SCM pp, SCM pend, struct gp_stack *gp)
q = SCM_CAR(pp);
int i = 0;
for(i = 0; i < GP_FRAMESIZE; i++)
for(i = 0; i < GP_FRAMESIZE; i++, sp--)
{
gp->gp_fr[i] = SCM_CAR(stack[sp]);
sp--;
}
gp->gp_fr += GP_FRAMESIZE;
......@@ -1227,19 +1221,45 @@ void POP(SCM * pp){
SCM gp_scan_tail(SCM path, SCM *ci, struct gp_stack *gp)
{
SCM pt = path;
while(1)
int error = 0;
SCM x;
if(SCM_CONSP(*ci))
{
SCM tag = SCM_CAR(*ci);
if(SCM_I_INUMP(tag))
{
if(SCM_UNPACK(tag) == gp_redo_tag)
x = SCM_CADR(*ci);
else
x = *ci;
}
else
error = 1;
}
else
error = 2;
if(error)
{
if(SCM_NULLP(pt))
return pt;
scm_misc_error("restore-state/scan_tail","ERROR TAG code ~a",
scm_list_1(scm_from_int(error)));
}
else
while(1)
{
if(SCM_NULLP(pt))
return pt;
if(check_fr_pt(ci,pt))
return pt;
if(scm_is_eq(pt, x))
return pt;
pt = SCM_CDR(pt);
}
if(SCM_CONSP(pt))
pt = SCM_CDR(pt);
}
}
voif check(char * str, SCM* fr, SCM pp_x, SCM path)
void check(char * str, SCM* fr, SCM pp_x, SCM path)
{
int fail = 0;
if(SCM_CONSP(*fr))
......@@ -1276,9 +1296,9 @@ voif check(char * str, SCM* fr, SCM pp_x, SCM path)
//#define DB(X) X
static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
{
SCM *si, path;
SCM *si, path, pathfr;
int n, m;
SCM *ci,*fr_x,*cs, pp_x;
SCM *ci,*fr, *fr_x,*cs, pp_x;
scm_t_bits dynstack_length;
SCM gp_unbd, dynstack;
SCM rguards;
......@@ -1296,7 +1316,7 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
n = SCM_I_INUM(v[STATE_N]);
path = v[STATE_PATH];
pathfr = v[CONTROL_PATH];
m = gp->gp_fr - gp->gp_frtack;
m = gp->gp_fr - gp->gp_frstack;
}
else
{
......@@ -1317,7 +1337,6 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
m = n;
}
redo:
if(n > m)
{
gp_debug0("n > m\n");
......@@ -1344,16 +1363,16 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
check("frame", fr, pp_x, pathfr);
si = GP_GET_VAR (fr);
cs = GP_GET_CONS (fr);
ci = GP_GET_VAL (fr);
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);
if(si > gp->gp_si) si = gp->gp_si;
if(cs > gp->gp_cs) cs = gp->gp_cs;
if(fr < gp->fr)
if(fr < gp->gp_fr)
gp_unwind0(fr, ci, si, cs, gp);
SCM pp_c = gp_scan_tail(path, pp_c, ci, gp);
SCM pp_c = gp_scan_tail(path, ci, gp);
check("valstack", ci, pp_c, path);
gp_rewind(path, pp_c, gp);
......@@ -1426,21 +1445,6 @@ SCM_DEFINE(gp_clear_frame_x, "gp-clear-frame!", 1, 0, 0, (SCM s),
"if s points to a numbered frame, then we will clear it")
#define FUNC_NAME s_gp_cear_frame_x
{
struct gp_stack *gp = get_gp();
SCM *pt, *end = (SCM*) 0;
return SCM_UNSPECIFIED;
gp_no_gc();
if(SCM_CONSP(s))
end = get_ci_from_f(SCM_CAR(s), gp);
else
return SCM_UNSPECIFIED;
pt = gp->gp_ci;
if(pt == end)
return gp_clear_frame();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
......
......@@ -268,6 +268,15 @@ scm_t_bits gp_smob_t;
#define SET_FRAME(x) ((x) = (x) | GPI_FRAME)
#define FRAMEP(x) ((x) & GPI_FRAME)
#define GP_CONSP(x) GP_CONS(GP_GETREF(x))
inline int GP_FRAME_VAR(SCM x)
{
if(GP(x))
return FRAMEP(SCM_UNPACK(GP_GETREF(x)[0]));
else
return 0;
}
inline int gp_is_free(SCM *pt)
{
scm_t_bits head = SCM_UNPACK(GP_GETREF(*pt)[0]);
......@@ -522,42 +531,41 @@ static inline void handle_force(SCM *id, SCM flags, SCM v)
*(id + 1) = v;
}
SCM * set_fr(SCM *fr, struct gp_stack *gp)
inline SCM * set_fr(SCM *fr, struct gp_stack *gp)
{
SCM *f = get_gp_var(gp);
SCM flags = SCM_PACK(GP_MK_FRAME_EQ(gp_type));
SET_FRAME(flags);
handle_force(f, flags, scm_from_ulong(gp->gp_fr - gp->gp_frstack));
GP_SET_SELF(fr,GP_UNREF(f));
return f;
}
// We will add f to ci stack, hence it must be one larger
SCM * set_ci(SCM *fr, struct gp_stack *gp)
inline SCM * set_ci(SCM *fr, struct gp_stack *gp)
{
SCM *f = get_gp_var(gp);
SCM flags = SCM_PACK(GP_MK_FRAME_EQ(gp_type));
scm_t_bits tflags = GP_MK_FRAME_EQ(gp_type);
SET_FRAME(flags);
SET_FRAME(tflags);
SCM flags = SCM_PACK(tflags);
handle_force(f, flags, scm_from_ulong(1UL + gp->gp_ci - gp->gp_cstack));
handle_force(f, flags, scm_from_ulong(1 + gp->gp_ci - gp->gp_cstack));
GP_SET_VAL(fr,GP_UNREF(f));
return f;
}
SCM * set_fr_scm(SCM *fr, struct gp_stack *gp)
inline SCM * set_fr_scm(SCM *fr, struct gp_stack *gp)
{
SCM *f = GP_GETREF(gp_make_variable());
SCM flags = SCM_PACK(GP_MK_FRAME_EQ(gp_type));
SET__FRAME(flags);
handle_force(f, flags, scm_from_ulong(gp->gp_fr - gp->gp_cstack));
GP_SET_SELF(fr,GP_UNREF(f));
return f;
......@@ -1213,7 +1221,7 @@ static inline SCM gp_newframe(SCM s)
{
SCM ret;
SCM *f1, SCM *f2, *cons1 *cons2;
SCM *f1, *f2, *cons1, *cons2;
SCM *fr;
gp_debug0("newframe\n");
GP_TEST_CSTACK;
......@@ -1227,17 +1235,17 @@ static inline SCM gp_newframe(SCM s)
GP_SET_HANDLERS(fr,gp);
GP_SET_DLENGTH(fr,gp);
f1 = set_fr(fr,gp);
f2 = set_ci(fr,gp,0);
gp->gp_ci[0] = f2;
f2 = set_ci(fr,gp);
gp->gp_ci[0] = GP_UNREF(f2);
gp->gp_ci++;
cons1 = get_gp_cons_pure(gp);
cons2 = get_gp_cons_pure(gp);
cons2[1] = f1;
cons2[2] = f2;
cons2[1] = GP_UNREF(f1);
cons2[2] = GP_UNREF(f2);
GP_SET_VAR(fr,gp->gp_si,0);
GP_SET_VAR(fr,gp->gp_si,0,gp);
GP_SET_CONS(fr,gp->gp_cs,gp);
cons1[1] = GP_UNREF(cons2);
cons1[2] = l;
......@@ -1266,7 +1274,7 @@ static inline SCM gp_newframe_choice(SCM s)
{
SCM ret;
SCM *f1, SCM *f2, *cons1 *cons2;
SCM *f1, *f2, *cons1, *cons2;
SCM *fr;
gp_debug0("newframe\n");
GP_TEST_CSTACK;
......@@ -1280,17 +1288,17 @@ static inline SCM gp_newframe_choice(SCM s)
GP_SET_HANDLERS(fr,gp);
GP_SET_DLENGTH(fr,gp);
f1 = set_fr(fr,gp);
f2 = set_ci(fr,gp,0);
gp->gp_ci[0] = f2;
f2 = set_ci(fr,gp);
gp->gp_ci[0] = GP_UNREF(f2);
gp->gp_ci++;
cons1 = get_gp_cons_pure(gp);
cons2 = get_gp_cons_pure(gp);
cons2[1] = f1;
cons2[2] = f2;
cons2[1] = GP_UNREF(f1);
cons2[2] = GP_UNREF(f2);
GP_SET_VAR(fr,gp->gp_si,1);
GP_SET_VAR(fr,gp->gp_si,1,gp);
GP_SET_CONS(fr,gp->gp_cs,gp);
cons1[1] = GP_UNREF(cons2);
cons1[2] = l;
......@@ -2692,7 +2700,7 @@ SCM_DEFINE(gp_atomicp,"gp-atomic?",2,0,0,(SCM x, SCM s),
}
#undef FUNC_NAME
static void gp_unwind0(SCM *ci, SCM *sim, SCM *cs, struct gp_stack *gp);
static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp);
void gp_unwind_dynstack(struct gp_stack *gp, scm_t_bits dyn_n);
SCM_DEFINE(gp_clear, "gp-clear", 1, 0, 0, (SCM s),
......@@ -2701,7 +2709,10 @@ SCM_DEFINE(gp_clear, "gp-clear", 1, 0, 0, (SCM s),
{
struct gp_stack *gp = get_gp();
gp_debug0("clear\n");
gp_unwind0(gp->gp_cstack + 4,gp->gp_stack, gp->gp_cons_stack, gp);
gp_unwind0(gp->gp_frstack + GP_FRAMESIZE,
gp->gp_cstack + 1,
gp->gp_stack,
gp->gp_cons_stack, gp);
gp_debug0("clear 2\n");
gp_unwind_dynstack(gp, 2);
gp->rguards = SCM_EOL;
......@@ -3931,18 +3942,18 @@ return SCM_UNSPECIFIED;
MK_CUSTOM_FKN_MODEL(vm__raw,gp_make_vm_model,"gp-make-vm-model");
SCM_DEFINE(gp_is_deterministic, "gp-deterministic?", 2, 0, 0, (SCM s0, SCM s)
SCM_DEFINE(gp_is_deterministic, "gp-deterministic?", 1, 0, 0, (SCM s0)
, "is there no choice points after tag")
{
struct gp_stack *gp = get_gp();
SCM tag = gp_car(tag, s);
tag = gp_car(tag, s);
SCM *fr_tag = gp->gp_frstack + scm_to_ulong(GP_VAR_VAL(tag));
SCM tag = gp_car(s0, s0);
tag = gp_car(tag, s0);
SCM *fr_tag = gp->gp_frstack + GP_GET_SELF_TAG(tag);
SCM *pt;