Old functionality untouched by engines

parent f7f826f3
......@@ -141,6 +141,11 @@
gp-make-struct
gp-set-struct
gp-pop-engine
gp-push-engine
gp-peek-engine
gp-combine-engines
))
;; Tos silence the compiler, those are fetched from the .so file
......
......@@ -16,13 +16,14 @@
(frame (<newframe>))
(p P)
(cc CC))
(<code> (gp-combine-engines data)
(<pit> cc
(<with-p> p
(<with-s> (gp-push-engine frame engine)
code
(<=> v ,(gp-pop-engine)))))
...
(<with-fail> p (<code> (gp-combine-engines data))))))
(<with-fail> p <cc>)))))
......
......@@ -43,7 +43,7 @@ SCM make_logical()
return ret;
}
inline get_l(SCM l)
inline SCM get_l(SCM l)
{
return SCM_CAR(l);
}
......@@ -184,7 +184,7 @@ inline SCM logical_lookup3(SCM x, SCM l)
inline SCM logical_lookup_l(SCM x, SCM *l)
{
l = &(get_l(*l));
l = GP_GETREF(get_l(*l));
gp_debug0("logiacl l lookup\n");
if(!GP(x))
......
......@@ -1533,25 +1533,8 @@ SCM_DEFINE(gp_clear_frame, "gp-clear-frame", 0, 0, 0, (),
gp_do_gc();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_push_engine, "gp-push-engine", 0, 0, 0, (SCM frame, SCM new_engine),
"")
#define FUNC_NAME s_gp_push_engine
{
SCM old_engine = scm_fluid_ref(gp_current_stack);
SCM p = scm_cons(frame, old_engine);
gp_engine_path = scm_cons(p, gp_engine_path);
scm_fluid_set_x(gp_current_stack, new_engine);
return scm_cons(SCM_EOL, scm_cons(SCM_EOL, p));
}
#undef FUNC_NAME
#undef FUNC_NAME
SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (),
"")
#define FUNC_NAME s_gp_pop_engine
......@@ -1567,11 +1550,10 @@ SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (),
gp_engine_path = SCM_CDR(gp_engine_path);
return s_stack;
return SCM_CAR(s_stack);
}
#undef FUNC_NAME
#undef FUNC_NAME
SCM_DEFINE(gp_peek_engine, "gp-peek-engine", 0, 0, 0, (),
"")
#define FUNC_NAME s_gp_peek_engine
......@@ -1587,9 +1569,36 @@ SCM_DEFINE(gp_peek_engine, "gp-peek-engine", 0, 0, 0, (),
}
#undef FUNC_NAME
SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 0, 0, 0, (SCM l),
SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
"")
#define FUNC_NAME s_gp_peek_engine
#define FUNC_NAME s_gp_push_engine
{
SCM x = scm_cons(SCM_BOOL_F,e);
SCM car;
SCM cdr;
if(SCM_CONSP(s) || GP_CONSP(s))
{
car = gp_car(s,s);
cdr = gp_gp_cdr(s,s);
}
else
{
car = SCM_BOOL_F;
cdr = scm_cons(SCM_EOL,SCM_EOL);
}
SCM ss;
gp_engine_path = scm_cons(x , gp_engine_path);
ss = scm_cons(car, scm_cons(SCM_CAR(cdr), gp_engine_path));
SCM_SETCAR(x, ss);
return ss;
}
#undef FUNC_NAME
SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 1, 0, 0, (SCM l),
"")
#define FUNC_NAME s_gp_combine_engine
{
SCM vec = scm_c_make_vector (1,l);
struct gp_stack * gp = get_gp();
......@@ -1599,6 +1608,6 @@ SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 0, 0, 0, (SCM l),
gp->gp_ci[0] = vec;
gp->gp_ci++;
return ret;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
......@@ -575,32 +575,35 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp,
if(scm_is_false(*i))
continue;
/*
current_path => '((sk . ek) ... (s1 . ek))
path => '((s1' . ek) ... (sk* . ek*))
We assume that we cons unwind path onto current path
*/
if(SCM_I_IS_VECTOR(*i))
{
SCM l = SCM_SIMPLE_VECTOR_REF(*i,0);
SCM p = SCM_EOL(path) ? SCM_BOOL_F : SCM_CAR(path);
SCM p = SCM_CAR(path);
if(scm_is_false(p))
{
unwind_all_in_branch(l);
unwind_all_in_branch(l);
}
else
{
int found = 0;
for(;SCM_CONSP(l);l=SCM_CDR(l))
{
if(scm_is_eq(SCM_CAR(l), p))
SCM x = gp_variable_ref(SCM_CAR(l));
if(scm_is_eq(x, p))
{
found = 1;
unwind_in_new_branch(p,SCM_CDR(path), lpath);
unwind_in_new_branch(p, SCM_CDR(path), lpath);
ci = i + 1;
break;
}
}
if(!found) unwind_all_in_branch(l);
}
}
while(SCM_CONSP(l))
{
SCM item = SCM_CAR(l);
if(!found) unwind_all_in_branch(l);
}
}
......@@ -854,18 +857,25 @@ void unwind_all_in_branch(SCM l)
for(; SCM_CONSP(l); l = SCM_CDR(l))
{
SCM new_engine = SCM_CDAR(l);
scm_fluid_set_x(gp_current_stack, new_engine);
gp_clear();
SCM x = gp_variable_ref(SCM_CAR(l));
if(SCM_CONSP(x))
{
SCM new_engine = SCM_CDR(x);
scm_fluid_set_x(gp_current_stack, new_engine);
gp_clear(SCM_BOOL_F);
}
}
scm_fluid_set_x(gp_current_stack, old_engine);
}
static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
SCM path, SCM lpath);
void unwind_in_new_branch(SCM p, SCM path, SCM lpath)
{
SCM engine = SCM_CDR(p);
SCM gp_engine_path = scm_cons(p, gp_engine_path);
gp_engine_path = scm_cons(p, gp_engine_path);
scm_fluid_set_x(gp_current_stack, engine);
if(SCM_CONSP(path))
......@@ -874,31 +884,85 @@ void unwind_in_new_branch(SCM p, SCM path, SCM lpath)
}
else
{
gp_unwind_(SCM_CAR(p, 0, 0, 0, path, lpath);
gp_unwind_(SCM_CAR(p), 0, 0, 0, path, lpath);
}
}
static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
SCM path, SCM lpath)
/*
path = [bk, ..., a0, x, ...]
l = [ak, ..., a0, x, ...]
*/
static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
SCM path, SCM lpath)
{
if(scm_is_false(path))
SCM lt = SCM_EOL;
if(scm_is_false(lpath))
{
lt = gp_gp_cdr(s,s);
if(SCM_CONSP(lt))
path = SCM_CDR(lt);
else
path = SCM_EOL;
path = gp_engine_path;
if(SCM_CONSP(path))
{
SCM l = gp_engine_path;
SCM a = scm_reverse(l);
SCM b = scm_reverse(path);
SCM aa = a;
while(SCM_CONSP(a) && SCM_CONSP(b) && scm_is_eq(SCM_CAR(a),SCM_CAR(b)))
{
aa = a;
a = SCM_CDR(a);
b = SCM_CDR(b);
}
SCM a0 = SCM_CAR(aa);
while(SCM_CONSP(l) && !scm_is_eq(SCM_CAR(l), a0))
{
SCM engine = SCM_CDAR(l);
scm_fluid_set_x(gp_current_stack, engine);
gp_clear(SCM_BOOL_F);
l = SCM_CDR(l);
}
scm_fluid_set_x(gp_current_stack, SCM_CDAR(l));
path = b;
}
}
if(SCM_CONSP(path))
{
if(scm_bool_false(lpath))
lpath = scm_list_4(s,(SCM) ncons, (SCM) nvar, (SCM) nci);
s = SCM_CAAR(path);
if(scm_is_false(lpath))
lpath = scm_list_4(s,SCM_PACK((scm_t_bits) ncons),
SCM_PACK((scm_t_bits) nvar),
SCM_PACK((scm_t_bits) nci));
ncons = 0;
nvar = 0;
nci = 0;
}
else
{
if(scm_is_true(lpath))
{
s = SCM_CAR(lpath);
lpath = SCM_CDR(lpath);
ncons = (int) SCM_UNPACK(SCM_CAR(lpath));
lpath = SCM_CDR(lpath);
nvar = (int) SCM_UNPACK(SCM_CAR(lpath));
lpath = SCM_CDR(lpath);
nci = (int) SCM_UNPACK(SCM_CAR(lpath));
}
}
struct gp_stack *gp = get_gp();
SCM *fr, *ci,*si,*cs,lt;
SCM *fr, *ci,*si,*cs;
scm_t_bits dyn_n;
SCM ha, tag = SCM_EOL;
......@@ -996,6 +1060,7 @@ void inline falsify_entries(SCM *ci,struct gp_stack *gp)
// Use this functionto prune the control stack and also perhaps clear
// The stacks completely.
// Todo make this work for sub engines currently we do nothing between engines
static inline void gp_prune(SCM s, int tailp)
{
struct gp_stack *gp = get_gp();
......@@ -1006,6 +1071,14 @@ static inline void gp_prune(SCM s, int tailp)
{
tag = gp_car(gp_car(s, s),s);
lt = gp_gp_cdr(s,s);
if(SCM_CONSP(lt))
{
SCM pth = SCM_CDR(lt);
lt = SCM_CAR(lt);
if(!(SCM_CONSP(gp_engine_path) && SCM_CONSP(pth) &&
scm_is_eq(SCM_CAR(pth), SCM_CAR(gp_engine_path))))
return; // Between engines we do nothing
}
fr = gp->gp_frstack + GP_GET_SELF_TAG(tag);
if(vlist_p(lt))
{
......@@ -1064,7 +1137,8 @@ static inline void gp_prune(SCM s, int tailp)
gp_debug2("2 si> %x %x\n",si - gp->gp_stack,si - gp->gp_cons_stack);
gp_unwind0(fr - (tailp?GP_FRAMESIZE:0),ci, si, cs, gp);
gp_unwind0(fr - (tailp?GP_FRAMESIZE:0),ci, si, cs, gp,
SCM_BOOL_F, SCM_BOOL_F);
}
......@@ -1086,7 +1160,7 @@ static inline void gp_unwind_ncons(SCM fr, int ncons)
static inline void gp_unwind_tail(SCM fr)
{
gp_unwind_(fr,2,2,1, SCM_EOL, SCM_BOOL_F););
gp_unwind_(fr,2,2,1, SCM_EOL, SCM_BOOL_F);
//gp_unwind_(fr,0,0,0, SCM_EOL, SCM_BOOL_F););
}
......@@ -1806,7 +1880,7 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
gp->gp_si - si,
gp->gp_cs - cs);
gp_unwind0(fr, ci, si, cs, gp);
gp_unwind0(fr, ci, si, cs, gp, SCM_BOOL_F, SCM_BOOL_F);
gp_debug0("scan ci stack\n");
......
......@@ -128,8 +128,8 @@ SCM gp_procedure_name(SCM f)
}
#define DB(X)
#define DS(X)
#define DB(X)
#define DS(X)
#define gp_debug0(s) DB(printf(s) ; fflush(stdout))
#define gp_debug1(s,a) DB(printf(s,a) ; fflush(stdout))
#define gp_debug2(s,a,b) DB(printf(s,a,b) ; fflush(stdout))
......@@ -339,7 +339,9 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
#include "vlist/vlist-wrap.c"
#include "logical.c"
#define UNPACK_S(l,gp,s,err) \
#define GET_L(l) (SCM_CONSP(l) ? SCM_CAR(l) : SCM_EOL)
#define UNPACK_S(ll,l,gp,s,err) \
{ \
SCM a; \
a = scm_fluid_ref(gp_current_stack); \
......@@ -349,15 +351,18 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
gp_debug0(err); \
if(GP_CONSP(s)) \
{ \
l = GP_GETREF(s)[2]; \
ll = GP_GETREF(s)[2]; \
l = GET_L(ll); \
} \
else if(SCM_CONSP(s)) \
{ \
l = SCM_CDR(s); \
ll = SCM_CDR(s); \
l = GET_L(ll); \
} \
else \
{ \
l = SCM_EOL; \
ll = scm_cons(SCM_EOL,SCM_EOL); \
} \
}
......@@ -369,11 +374,11 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
scm_misc_error("unpack_s0",err,SCM_EOL); \
if(GP_CONSP(s)) \
{ \
l = GP_GETREF(s)[2]; \
l = GET_L(GP_GETREF(s)[2]); \
} \
else if(SCM_CONSP(s)) \
{ \
l = SCM_CDR(s); \
l = GET_L(SCM_CDR(s)); \
} \
else \
{ \
......@@ -381,7 +386,7 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
} \
}
#define UNPACK_ALL(fr,l,ggp,gp,s,err) \
#define UNPACK_ALL(fr,ll,l,ggp,gp,s,err) \
{ \
ggp = scm_fluid_ref(gp_current_stack); \
if(!GP_STACKP(ggp)) \
......@@ -389,17 +394,20 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
gp = GET_GP(ggp); \
if(GP_CONSP(s)) \
{ \
l = GP_GETREF(s)[2]; \
ll = GP_GETREF(s)[2]; \
l = GET_L(ll); \
fr = GP_GETREF(s)[1]; \
} \
else if (SCM_CONSP(s)) \
{ \
l = SCM_CDR(s); \
ll = SCM_CDR(s); \
l = GET_L(ll); \
fr = SCM_CAR(s); \
} \
else \
{ \
fr = PTR2NUM(gp->gp_fr); \
ll = scm_cons(SCM_EOL,SCM_EOL); \
l = SCM_EOL; \
} \
}
......@@ -412,11 +420,11 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
gp = GET_GP(ggp); \
if(GP_CONSP(s)) \
{ \
l = GP_GETREF(s)[2]; \
l = GET_L(GP_GETREF(s)[2]); \
} \
else if(SCM_CONSP(s)) \
{ \
l = SCM_CDR(s); \
l = GET_L(SCM_CDR(s)); \
} \
else \
{ \
......@@ -432,10 +440,10 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
gp = GET_GP(ggp); \
}
#define PACK_ALL(fr,l,lnew,gp,s) \
{ \
#define PACK_ALL(fr,ll,l,lnew,gp,s) \
{ \
if(!scm_is_eq(l,lnew)) \
s = scm_cons(fr,lnew); \
s = scm_cons(fr,scm_cons(l,SCM_CDR(ll))); \
}
inline SCM gp_make_s(SCM frci, SCM *l)
......@@ -843,7 +851,7 @@ static inline SCM gp_set_unbound_bang(SCM *id, SCM l, struct gp_stack *gp)
static inline SCM * gp_lookup(SCM *id, SCM l)
{
gp_debug0("lookup>\n");
gp_debug0("lookup l>\n");
retry:
......@@ -1250,7 +1258,7 @@ static inline SCM gp_newframe(SCM s)
else
{
s = SCM_PACK(0);
l = SCM_EOL;
l = scm_cons(SCM_EOL, gp_engine_path);
}
if(scm_is_eq(l, SCM_UNBOUND))
......@@ -1278,7 +1286,7 @@ static inline SCM gp_newframe(SCM s)
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);
......@@ -2507,7 +2515,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
//#define DB(X)
int _gp_unify(SCM **spp, int nargs, SCM *cl, SCM *max)
{
SCM fr, *sp, s,v1,v2,*vv1, *vv2, ret, l[3], ggp, old, oldi;
SCM fr, ll, *sp, s,v1,v2,*vv1, *vv2, ret, l[3], ggp, old, oldi;
struct gp_stack *gp;
gp_debug0("unify\n");
......@@ -2519,7 +2527,7 @@ int _gp_unify(SCM **spp, int nargs, SCM *cl, SCM *max)
if(SCM_UNLIKELY(nargs != 3))
scm_misc_error("gp-unify!","wrong number of arguments", SCM_EOL);
UNPACK_ALL(fr,l[0],ggp,gp,s,"failed to unpack in gp_gp_unify");
UNPACK_ALL(fr,ll, l[0],ggp,gp,s,"failed to unpack in gp_gp_unify");
old = l[0];
......@@ -2541,9 +2549,12 @@ int _gp_unify(SCM **spp, int nargs, SCM *cl, SCM *max)
if(ret)
{
if(vlist_p(l[0]) && oldi != l[2])
l[0] = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
{
l[0] = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
}
PACK_ALL(fr,ll,old,l[0],ggp,s);
PACK_ALL(fr,old,l[0],ggp,s);
sp[-3] = s;
*spp = sp - 3;
return -1;
......@@ -2558,11 +2569,11 @@ SCM_DEFINE(gp_gp_unify,"gp-unify!",3,0,0,(SCM v1, SCM v2, SCM s),
"unifies two gp variables")
#define FUNC_NAME s_gp_gp_unify
{
SCM fr, *vv1, *vv2, ret, l[3], ggp, old, oldi;
SCM fr, ll, *vv1, *vv2, ret, l[3], ggp, old, oldi;
struct gp_stack *gp;
gp_debus0("gp-unify!>\n");
UNPACK_ALL(fr, (l[0]),ggp,gp,s,"failed to unpack in gp_gp_unify");
UNPACK_ALL(fr,ll, (l[0]),ggp,gp,s,"failed to unpack in gp_gp_unify");
vv1 = UN_GP(v1);
......@@ -2583,8 +2594,12 @@ SCM_DEFINE(gp_gp_unify,"gp-unify!",3,0,0,(SCM v1, SCM v2, SCM s),
if(ret)
{
if(vlist_p(l[0]) && (oldi != l[2] || old != l[0]))
l[0] = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
PACK_ALL(fr, old, l[0], ggp,s);
{
l[0] = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
}
PACK_ALL(fr,ll, old, l[0], ggp,s);
//printf("true\n");
return s;
}
......@@ -2599,7 +2614,7 @@ SCM_DEFINE(gp_gp_unify,"gp-unify!",3,0,0,(SCM v1, SCM v2, SCM s),
int _gp_unify_raw(SCM **spp, int nargs, SCM *cl, SCM *max)
{
SCM fr, *sp, s,v1,v2,*vv1, *vv2, ret, l[3], ggp, old, oldi;
SCM fr, ll, *sp, s,v1,v2,*vv1, *vv2, ret, l[3], ggp, old, oldi;
struct gp_stack *gp;
sp = *spp;
......@@ -2611,7 +2626,7 @@ int _gp_unify_raw(SCM **spp, int nargs, SCM *cl, SCM *max)
if(SCM_UNLIKELY(nargs != 3))
scm_misc_error("gp-unify-raw!","wrong number of arguments", SCM_EOL);
UNPACK_ALL(fr, l[0],ggp,gp,s,"failed to unpack in gp_gp_unify");
UNPACK_ALL(fr,ll, l[0],ggp,gp,s,"failed to unpack in gp_gp_unify");
old = l[0];
......@@ -2633,9 +2648,12 @@ int _gp_unify_raw(SCM **spp, int nargs, SCM *cl, SCM *max)
if(ret)
{
if(vlist_p(l[0]) && (oldi != l[2] || old != l[0]))
{
l[0] = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
}
PACK_ALL(fr, old, l[0], ggp,s);
PACK_ALL(fr, ll, old, l[0], ggp,s);
sp[-3] = s;
*spp = sp - 3;
return -1;
......@@ -2650,11 +2668,11 @@ SCM_DEFINE(gp_gp_unify_raw,"gp-unify-raw!",3,0,0,(SCM v1, SCM v2, SCM s),
"unifies two gp variables")
#define FUNC_NAME s_gp_gp_unify
{
SCM fr,*vv1, *vv2, ret, l[3], ggp, old, oldi;
SCM fr, ll, *vv1, *vv2, ret, l[3], ggp, old, oldi;
struct gp_stack *gp;
gp_debus0("gp-unify-raw!>\n");
UNPACK_ALL(fr,l[0],ggp, gp,s,"failed to unpack in gp_gp_unify_raw");
UNPACK_ALL(fr,ll, l[0],ggp, gp,s,"failed to unpack in gp_gp_unify_raw");
old = l[0];
......@@ -2674,9 +2692,11 @@ SCM_DEFINE(gp_gp_unify_raw,"gp-unify-raw!",3,0,0,(SCM v1, SCM v2, SCM s),
if(ret)
{
if(vlist_p(l[0]) && oldi != l[2])
{
l[0] = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
}
PACK_ALL(fr,old,l[0],ggp,s);
PACK_ALL(fr,ll,old,l[0],ggp,s);
//printf("true\n");
return s;
......@@ -2753,7 +2773,8 @@ SCM_DEFINE(gp_atomicp,"gp-atomic?",2,0,0,(SCM x, SCM s),
}
#undef FUNC_NAME
static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp);
static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp, SCM path, SCM lpath);
void gp_unwind_dynstack(struct gp_stack *gp, scm_t_bits dyn_n);
SCM current_stack = SCM_BOOL_F;
......@@ -2776,7 +2797,7 @@ SCM_DEFINE(gp_clear, "gp-clear", 1, 0, 0, (SCM s),
gp_unwind0(gp->gp_frstack + GP_FRAMESIZE,
gp->gp_cstack + 1,
gp->gp_stack,
gp->gp_cons_stack, gp);
gp->gp_cons_stack, gp, SCM_BOOL_F, SCM_BOOL_F);
gp_debug0("clear 2\n");
gp_unwind_dynstack(gp, 2);
gp->rguards = SCM_EOL;
......@@ -2789,7 +2810,7 @@ SCM_DEFINE(gp_clear, "gp-clear", 1, 0, 0, (SCM s),
scm_cons(scm_cons(GP_GET_SELF(gp->gp_fr),
GP_GET_VAL (gp->gp_fr)),
SCM_EOL));
scm_cons(SCM_EOL, gp_engine_path)));
return SCM_BOOL_T;
}
......@@ -2807,9 +2828,9 @@ SCM_DEFINE(gp_gp, "gp?", 1, 0, 0, (SCM scm), "")
static inline SCM ggp_set(SCM var, SCM val, SCM s)
{
SCM *id,l,ret,ggp,fr;
SCM *id,l,ll,ret,ggp,fr;
struct gp_stack *gp;
UNPACK_ALL(fr,l,ggp,gp,s,"failed to unpack s in ggp_set");
UNPACK_ALL(fr,ll,l,ggp,gp,s,"failed to unpack s in ggp_set");
if(GP(var))
{
......@@ -2822,13 +2843,13 @@ static inline SCM ggp_set(SCM var, SCM val, SCM s)
if(GP(val))
{
ret = gp_set_ref(id,GP_UNREF(gp_gp_lookup(val,s)),l,gp);
PACK_ALL(fr, l ,ret, ggp, s);
PACK_ALL(fr, ll, l, ret, ggp, s);
return s;
}
else
{
ret = gp_set_val(id,val, l, gp);
PACK_ALL(fr, l ,ret, ggp, s);
PACK_ALL(fr, ll, l, ret, ggp, s);
return s;
}
}
......@@ -2839,9 +2860,9 @@ static inline SCM ggp_set(SCM var, SCM val, SCM s)
static inline SCM ggp_set2(SCM var, SCM val, SCM s)
{
SCM *id,l,ll;
SCM *id,l,lnew,ll;
struct gp_stack *gp;
UNPACK_S(l,gp,s,"cannot unpack s in ggp_set2");
UNPACK_S(ll,l,gp,s,"cannot unpack s in ggp_set2");
if(GP(var))
{
......@@ -2851,16 +2872,14 @@ static inline SCM ggp_set2(SCM var, SCM val, SCM s)
{
if(GP(val))
{
ll = gp_set_ref(id,GP_UNREF(gp_gp_lookup(val,s)),l,gp);
lnew = gp_set_ref(id,GP_UNREF(gp_gp_lookup(val,s)),l,gp);
}
else
{
ll = gp_set_val(id, val, l, gp);
lnew = gp_set_val(id, val, l, gp);
}
if(ll == l)
return s;
else
return scm_cons(SCM_CAR(s), ll);
PACK_ALL(0,ll,l,lnew,gp,s);
return s;
}
}
scm_misc_error("gp-set!","wrong type of the variable to set",SCM_EOL);
......@@ -2988,25 +3007,24 @@ SCM_DEFINE(gp_ref_set, "gp-ref-set!", 3, 0, 0, (SCM var, SCM val, SCM s),
"set gp var reference to val")
#define FUNC_NAME s_gp_ref_set
{
SCM *id,l,lnew;
SCM *id,l,ll,lnew;
struct gp_stack *gp;
if(GP(var))
{
if(GP(val) || SCM_VARIABLEP(val))
{
UNPACK_S(l,gp,s,"cannot unpack s in gp_ref_set");
UNPACK_S(ll,l,gp,s,"cannot unpack s in gp_ref_set");
lnew = gp_set_ref(GP_GETREF(var),val,l,gp);
}
else
{
UNPACK_S(l,gp,s,"cannot unpack s in gp_ref_set");
UNPACK_S(ll,l,gp,s,"cannot unpack s in gp_ref_set");
id = gp_lookup(GP_GETREF(var), l);
lnew = gp_set_val(id,val,l,gp);
}
if(l == lnew)
return s;
else
return scm_cons(SCM_CAR(s),lnew);
PACK_ALL(0,ll,l,lnew,gp,s);
return s;
}
scm_misc_error("gp-ref-set!", "wrong type to set", SCM_EOL);