started debugging of assq code

parent 18ae5d4f
......@@ -11,7 +11,7 @@
let<> <or-i> <or-union> <stall> <continue> <take>
<state-ref> <state-set!> <lv*> <clear>
<and-i> and-interleave interleave tr
<letg> <set!> define-guarded *gp-var-tr*)
<letg> <set!> define-guarded *gp-var-tr* *kanren-assq*)
(re-export define-guile-log guile-log-macro? log-code-macro log-code-macro?)
......@@ -74,10 +74,13 @@
k)))
x)))))))
(define *kanren-assq* #f)
(define-syntax <run>
(syntax-rules (*)
((_ (v) code ...)
(let ((fr (gp-newframe #f)))
(if *kanren-assq*
(gp-logical++))
(with-guarded-states ret-set! ((ret '()))
(<eval> (v)
(<and> code ...)
......@@ -90,6 +93,8 @@
((_ (v ...) code ...)
(let ((fr (gp-newframe #f)))
(if *kanren-assq*
(gp-logical++))
(with-guarded-states ret-set! ((ret '()))
(<eval> (v ...)
(<and> code ...)
......@@ -107,6 +112,8 @@
((_ m (v) code ...)
(let ((fr (gp-newframe #f)))
(if *kanren-assq*
(gp-logical++))
(with-guarded-states n-ret-set! ((n m) (ret '()))
(<eval> (v)
(<and> code ...)
......@@ -136,6 +143,8 @@
((_ m (v ...) code ...)
(let ((fr (gp-newframe #f)))
(if *kanren-assq*
(gp-logical++))
(with-guarded-states n-ret-set! ((n m) (ret '()))
(<eval> (v ...)
(<and> code ...)
......
......@@ -6,22 +6,31 @@ int _logical_ = 0;
SCM make_logical()
{
SCM ret;
ret = SCM_NEWSMOB(ret,GP_MK_FRAME_UNBD(gp_type),(void *)0);
SCM ret,*id;
ret = SCM_NEWSMOB(ret,GP_MK_FRAME_UNBD(gp_type),
(void*)0);
id = GP_GETREF(ret);
*(id + 0) = SCM_PACK(GP_MK_FRAME_UNBD(gp_type));
*(id + 1) = SCM_UNBOUND;
return ret;
}
SCM logical_lookup(SCM x, SCM s)
inline SCM logical_lookup(SCM x, SCM s)
{
SCM l;
if(SCM_CONSP(s))
l = SCM_CDR(s);
s = SCM_CDR(s);
else
return x;
l = s;
if(!GP(x))
return x;
return x;
retry:
if(SCM_CONSP(l))
{
......@@ -50,10 +59,14 @@ SCM logical_lookup(SCM x, SCM s)
SCM logical_add(SCM x, SCM v, SCM s)
{
return scm_cons(SCM_CAR(s),scm_cons(scm_cons(x,v),SCM_CDR(s)));
if(SCM_CONSP(s))
return scm_cons(SCM_CAR(s),scm_cons(scm_cons(x,v),SCM_CDR(s)));
else
scm_misc_error("logical_add","malformed s",SCM_EOL);
return SCM_BOOL_F;
}
SCM_DEFINE(gp_logical_incr, "gp-logic++", 0, 0, 0, (),
SCM_DEFINE(gp_logical_incr, "gp-logical++", 0, 0, 0, (),
"increase logic indicator")
#define FUNC_NAME s_gp_logical_incr
{
......@@ -62,7 +75,7 @@ SCM_DEFINE(gp_logical_incr, "gp-logic++", 0, 0, 0, (),
}
#undef FUNC_NAME
SCM_DEFINE(gp_logical_decr, "gp-logic--", 0, 0, 0, (),
SCM_DEFINE(gp_logical_decr, "gp-logical--", 0, 0, 0, (),
"increase logic indicator")
#define FUNC_NAME s_gp_logical_incr
{
......
......@@ -41,8 +41,8 @@ scm_simple_format(SCM_BOOL_T, \
#define DB(X)
#define DS(X)
#define DB(X) X
#define DS(X) 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))
......@@ -183,8 +183,6 @@ static inline SCM alloc_unify_words (scm_t_bits car, scm_t_uint16 n_words)
#define GP_CDR(id) ((id) - 4)
#define GP_BUDY(id) ((id) + 2)
#include "logical.c"
static inline void swap_to_b()
{
gp_si_a = gp_si;
......@@ -271,13 +269,15 @@ static inline int GP(SCM scm)
(SCM_UNPACK(scm) < (scm_t_bits) gp_nns))
*/
SCM gp_unbound_sym;
SCM gp_unbound_str;
SCM gp_unwind_fluid;
SCM gp_cons_sym;
SCM gp_cons_str;
#include "logical.c"
#define GP_TEST_CSTACK if(gp_ci > gp_nnc) scm_out_of_range(NULL, SCM_I_MAKINUM(gp_nc))
......@@ -349,10 +349,14 @@ static inline SCM gp_set_ref(SCM *id, SCM ref, SCM s)
{
SCM val;
gp_debug0("setref ...");
if(_logical_) return logical_add(GP_UNREF(id),ref,s);
gp_debug0("setref ....");
if(!GP(ref)) return gp_set_val(id,ref,s);
gp_debug0("setref .....");
gp_store_var_2(id,0);
gp_debug0("setref ...");
val = SCM_PACK(GP_MK_FRAME_PTR(gp_type));
gp_debug2(">> id = %x, val = %x\n",(scm_t_bits) id, SCM_UNPACK(val));
......@@ -446,6 +450,15 @@ static inline SCM * gp_lookup(SCM *id, SCM s)
{
gp_debug0("lookup>\n");
id = GP_GETREF(logical_lookup(GP_UNREF(id),s));
gp_debug0("lookup> /2\n");
if(!GP_STAR(id))
{
gp_debug0("lookup> no star\n");
return id;
}
gp_debug0("lookup> /3\n");
retry:
if(GP_POINTER(id))
{
......@@ -535,11 +548,12 @@ static inline SCM gp_mk_cons()
static int gp_recurent(SCM *id1,SCM *id2, SCM s)
{
SCM scm;
gp_debug0("recurent>\n");
if(!GP(GP_UNREF(id2))) goto non_gp;
id2 = gp_lookup(id2,s);
gp_debug0("recurent> looked up data\n");
if(id1 == id2 )
{
......@@ -667,7 +681,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM s)
gp_debug0("11>\n");
id2 = gp_lookup(id2,s);
id1 = gp_lookup(id1,s);
if(! (GP_STAR(id1) && GP_STAR(id2))) goto retry;
if(SCM_CONSP(GP_SCM(id1)))
{
......@@ -696,8 +710,8 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM s)
{
gp_debug0("10>\n");
id1 = gp_lookup(id1,s);
gp_debug0("10> lookup\n");
if(! (GP_STAR(id1))) goto retry;
gp_debug0("10> lookup__\n");
if(SCM_CONSP(GP_SCM(id1)))
{
id1 = GP_GETREF(GP_SCM(id1));
......@@ -713,6 +727,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM s)
{
gp_debug0("01>\n");
id2 = gp_lookup(id2,s);
if(!(GP_STAR(id2))) goto retry;
if(SCM_CONSP(GP_SCM(id2)))
{
......@@ -823,13 +838,13 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM s)
unbound1:
gp_debug0("unify> unbound1\n");
if(!raw && GP_CONS(id2) && gp_recurent(id1,id2,s)) return 0;
if(!raw && GP_CONS(id2) && gp_recurent(id1,id2,s)) return (SCM) 0;
s = gp_set_ref(id1,GP_UNREF(gp_lookup(id2,s)),s);
U_NEXT;
unbound2:
gp_debug0("unify> unbound2\n");
if(!raw && GP_CONS(id1) && gp_recurent(id2,id1,s)) return 0;
if(!raw && GP_CONS(id1) && gp_recurent(id2,id1,s)) return (SCM) 0;
s = gp_set_ref(id2,GP_UNREF(gp_lookup(id1,s)),s);
U_NEXT;
......@@ -961,10 +976,11 @@ SCM_DEFINE(gp_gp_unify,"gp-unify!",3,0,0,(SCM v1, SCM v2, SCM s),
#define FUNC_NAME s_gp_gp_unify
{
SCM *vv1, *vv2, ret;
gp_debus0("gp-unify!>\n");
vv1 = UN_GP(v1);
vv2 = UN_GP(v2);
ret = gp_unify(vv1,vv2,0,1,s);
gp_debus0("/gp-unify!>\n");
return ret ? ret : SCM_BOOL_F;
}
#undef FUNC_NAME
......@@ -974,10 +990,11 @@ SCM_DEFINE(gp_gp_unify_raw,"gp-unify-raw!",3,0,0,(SCM v1, SCM v2, SCM s),
#define FUNC_NAME s_gp_gp_unify
{
SCM *vv1, *vv2, ret;
gp_debus0("gp-unify-raw!>\n");
vv1 = UN_GP(v1);
vv2 = UN_GP(v2);
ret = gp_unify(vv1,vv2,1,1,s);
gp_debus0("/gp-unify-raw!>\n");
return ret ? ret : SCM_BOOL_F;
}
#undef FUNC_NAME
......@@ -1034,7 +1051,7 @@ SCM_DEFINE(gp_varp,"gp-var?",2,0,0,(SCM x, SCM s),
if(GP(x))
{
id = gp_lookup(UN_GP(x), s);
return GP_UNBOUND(id) ? SCM_BOOL_T : SCM_BOOL_F;
return (GP_STAR(id) && GP_UNBOUND(id)) ? SCM_BOOL_T : SCM_BOOL_F;
}
return SCM_BOOL_F;
}
......@@ -1049,8 +1066,11 @@ SCM_DEFINE(gp_atomicp,"gp-atomic?",2,0,0,(SCM x, SCM s),
if(GP(x))
{
id = gp_lookup(UN_GP(x),s);
return (GP_VAL(id) && !SCM_CONSP(GP_SCM(id)))
? SCM_BOOL_T : SCM_BOOL_F;
if(GP_STAR(id))
return (GP_VAL(id) && !SCM_CONSP(GP_SCM(id)))
? SCM_BOOL_T : SCM_BOOL_F;
return SCM_CONSP(GP_UNREF(id)) ? SCM_BOOL_F : SCM_BOOL_T;
}
return scm_is_pair(x) ? SCM_BOOL_F : SCM_BOOL_T;
}
......@@ -1086,15 +1106,16 @@ static inline SCM ggp_set(SCM var, SCM val, SCM s)
{
id = GP_GETREF(var);
id = gp_lookup(id,s);
if(GP(val))
{
return gp_set_ref(id,GP_UNREF(gp_lookup(UN_GP(val),s)),s);
}
else
{
return gp_set_val(id,val, s);
}
}
if(GP_STAR(id))
if(GP(val))
{
return gp_set_ref(id,GP_UNREF(gp_lookup(UN_GP(val),s)),s);
}
else
{
return gp_set_val(id,val, s);
}
}
scm_misc_error("gp-set!","wrong type of the variable to set",SCM_EOL);
return SCM_BOOL_F;
}
......@@ -1219,6 +1240,7 @@ SCM_DEFINE(gp_pair_bang, "gp-pair!?", 2, 0, 0, (SCM x, SCM s),
#define FUNC_NAME s_gp_pair_bang
{
SCM * y;
gp_debus0("gp-pair!?>\n");
if(GP(x))
{
y = GP_GETREF(x);
......@@ -1247,6 +1269,7 @@ SCM_DEFINE(gp_pair, "gp-pair?", 2, 0, 0, (SCM x, SCM s),
"checks for a prolog pair or scheme pair")
#define FUNC_NAME s_gp_pair
{
gp_debus0("gp-pair?>\n");
if(GP(x))
{
//printf("pair gp-addr %x, val %x\n",SCM_UNPACK(x),SCM_UNPACK(*GP_GETREF(x)));
......@@ -1264,6 +1287,7 @@ SCM_DEFINE(gp_null, "gp-null?", 2, 0, 0, (SCM x, SCM s),
"checks for a prolog pair or scheme pair")
#define FUNC_NAME s_gp_null
{
gp_debus0("gp-null?>\n");
if(GP(x))
{
SCM *id = GP_GETREF(x);
......@@ -1282,6 +1306,7 @@ SCM_DEFINE(gp_null_bang, "gp-null!?", 2, 0, 0, (SCM x, SCM s),
#define FUNC_NAME s_gp_null_bang
{
SCM * y;
gp_debus0("gp-null!?>\n");
if(GP(x))
{
y = GP_GETREF(x);
......@@ -1338,7 +1363,7 @@ SCM_DEFINE(gp_car, "gp-car", 1, 0, 0, (SCM x),
"takes car a prolog pair or scheme pair")
#define FUNC_NAME s_gp_car
{
//printf("gp-car>\n");
gp_debus0("gp-car?>\n");
if(GP(x))
{
return GP_UNREF(GP_CAR(GP_GETREF(x)));
......@@ -1355,7 +1380,7 @@ SCM_DEFINE(gp_gp_cdr, "gp-cdr", 1, 0, 0, (SCM x),
"takes cdr a prolog pair or scheme pair")
#define FUNC_NAME s_gp_gp_cdr
{
//printf("gp-cdr>\n");
gp_debus0("gp-cdr>\n");
if(GP(x))
{
return GP_UNREF(GP_CDR(GP_GETREF(x)));
......
......@@ -72,7 +72,7 @@ SCM_API SCM gp_dynwind(SCM in, SCM out);
//SCM_API SCM gp_copy(SCM x);
SCM_API SCM gp_gp_jumpframe_start();
SCM_API SCM gp_gp_jumpframe_end();
SCM_API SCM gp_jumpframe_start();
SCM_API SCM gp_jumpframe_end();
SCM_API SCM gp_logical_incr();
SCM_API SCM gp_logical_decr();
......@@ -39,7 +39,8 @@
umatch gp-logical-var?
gp-copy **um** gp-get-stack
push-setup que-setup
with-guarded-states with-guarded-globals gp->scm))
with-guarded-states with-guarded-globals gp->scm
gp-logical++ gp-logical--))
(define gp-module-init #f)
(define gp? #f)
......@@ -206,7 +207,7 @@
(let ((x (glup x)))
(if (gp? x)
(if (gp-pair x '())
(if (gp-pair? x '())
(let-values (((l d) (get-line x '())))
(if (null? x)
(f l "")
......@@ -379,4 +380,3 @@
(define (gp-restore-state x)
(set! *wind* #f)
(gp-restore-state-raw x))
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