added a functional tree stub

parent 73252347
//#(k v l r)
inline SCM make_new_gp_tree_node(SCM hash,SCM key,SCM val)
{
SCM ret = scm_c_make_vector(4,SCM_BOOL_F);
scm_c_vector_set_x(ret,0,hash);
scm_c_vector_set_x(ret,1,scm_cons(scm_cons(key,val),SCM_EOL));
return ret;
}
inline SCM make_gp_tree_node(SCM k,SCM v,SCM l,SCM r)
{
SCM ret = scm_c_make_vector(4,SCM_BOOL_F);
scm_c_vector_set_x(ret,0,k);
scm_c_vector_set_x(ret,1,v);
scm_c_vector_set_x(ret,2,l);
scm_c_vector_set_x(ret,3,r);
return ret;
}
SCM gp_tree_lookup(SCM tree, SCM hash, SCM key)
{
retry:
if(scm_is_false (scm_vector_p (tree))) return key;
SCM k = scm_c_vector_ref (tree,0);
if(scm_is_eq (hash,k))
{
SCM v = scm_c_vector_ref(tree,1);
retry_assq:
if(!SCM_CONSP (v)) return key;
SCM u = SCM_CAR (v);
if(!SCM_CONSP (u)) scm_misc_error("gp_tree_lookup","assumes a cons assq"
,SCM_EOL);
if(scm_is_eq (key, SCM_CAR (u))) return SCM_CDR (u);
v = SCM_CDR(v);
goto retry_assq;
}
if(SCM_UNPACK (hash) < SCM_UNPACK (k))
tree = scm_c_vector_ref (tree,2);
else
tree = scm_c_vector_ref (tree,3);
goto retry;
}
SCM gp_tree_add(SCM tree, SCM hash, SCM key, SCM val)
{
if(scm_is_false (scm_vector_p (tree)))
return make_new_gp_tree_node(hash,key,val);
SCM k = scm_c_vector_ref (tree,0);
if(scm_is_eq (hash,k))
{
SCM v = scm_cons (scm_cons (key,val), scm_c_vector_ref(tree,1));
make_gp_tree_node(k,v,scm_c_vector_ref(tree,2),scm_c_vector_ref(tree,3));
}
if(SCM_UNPACK (hash) < SCM_UNPACK (k))
return make_gp_tree_node(k,scm_c_vector_ref(tree,1),
gp_tree_add(scm_c_vector_ref(tree,2),
hash,key,val),
scm_c_vector_ref(tree,3));
else
return make_gp_tree_node(k,scm_c_vector_ref(tree,1),
scm_c_vector_ref(tree,2),
gp_tree_add(scm_c_vector_ref(tree,3),
hash,key,val));
}
......@@ -2,9 +2,21 @@
This define the logical variables
*/
#include <stdlib.h>
#include "functional-tree.c"
int _logical_ = 0;
SCM make_logical()
inline SCM get_gp_key(SCM *id)
{
if(GP_STAR(id))
return SCM_PACK(((SCM_UNPACK(id[0]) >> 20) & ~0x11) | 0x10);
scm_misc_error("get_gp_key","not a gp variables as input",SCM_EOL);
return 0;
}
inline SCM make_logical()
{
SCM ret,*id;
ret = SCM_NEWSMOB(ret,GP_MK_FRAME_UNBD(gp_type),
......@@ -12,7 +24,8 @@ SCM make_logical()
id = GP_GETREF(ret);
*(id + 0) = SCM_PACK(GP_MK_FRAME_UNBD(gp_type));
long k = random() << 20;
*(id + 0) = SCM_PACK(GP_MK_FRAME_UNBD(gp_type) | k);
*(id + 1) = SCM_UNBOUND;
return ret;
}
......@@ -25,7 +38,20 @@ inline SCM logical_lookup(SCM x, SCM s)
s = SCM_CDR(s);
else
return x;
/*
{
//new tree code here
retry_tree:
if(!GP_STAR(x)) return x;
SCM hash = get_gp_key(GP_GETREF(x));
SCM y = gp_tree_lookup(s,hash,x);
if(scm_is_eq(x,y)) return y;
x = y;
goto retry_tree;
}
*/
l = s;
if(!GP(x))
......@@ -65,7 +91,22 @@ inline SCM logical_lookup2(SCM x, SCM s)
s = SCM_CDR(s);
else
return x;
/*
{
//new tree code here
retry_tree:
if(!GP_STAR(x))
scm_misc_error("logical_lookup2","expected a logical variable",SCM_EOL);
SCM hash = get_gp_key(GP_GETREF(x));
SCM y = gp_tree_lookup(s,hash,x);
if(scm_is_eq(x,y)) return y;
if(!GP_STAR(y)) return x;
x = y;
goto retry_tree;
}
*/
l = s;
if(!GP(x))
......@@ -100,6 +141,17 @@ inline SCM logical_lookup2(SCM x, SCM s)
SCM logical_add(SCM x, SCM v, SCM s)
{
/*
{
//new tree code comes in here
if(!SCM_CONSP(s))
scm_misc_error("logical_add","malformed s",SCM_EOL);
SCM ss = SCM_CDR(s);
SCM hash = get_gp_key(GP_GETREF(x));
return scm_cons(SCM_CAR(s),gp_tree_add(ss,hash,x,v));
}
*/
if(SCM_CONSP(s))
return scm_cons(SCM_CAR(s),scm_cons(scm_cons(x,v),SCM_CDR(s)));
else
......
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