further developments of attributed variables

parent 5db91ca9
......@@ -15,6 +15,7 @@ SOURCES = \
logic/guile-log/code-load.scm \
logic/guile-log/vlist.scm \
logic/guile-log/indexer.scm \
logic/guile-log/attributed.scm \
logic/guile-log/umatch.scm \
logic/guile-log/macros.scm \
logic/guile-log/run.scm \
......
(define-module (logic guile-log attributed)
#:use-module (logic guile-log code-load)
#:export (add-attribute-printer
attribute-printer-ref
att-printer)
#:re-export (
gp-attvar?
gp-attvar-raw?
gp-put-attr
gp-get-attr
gp-del-attr
gp-att-data
))
(define *printers* (make-weak-key-hash-table))
(define (default-printer lam x s)
(format #f "(~a : ~a)" lam x))
(define (add-attribute-printer lam printer)
(hashq-set! *printers* lam printer))
(define (attribute-printer-ref lam)
(hashq-ref *printers* lam default-printer))
(define (att-printer port x s)
(format port "@<~{~a,~}>"
(map (lambda (x)
((attribute-printer-ref (car x)) (car x) (cdr x) s))
(gp-att-data x s))))
......@@ -94,6 +94,13 @@
namespace-lexical?
setup-namespace
<namespace-type>
gp-attvar?
gp-attvar-raw?
gp-att-data
gp-put-attr
gp-get-attr
gp-del-attr
))
;; Tos silence the compiler, those are fetched from the .so file
......
SCM_DEFINE(gp_attvar, "gp-attvar", 1, 0, 0, (SCM x, SCM s),
SCM_DEFINE(gp_attvar, "gp-attvar?", 2, 0, 0, (SCM x, SCM s),
"check to see if variable is an attributed variable")
#define FUNC_NAME s_gp_attvar
{
SCM l;
UNPACK_S0(l,s,"cannot unpack s in gp_ref_set");
SCM *ref;
if(GP(x));
{
ref = gp_lookup2(GP_GETREF(x), l);
if(GP(x) && (GP_ATTR(ref) || GP_UNBOUND(ref)))
{
return SCM_BOOL_T;
}
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE(gp_attdata, "gp-att-data", 2, 0, 0, (SCM x, SCM s),
"check to see if variable is an attributed variable")
#define FUNC_NAME s_gp_attdata
{
SCM l;
UNPACK_S0(l,s,"cannot unpack s in gp_ref_set");
SCM *ref;
if(GP(x));
{
x = gp_gp_lookup(x);
if(GP(x) && (GP_ATTR(x) || GP_VAR(x)))
ref = gp_lookup2(GP_GETREF(x), l);
if(GP(x) && GP_ATTR(ref))
{
return ref[1];
}
}
return SCM_UNBOUND;
}
#undef FUNC_NAME
SCM_DEFINE(gp_attvar_raw, "gp-attvar-raw?", 2, 0, 0, (SCM x, SCM s),
"check to see if variable is an raw attributed variable")
#define FUNC_NAME s_gp_attvar_raw
{
SCM l;
UNPACK_S0(l,s,"cannot unpack s in gp_ref_set");
SCM *ref;
if(GP(x));
{
ref = gp_lookup2(GP_GETREF(x), l);
if(GP(x) && (GP_ATTR(ref)))
{
return SCM_BOOL_T;
}
......@@ -15,22 +59,29 @@ SCM_DEFINE(gp_attvar, "gp-attvar", 1, 0, 0, (SCM x, SCM s),
#undef FUNC_NAME
SCM_DEFINE(gp_put_attr, "gp-put-attr", 3, 0, 0, (SCM x, SCM lam, SCM val, SCM s),
SCM_DEFINE(gp_put_attr, "gp-put-attr", 4, 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));
if(GP(x))
{
x = gp_gp_lookup(x);
SCM l;
UNPACK_S0(l,s,"cannot unpack s in gp_ref_set");
SCM *ref;
ref = gp_lookup2(GP_GETREF(x), l);
ref = GP_GETREF(x);
if(GP(x))
{
if(GP_ATTR(x))
if(GP_ATTR(ref) || GP_UNBOUND(ref))
{
SCM it = GP_GETREF(x)[1];
if(GP_VAR(x))
SCM it = ref[1];
if(GP_UNBOUND(ref))
{
SCM newvar = GP_IT(gp_mk_var(s));
s = gp_ref_set(x, scm_cons(scm_cons(lam, newvar)), s);
s = gp_ref_attr_set
(GP_UNREF(ref), scm_cons(scm_cons(lam, newvar),SCM_EOL), s);
s = gp_ref_set(newvar, val, s);
}
else
......@@ -40,18 +91,23 @@ SCM_DEFINE(gp_put_attr, "gp-put-attr", 3, 0, 0, (SCM x, SCM lam, SCM val, SCM s)
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;
}
{
if(scm_is_eq(SCM_CAAR(l), lam))
{
s = gp_ref_set(SCM_CDAR(l), val, s);
found = 1;
break;
}
l = SCM_CDR(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));
}
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
(GP_UNREF(ref), scm_cons(scm_cons(lam, newvar), it), s);
s = gp_ref_set(newvar, val, s);
}
}
......@@ -77,27 +133,32 @@ 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))
if(GP(x))
{
SCM l;
UNPACK_S0(l,s,"cannot unpack s in gp_ref_set");
SCM *ref;
ref = gp_lookup2(GP_GETREF(x), l);
if(1)
{
if(GP_ATTR(ref))
{
SCM it = ref[1];
if(GP_UNBOUND(ref))
{
return x;
}
else
{
SCM l = it;
while(SCM_CONSP(l))
{
if(SCM_CONSP(SCM_CAR(l)))
{
return SCM_CDAR(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));
......@@ -117,26 +178,28 @@ SCM_DEFINE(gp_get_attr, "gp-get-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
}
#undef FUNC_NAME
SCM_DEFINE(gp_det_attr, "gp-det-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
SCM_DEFINE(gp_del_attr, "gp-del-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);
x = gp_gp_lookup(x , s);
lam = gp_gp_lookup(lam, s);
if(GP(x))
{
if(GP_ATTR(x))
SCM *ref = GP_GETREF(x);
if(GP_ATTR(ref))
{
SCM it = GP_GETREF(x)[1];
if(GP_VAR(x))
SCM it = ref[1];
if(GP_UNBOUND(ref))
{
return SCM_UNSPECIFIED;
}
else
{
SCM l = it;
SCM p = l;
SCM p = SCM_EOL;
SCM r = SCM_EOL;
while(SCM_CONSP(l))
{
......@@ -145,18 +208,25 @@ SCM_DEFINE(gp_det_attr, "gp-det-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
if(scm_is_eq(SCM_CAAR(l), lam))
{
r = SCM_CDR(l);
break;
}
else
{
l = SCM_CDR(l);
p = scm_cons(SCM_CAR(l),p);
l = SCM_CDR(l);
}
}
}
if(SCM_NULLP(p) && SCM_NULLP(r))
{
s = mkunbd(x,s);
SCM l,ret,ggp,ci;
struct gp_stack *gp;
UNPACK_ALL(ci,l,ggp,gp,s,"failed to unpack s in delattr");
ret = gp_set_unbound(ref,l,gp);
PACK_ALL(ci, l ,ret, ggp, s);
}
else
{
......@@ -165,8 +235,7 @@ SCM_DEFINE(gp_det_attr, "gp-det-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
r = scm_cons(SCM_CAR(p),r);
p = SCM_CDR(p);
}
s = gp_ref_set(x, val, s);
s = gp_ref_set(x, r, s);
}
}
}
......
......@@ -61,6 +61,9 @@ inline SCM logical_lookup(SCM x, SCM l)
if(!GP(x))
return x;
if(GP_STAR(GP_GETREF(x)) && GP_ATTR(GP_GETREF(x)))
return x;
retry:
if(SCM_CONSP(l))
......@@ -73,6 +76,10 @@ inline SCM logical_lookup(SCM x, SCM l)
x = SCM_CDR(car);
if(!GP(x))
return x;
if(GP_STAR(GP_GETREF(x)) && GP_ATTR(GP_GETREF(x)))
return x;
if(!GP_UNBOUND(GP_GETREF(x)))
return x;
l = s;
......
......@@ -229,6 +229,7 @@ scm_t_bits gp_smob_t;
#define N_BITS 22
#define H_BITS 36
#define GP_ATTR_IT(x) ((x) = ((x) | GPI_ATTR))
#define GP_GC_MARK(x) ((x) = ((x) | GPI_SCM_M))
#define GP_GC_ISMARKED(x) ((x) & GPI_SCM_M)
......@@ -538,6 +539,22 @@ static inline SCM gp_set_val(SCM *id, SCM v, SCM l, struct gp_stack *gp)
return handle(id, flags, v, l, gp, 0, 0);
}
static inline SCM gp_set_attr_val(SCM *id, SCM v, SCM l, struct gp_stack *gp)
{
SCM flags;
if(GP_IS_EQ(v))
flags = SCM_PACK(GP_MK_FRAME_EQ(gp_type));
else
flags = SCM_PACK(GP_MK_FRAME_VAL(gp_type));
{
scm_t_bits f = SCM_UNPACK(flags);
GP_ATTR_IT(f);
flags = SCM_PACK(f);
}
return handle(id, flags, v, l, gp, 0, 0);
}
static inline SCM gp_set_val_l(SCM *id, SCM v, SCM *l, struct gp_stack *gp)
{
......@@ -674,7 +691,9 @@ static inline SCM * gp_lookup(SCM *id, SCM l)
retry:
if(GP_STAR(id) && GP_ATTR(id))
return id;
if(GP_STAR(id) && GP_POINTER(id))
{
id = GP_GETREF(GP_SCM(id));
......@@ -697,6 +716,9 @@ static inline SCM * gp_lookup(SCM *id, SCM l)
gp_debug0("lookup> /3\n");
if(GP_STAR(id) && GP_ATTR(id))
return id;
if(GP_STAR(id) && GP_POINTER(id))
{
id = GP_GETREF(GP_SCM(id));
......@@ -755,6 +777,9 @@ static inline SCM * gp_lookup_ll(SCM *id, SCM *l)
retry:
if(GP_STAR(id) && GP_ATTR(id))
return id;
if(GP_STAR(id) && GP_POINTER(id))
{
id = GP_GETREF(GP_SCM(id));
......@@ -779,6 +804,9 @@ static inline SCM * gp_lookup_ll(SCM *id, SCM *l)
gp_debug0("lookup> /3\n");
if(GP_STAR(id) && GP_ATTR(id))
return id;
if(GP_STAR(id) && GP_POINTER(id))
{
id = GP_GETREF(GP_SCM(id));
......@@ -1271,6 +1299,9 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
gp_debug0("11>\n");
gp_lookup_l(id2,id2,l);
gp_lookup_l(id1,id1,l);
if(GP_ATTR(id1) && !GP_UNBOUND(id1)) goto retry_attr;
if(GP_ATTR(id2) && !GP_UNBOUND(id2)) goto retry_attr_rev;
if(! (GP_STAR(id1) && GP_STAR(id2))) goto retry;
......@@ -1304,6 +1335,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
gp_debug0("10>\n");
gp_lookup_l(id1,id1,l);
if(! (GP_STAR(id1))) goto retry;
if(GP_ATTR(id1) && !GP_UNBOUND(id1)) goto retry_attr;
gp_debug0("10> lookup__\n");
if(SCM_CONSP(GP_SCM(id1)))
{
......@@ -1322,7 +1354,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
gp_debug0("01>\n");
gp_lookup_l(id2,id2,l);
if(!(GP_STAR(id2))) goto retry;
if(GP_ATTR(id2) && !GP_UNBOUND(id2)) goto retry_attr_rev;
if(SCM_CONSP(GP_SCM(id2)))
{
id2 = GP_GETREF(GP_SCM(id2));
......@@ -1339,7 +1371,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
// u11 Has unbounded variables
gp_debug0("unify> looked up with u11\n");
if(0 && GP_ATTR(id1) && SCM_CONSP(id1[1]))
if(GP_ATTR(id1) && !GP_UNBOUND(id1))
{
retry_attr:
{
......@@ -1359,17 +1391,23 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
SCM xl = id1[1];
while(SCM_CONSP(xl))
{
s =
scm_call_5(SCM_CAAR(xl), SCM_CDAR(xl),
*id2, scm_raw, scm_plus, s);
if(scm_is_false(s))
return (SCM) 0;
gp_format1("processing ~a~%", SCM_CAR(xl));
if(SCM_CONSP(SCM_CAR(xl)))
{
s =
scm_call_5(SCM_CAAR(xl), SCM_CDAR(xl),GP_UNREF(id2),
scm_raw,
scm_plus, s);
gp_format1("processing got ~a~%", s);
if(scm_is_false(s))
return (SCM) 0;
xl = SCM_CDR(xl);
}
}
xl = SCM_CDR(xl);
}
{
SCM ll = SCM_CDR(s);
if(vlist_p(ll))
......@@ -1380,14 +1418,19 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
else
l[0] = ll;
}
U_NEXT;
}
}
else if (0 && GP_ATTR(id2) && SCM_CONSP(id2[1]))
else if (GP_ATTR(id2) && !GP_UNBOUND(id2))
{
SCM *temp = id1;
id1 = id2;
id2 = temp;
goto retry_attr;
retry_attr_rev:
{
SCM *temp = id1;
id1 = id2;
id2 = temp;
goto retry_attr;
}
}
if(GP_UNBOUND(id1))
......@@ -2416,6 +2459,33 @@ SCM_DEFINE(gp_ref_set, "gp-ref-set!", 3, 0, 0, (SCM var, SCM val, SCM s),
}
#undef FUNC_NAME
SCM_DEFINE(gp_ref_attr_set, "gp-ref-attr-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;
struct gp_stack *gp;
if(GP(var))
{
if(GP(val))
{
UNPACK_S(l,gp,s,"cannot unpack s in gp_ref_set");
return gp_set_ref(GP_GETREF(var),val,l,gp);
}
else
{
UNPACK_S(l,gp,s,"cannot unpack s in gp_ref_set");
id = gp_lookup(GP_GETREF(var), l);
return gp_set_attr_val(id,val,l,gp);
}
return SCM_BOOL_T;
}
scm_misc_error("gp-ref-set!", "wrong type to set", SCM_EOL);
return SCM_BOOL_F;
}
#undef FUNC_NAME
/* new api so that pure ffi will work */
SCM_DEFINE(gp_cons_bang, "gp-cons!", 3, 0, 0, (SCM car, SCM cdr, SCM s),
"crates a prolog variable cons pair")
......@@ -2696,7 +2766,7 @@ SCM_DEFINE(gp_gp_lookup, "gp-lookup", 2, 0, 0, (SCM x, SCM s),
gp_debug0("gp-lookup\n");
id = gp_lookup(GP_GETREF(x),l);
if(!GP_STAR(id)) return GP_UNREF(id);
if(GP_UNBOUND(id) || GP_CONS(id))
if(GP_UNBOUND(id) || GP_CONS(id) || GP_ATTR(id))
return GP_UNREF(id);
else
return GP_SCM(id);
......@@ -3005,7 +3075,7 @@ SCM_DEFINE(gp_fluid_set_bang, "gp-var-set", 3, 0, 0, (SCM f, SCM v, SCM s),
SCM *id, l;
struct gp_stack *gp;
UNPACK_S(l,gp,s,"failed to unpack s in gp_fluid_set");
UNPACK_S(l,gp,s,"failed to unpack s in gp_fluid_set_bang");
int old = gp->_logical_;
gp->_logical_ = 0;
......@@ -3183,7 +3253,7 @@ int _gp_pair_star(SCM **spp, int nargs, SCM *cl, SCM *max)
//#include "util.c"
#include "indexer/indexer.c"
#include "attributed.c"
void gp_init()
{
#include "unify.x"
......
......@@ -119,3 +119,10 @@ SCM_API SCM gp_clear_frame();
SCM_API SCM gp_clear_frame_x(SCM s);
SCM_API SCM gp_gc();
SCM_API SCM gp_attvar(SCM x, SCM s);
SCM_API SCM gp_attvar_raw(SCM x, SCM s);
SCM_API SCM gp_attdata(SCM x, SCM s);
SCM_API SCM gp_put_attr(SCM x, SCM lam, SCM val, SCM s);
SCM_API SCM gp_get_attr(SCM x, SCM lam, SCM s);
SCM_API SCM gp_del_attr(SCM x, SCM lam, SCM s);
......@@ -20,6 +20,7 @@
(define-module (logic guile-log umatch)
#:use-module (logic guile-log code-load)
#:use-module (logic guile-log attributed)
#:use-module (ice-9 match-phd-lookup)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 format)
......@@ -63,7 +64,15 @@
gp-cont-ids-ref
gp-cont-ids-set!
gp-gc)
gp-gc
gp-attvar?
gp-attvar-raw?
gp-att-data
gp-put-attr
gp-get-attr
gp-del-attr
)
......@@ -182,13 +191,18 @@
(let ((s (fluid-ref *current-stack*)))
(let ((x (glup x s)))
(if (gp? x)
(if (gp-pair? x s)
(cond
((gp-attvar-raw? x s)
(att-printer port x s))
((gp-pair? x s)
(let-values (((l d) (get-line x '())))
(if (null? x)
(f l "")
(f l (format #f " . ~a" d))))
(f l (format port " . ~a" d)))))
(else
(let ((varn (gp-var-number x s)))
(format port "<#~a>" (m varn))))
(format port "<#~a>" (m varn)))))
(format port "<#gp ~a>" x)))))
(define gp-var-ref
......
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