attributed.c

parent 07610add
SCM_DEFINE(gp_attvar, "gp-attvar", 1, 0, 0, (SCM x, SCM s),
"check to see if variable is an attributed variable")
#define FUNC_NAME s_gp_attvar
{
if(GP(x));
{
x = gp_gp_lookup(x);
if(GP(x) && (GP_ATTR(x) || GP_VAR(x)))
{
return SCM_BOOL_T;
}
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE(gp_put_attr, "gp-put-attr", 3, 0, 0, (SCM x, SCM lam, SCM val, SCM s),
"put an attrubute on a variable with unification handler lambda")
#define FUNC_NAME s_gp_get_attr
{
if(GP(x));
{
x = gp_gp_lookup(x);
if(GP(x))
{
if(GP_ATTR(x))
{
SCM it = GP_GETREF(x)[1];
if(GP_VAR(x))
{
SCM newvar = GP_IT(gp_mk_var(s));
s = gp_ref_set(x, scm_cons(scm_cons(lam, newvar)), s);
s = gp_ref_set(newvar, val, s);
}
else
{
int found = 0;
SCM l = it;
while(SCM_CONSP(l))
{
if(SCM_CONSP(SCM_CAR(l)))
if(scm_is_eq(SCM_CAAR(l), lam))
{
s = gp_set_ref(SCM_CDAR(l) val, s);
found = 1;
}
else
scm_misc_error("gp-put-attr","not an internal cons in the attribute list inside the attributed variable ~a~%",scm_list_1(l));
}
if(!found)
{
SCM newvar = GP_IT(gp_mk_var(s));
s = gp_set_ref(x, scm_cons(scm_cons(lam, newvar), it), s);
s = gp_ref_set(newvar, val, s);
}
}
}
else
scm_misc_error("gp-put-attr","not an attributed variable~a~%",
scm_list_1(x));
}
else
scm_misc_error("gp-put-attr","not an attributed variable ~a~%",
scm_list_1(x));
}
else
scm_misc_error("gp-put-attr","not an attributed variable ~a~%",
scm_list_1(x));
return s;
}
#undef FUNC_NAME
SCM_DEFINE(gp_get_attr, "gp-get-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
"get an attrubute on a variable with unification handler lambda")
#define FUNC_NAME s_gp_attvar
{
if(GP(x));
{
x = gp_gp_lookup(x);
if(GP(x))
{
if(GP_ATTR(x))
{
SCM it = GP_GETREF(x)[1];
if(GP_VAR(x))
{
return x;
}
else
{
SCM l = it;
while(SCM_CONSP(l))
{
if(SCM_CONSP(SCM_CAR(l)))
if(scm_is_eq(SCM_CAAR(l), lam))
{
return SCM_CDAR(l);
}
else
scm_misc_error("gp-put-attr","not an internal cons in the attribute list inside the attributed variable ~a~%",scm_list_1(l));
}
return SCM_UNBOUND;
}
}
else
return SCM_UNBOUND;
}
else
return SCM_UNBOUND;
}
else
return SCM_UNBOUND;
}
#undef FUNC_NAME
SCM_DEFINE(gp_det_attr, "gp-det-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
"delete an attrubute on a variable with unification handler lambda")
#define FUNC_NAME s_gp_del_attr
{
if(GP(x));
{
x = gp_gp_lookup(x);
if(GP(x))
{
if(GP_ATTR(x))
{
SCM it = GP_GETREF(x)[1];
if(GP_VAR(x))
{
return SCM_UNSPECIFIED;
}
else
{
SCM l = it;
SCM p = l;
SCM r = SCM_EOL;
while(SCM_CONSP(l))
{
if(SCM_CONSP(SCM_CAR(l)))
{
if(scm_is_eq(SCM_CAAR(l), lam))
{
r = SCM_CDR(l);
}
else
{
l = SCM_CDR(l);
p = scm_cons(SCM_CAR(l),p);
}
}
}
if(SCM_NULLP(p) && SCM_NULLP(r))
{
s = mkunbd(x,s);
}
else
{
while(SCM_CONSP(p))
{
r = scm_cons(SCM_CAR(p),r);
p = SCM_CDR(p);
}
s = gp_ref_set(x, val, s);
}
}
}
}
}
return s;
}
#undef FUNC_NAME
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